{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE UndecidableInstances  #-}

module Gibbon.Language
    ( module Gibbon.Language.Constants
    , module Gibbon.Language.Syntax

      -- * Helpers operating on expressions
    , mapExt, mapLocs, mapExprs, mapMExprs, visitExp
    , subst, substE, hasTimeIt, hasSpawns, hasSpawnsProg, projNonFirst
    , mkProj, mkProd, mkLets, flatLets, tuplizeRefs

      -- * Helpers operating on types
    , mkProdTy, projTy , voidTy, isProdTy, isNestedProdTy, isPackedTy, isScalarTy
    , hasPacked, sizeOfTy, primArgsTy, primRetTy, tyToDataCon
    , stripTyLocs, isValidListElemTy, getPackedTys

      -- * Misc
    , assertTriv, assertTrivs

    ) where

import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
-- import           Data.Functor.Foldable
import           Text.PrettyPrint.GenericPretty

import           Gibbon.Language.Constants
import           Gibbon.Language.Syntax
import           Gibbon.Common
import GHC.Stack

--------------------------------------------------------------------------------

instance (Out l, Show l, Show d, Out d, Expression (e l d))
      => Expression (PreExp e l d) where
  type (TyOf (PreExp e l d))  = d
  type (LocOf (PreExp e l d)) = l
  isTrivial :: PreExp e l d -> Bool
isTrivial = PreExp e l d -> Bool
f
    where
      f :: (PreExp e l d) -> Bool
      f :: PreExp e l d -> Bool
f PreExp e l d
e =
       case PreExp e l d
e of
        VarE Var
_     -> Bool
True
        LitE Int
_     -> Bool
True
        CharE Char
_    -> Bool
True
        FloatE{}   -> Bool
True
        LitSymE Var
_  -> Bool
True
        PrimAppE{} -> Bool
False

        ----------------- POLICY DECISION ---------------
        -- Tuples and projections are NOT trivial!
        ProjE{}    -> Bool
False
        MkProdE{}  -> Bool
False

        -- DataCon's are a bit tricky.  May want to inline them at
        -- some point if it avoids region conflicts.
        DataConE{} -> Bool
False

        IfE{}      -> Bool
False
        CaseE{}    -> Bool
False
        LetE {}    -> Bool
False
        MapE {}    -> Bool
False
        FoldE {}   -> Bool
False
        AppE  {}   -> Bool
False
        TimeIt {}  -> Bool
False
        WithArenaE{} -> Bool
False
        SpawnE{}   -> Bool
False
        PreExp e l d
SyncE      -> Bool
False
        Ext e l d
ext -> e l d -> Bool
forall e. Expression e => e -> Bool
isTrivial e l d
ext

-- | Free data variables.  Does not include function variables, which
-- currently occupy a different namespace.  Does not include location/region variables.
instance FreeVars (e l d) => FreeVars (PreExp e l d) where
  gFreeVars :: PreExp e l d -> Set Var
gFreeVars PreExp e l d
ex = case PreExp e l d
ex of
      VarE Var
v    -> Var -> Set Var
forall a. a -> Set a
S.singleton Var
v
      LitE Int
_    -> Set Var
forall a. Set a
S.empty
      CharE Char
_   -> Set Var
forall a. Set a
S.empty
      FloatE{}  -> Set Var
forall a. Set a
S.empty
      LitSymE Var
_ -> Set Var
forall a. Set a
S.empty
      ProjE Int
_ PreExp e l d
e -> PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
e
      IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c -> PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
a Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
b Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
c
      AppE Var
v [l]
_ [PreExp e l d]
ls         -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ (Var -> Set Var
forall a. a -> Set a
S.singleton Var
v) Set Var -> [Set Var] -> [Set Var]
forall a. a -> [a] -> [a]
: ((PreExp e l d -> Set Var) -> [PreExp e l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp e l d]
ls)
      PrimAppE Prim d
_ [PreExp e l d]
ls        -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((PreExp e l d -> Set Var) -> [PreExp e l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp e l d]
ls)
      LetE (Var
v,[l]
_,d
_,PreExp e l d
rhs) PreExp e l d
bod -> PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
rhs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union`
                              Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v (PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
bod)
      CaseE PreExp e l d
e [(DataCon, [(Var, l)], PreExp e l d)]
ls -> Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union (PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
e)
                    ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ ((DataCon, [(Var, l)], PreExp e l d) -> Set Var)
-> [(DataCon, [(Var, l)], PreExp e l d)] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(DataCon
_, [(Var, l)]
vlocs, PreExp e l d
ee) ->
                                           let ([Var]
vars,[l]
_) = [(Var, l)] -> ([Var], [l])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, l)]
vlocs
                                           in (PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
ee) Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
vars))
                                [(DataCon, [(Var, l)], PreExp e l d)]
ls)
      MkProdE [PreExp e l d]
ls          -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> Set Var) -> [PreExp e l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp e l d]
ls
      DataConE l
_ DataCon
_ [PreExp e l d]
ls     -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> Set Var) -> [PreExp e l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp e l d]
ls
      TimeIt PreExp e l d
e d
_ Bool
_        -> PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
e
      MapE (Var
v,d
_t,PreExp e l d
rhs) PreExp e l d
bod -> PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
rhs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union`
                             Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v (PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
bod)
      FoldE (Var
v1,d
_t1,PreExp e l d
r1) (Var
v2,d
_t2,PreExp e l d
r2) PreExp e l d
bod ->
          PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
r1 Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
r2 Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union`
          (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v1 (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v2 (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
bod)

      WithArenaE Var
v PreExp e l d
e -> Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars PreExp e l d
e

      SpawnE Var
v [l]
_ [PreExp e l d]
ls -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ (Var -> Set Var
forall a. a -> Set a
S.singleton Var
v) Set Var -> [Set Var] -> [Set Var]
forall a. a -> [a] -> [a]
: ((PreExp e l d -> Set Var) -> [PreExp e l d] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars [PreExp e l d]
ls)
      PreExp e l d
SyncE -> Set Var
forall a. Set a
S.empty

      Ext e l d
q -> e l d -> Set Var
forall a. FreeVars a => a -> Set Var
gFreeVars e l d
q


-- | A Typeable instance for L1 and L3 (L2 defines it's own)
instance (Show (), Out (),
          TyOf (e () (UrTy ())) ~ TyOf (PreExp e () (UrTy ())),
          FunctionTy (UrTy ()), Typeable (e () (UrTy ())))
       => Typeable (PreExp e () (UrTy ())) where
  gRecoverType :: DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
ex =
    case PreExp e () (UrTy ())
ex of
      VarE Var
v       -> UrTy () -> Var -> TyEnv (UrTy ()) -> UrTy ()
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (DataCon -> UrTy ()
forall a. HasCallStack => DataCon -> a
error (DataCon -> UrTy ()) -> DataCon -> UrTy ()
forall a b. (a -> b) -> a -> b
$ DataCon
"Cannot find type of variable " DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ Var -> DataCon
forall a. Show a => a -> DataCon
show Var
v DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ DataCon
" in " DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ TyEnv (UrTy ()) -> DataCon
forall a. Show a => a -> DataCon
show (Env2 (UrTy ()) -> TyEnv (UrTy ())
forall a. Env2 a -> TyEnv a
vEnv Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2)) Var
v (Env2 (UrTy ()) -> TyEnv (UrTy ())
forall a. Env2 a -> TyEnv a
vEnv Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2)
      LitE Int
_       -> TyOf (PreExp e () (UrTy ()))
UrTy ()
forall loc. UrTy loc
IntTy
      CharE Char
_      -> TyOf (PreExp e () (UrTy ()))
UrTy ()
forall loc. UrTy loc
CharTy
      FloatE{}     -> TyOf (PreExp e () (UrTy ()))
UrTy ()
forall loc. UrTy loc
FloatTy
      LitSymE Var
_    -> TyOf (PreExp e () (UrTy ()))
UrTy ()
forall loc. UrTy loc
SymTy
      AppE Var
v [()]
_ [PreExp e () (UrTy ())]
_   -> ArrowTy (TyOf (PreExp e () (UrTy ())))
-> TyOf (PreExp e () (UrTy ()))
forall ty. FunctionTy ty => ArrowTy ty -> ty
outTy (ArrowTy (TyOf (PreExp e () (UrTy ())))
 -> TyOf (PreExp e () (UrTy ())))
-> ArrowTy (TyOf (PreExp e () (UrTy ())))
-> TyOf (PreExp e () (UrTy ()))
forall a b. (a -> b) -> a -> b
$ Env2 (UrTy ()) -> Map Var (ArrowTy (UrTy ()))
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2 Map Var (ArrowTy (UrTy ())) -> Var -> ArrowTy (UrTy ())
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v
      PrimAppE (DictInsertP UrTy ()
ty) ((VarE Var
v):[PreExp e () (UrTy ())]
_) -> Maybe Var -> UrTy () -> UrTy ()
forall loc. Maybe Var -> UrTy () -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v) (UrTy () -> UrTy ()) -> UrTy () -> UrTy ()
forall a b. (a -> b) -> a -> b
$ UrTy () -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy ()
ty
      PrimAppE (DictEmptyP  UrTy ()
ty) ((VarE Var
v):[PreExp e () (UrTy ())]
_) -> Maybe Var -> UrTy () -> UrTy ()
forall loc. Maybe Var -> UrTy () -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v) (UrTy () -> UrTy ()) -> UrTy () -> UrTy ()
forall a b. (a -> b) -> a -> b
$ UrTy () -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy ()
ty
      PrimAppE Prim (UrTy ())
p [PreExp e () (UrTy ())]
_ -> Prim (UrTy ()) -> UrTy ()
forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim (UrTy ())
p

      LetE (Var
v,[()]
_,UrTy ()
t,PreExp e () (UrTy ())
_) PreExp e () (UrTy ())
e -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs (Var -> UrTy () -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v UrTy ()
t Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2) PreExp e () (UrTy ())
e
      IfE PreExp e () (UrTy ())
_ PreExp e () (UrTy ())
e PreExp e () (UrTy ())
_        -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e
      MkProdE [PreExp e () (UrTy ())]
es       -> [UrTy ()] -> UrTy ()
forall loc. [UrTy loc] -> UrTy loc
ProdTy ([UrTy ()] -> UrTy ()) -> [UrTy ()] -> UrTy ()
forall a b. (a -> b) -> a -> b
$ (PreExp e () (UrTy ()) -> UrTy ())
-> [PreExp e () (UrTy ())] -> [UrTy ()]
forall a b. (a -> b) -> [a] -> [b]
L.map (DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2) [PreExp e () (UrTy ())]
es
      DataConE ()
loc DataCon
c [PreExp e () (UrTy ())]
_ -> DataCon -> () -> UrTy ()
forall loc. DataCon -> loc -> UrTy loc
PackedTy (DDefs (UrTy ()) -> DataCon -> DataCon
forall a. Out a => DDefs a -> DataCon -> DataCon
getTyOfDataCon DDefs (TyOf (PreExp e () (UrTy ())))
DDefs (UrTy ())
ddfs DataCon
c) ()
loc
      TimeIt PreExp e () (UrTy ())
e UrTy ()
_ Bool
_     -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e
      MapE (Var, UrTy (), PreExp e () (UrTy ()))
_ PreExp e () (UrTy ())
e         -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e
      FoldE (Var, UrTy (), PreExp e () (UrTy ()))
_ (Var, UrTy (), PreExp e () (UrTy ()))
_ PreExp e () (UrTy ())
e      -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e
      Ext e () (UrTy ())
ext          -> DDefs (TyOf (e () (UrTy ())))
-> Env2 (TyOf (e () (UrTy ())))
-> e () (UrTy ())
-> TyOf (e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (e () (UrTy ())))
DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (e () (UrTy ())))
Env2 (TyOf (PreExp e () (UrTy ())))
env2 e () (UrTy ())
ext
      ProjE Int
i PreExp e () (UrTy ())
e ->
        case DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e of
          (ProdTy [UrTy ()]
tys) -> [UrTy ()]
tys [UrTy ()] -> Int -> UrTy ()
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
          TyOf (PreExp e () (UrTy ()))
oth -> DataCon -> TyOf (PreExp e () (UrTy ()))
forall a. HasCallStack => DataCon -> a
error(DataCon -> TyOf (PreExp e () (UrTy ())))
-> DataCon -> TyOf (PreExp e () (UrTy ()))
forall a b. (a -> b) -> a -> b
$ DataCon
"typeExp: Cannot project fields from this type: "DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++UrTy () -> DataCon
forall a. Show a => a -> DataCon
show TyOf (PreExp e () (UrTy ()))
UrTy ()
oth
                        DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++DataCon
"\nExpression:\n  "DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ PreExp e () (UrTy ()) -> DataCon
forall a. Out a => a -> DataCon
sdoc PreExp e () (UrTy ())
ex
                        DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++DataCon
"\nEnvironment:\n  "DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++TyEnv (UrTy ()) -> DataCon
forall a. Out a => a -> DataCon
sdoc (Env2 (UrTy ()) -> TyEnv (UrTy ())
forall a. Env2 a -> TyEnv a
vEnv Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2)
      WithArenaE Var
_v PreExp e () (UrTy ())
e -> DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs Env2 (TyOf (PreExp e () (UrTy ())))
env2 PreExp e () (UrTy ())
e
      SpawnE Var
v [()]
_ [PreExp e () (UrTy ())]
_    -> ArrowTy (TyOf (PreExp e () (UrTy ())))
-> TyOf (PreExp e () (UrTy ()))
forall ty. FunctionTy ty => ArrowTy ty -> ty
outTy (ArrowTy (TyOf (PreExp e () (UrTy ())))
 -> TyOf (PreExp e () (UrTy ())))
-> ArrowTy (TyOf (PreExp e () (UrTy ())))
-> TyOf (PreExp e () (UrTy ()))
forall a b. (a -> b) -> a -> b
$ Env2 (UrTy ()) -> Map Var (ArrowTy (UrTy ()))
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2 Map Var (ArrowTy (UrTy ())) -> Var -> ArrowTy (UrTy ())
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v
      PreExp e () (UrTy ())
SyncE           -> TyOf (PreExp e () (UrTy ()))
UrTy ()
forall loc. UrTy loc
voidTy
      CaseE PreExp e () (UrTy ())
_ [(DataCon, [(Var, ())], PreExp e () (UrTy ()))]
mp ->
        let (DataCon
c,[(Var, ())]
args,PreExp e () (UrTy ())
e) = [(DataCon, [(Var, ())], PreExp e () (UrTy ()))]
-> (DataCon, [(Var, ())], PreExp e () (UrTy ()))
forall a. HasCallStack => [a] -> a
head [(DataCon, [(Var, ())], PreExp e () (UrTy ()))]
mp
            args' :: [Var]
args' = ((Var, ()) -> Var) -> [(Var, ())] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var, ()) -> Var
forall a b. (a, b) -> a
fst [(Var, ())]
args
        in DDefs (TyOf (PreExp e () (UrTy ())))
-> Env2 (TyOf (PreExp e () (UrTy ())))
-> PreExp e () (UrTy ())
-> TyOf (PreExp e () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e () (UrTy ())))
ddfs (TyEnv (UrTy ()) -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, UrTy ())] -> TyEnv (UrTy ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [UrTy ()] -> [(Var, UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
args' (DDefs (UrTy ()) -> DataCon -> [UrTy ()]
forall a. Out a => DDefs a -> DataCon -> [a]
lookupDataCon DDefs (TyOf (PreExp e () (UrTy ())))
DDefs (UrTy ())
ddfs DataCon
c))) Env2 (TyOf (PreExp e () (UrTy ())))
Env2 (UrTy ())
env2) PreExp e () (UrTy ())
e


instance Renamable Var where
  gRename :: Map Var Var -> Var -> Var
gRename Map Var Var
env Var
v = Var -> Var -> Map Var Var -> Var
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Var
v Var
v Map Var Var
env

instance HasSubstitutable e l d => Substitutable (PreExp e l d) where
  gSubst :: Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
gSubst  = Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst
  gSubstE :: PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
gSubstE = PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE

instance HasRenamable e l d => Renamable (PreExp e l d) where
  gRename :: Map Var Var -> PreExp e l d -> PreExp e l d
gRename Map Var Var
env PreExp e l d
ex =
    case PreExp e l d
ex of
      VarE Var
v -> Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Var -> Var
forall a. Renamable a => a -> a
go Var
v)
      LitE{}    -> PreExp e l d
ex
      CharE{}   -> PreExp e l d
ex
      FloatE{}  -> PreExp e l d
ex
      LitSymE{} -> PreExp e l d
ex
      AppE Var
f [l]
locs [PreExp e l d]
args -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE (Var -> Var
forall a. Renamable a => a -> a
go Var
f) ([l] -> [l]
forall a. Renamable a => [a] -> [a]
gol [l]
locs) ([PreExp e l d] -> [PreExp e l d]
forall a. Renamable a => [a] -> [a]
gol [PreExp e l d]
args)
      PrimAppE Prim d
pr [PreExp e l d]
args -> Prim d -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim d
pr ([PreExp e l d] -> [PreExp e l d]
forall a. Renamable a => [a] -> [a]
gol [PreExp e l d]
args)
      LetE (Var
v,[l]
locs,d
ty,PreExp e l d
rhs) PreExp e l d
bod -> (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var -> Var
forall a. Renamable a => a -> a
go Var
v, [l] -> [l]
forall a. Renamable a => [a] -> [a]
gol [l]
locs, d -> d
forall a. Renamable a => a -> a
go d
ty, PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
rhs) (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
bod)
      IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c  -> PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
a) (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
b) (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
c)
      MkProdE [PreExp e l d]
ls -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([PreExp e l d] -> [PreExp e l d]
forall a. Renamable a => [a] -> [a]
gol [PreExp e l d]
ls)
      ProjE Int
i PreExp e l d
e  -> Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
e)
      CaseE PreExp e l d
scrt [(DataCon, [(Var, l)], PreExp e l d)]
ls ->
        PreExp e l d
-> [(DataCon, [(Var, l)], PreExp e l d)] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(DataCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
scrt) (((DataCon, [(Var, l)], PreExp e l d)
 -> (DataCon, [(Var, l)], PreExp e l d))
-> [(DataCon, [(Var, l)], PreExp e l d)]
-> [(DataCon, [(Var, l)], PreExp e l d)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DataCon
a,[(Var, l)]
b,PreExp e l d
c) -> (DataCon
a, ((Var, l) -> (Var, l)) -> [(Var, l)] -> [(Var, l)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
d,l
e) -> (Var -> Var
forall a. Renamable a => a -> a
go Var
d, l -> l
forall a. Renamable a => a -> a
go l
e)) [(Var, l)]
b, PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
c)) [(DataCon, [(Var, l)], PreExp e l d)]
ls)
      DataConE l
loc DataCon
dcon [PreExp e l d]
ls -> l -> DataCon -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
loc -> DataCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE (l -> l
forall a. Renamable a => a -> a
go l
loc) DataCon
dcon ([PreExp e l d] -> [PreExp e l d]
forall a. Renamable a => [a] -> [a]
gol [PreExp e l d]
ls)
      TimeIt PreExp e l d
e d
ty Bool
b -> PreExp e l d -> d -> Bool -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
e) (d -> d
forall a. Renamable a => a -> a
go d
ty) Bool
b
      SpawnE Var
f [l]
locs [PreExp e l d]
args -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE (Var -> Var
forall a. Renamable a => a -> a
go Var
f) ([l] -> [l]
forall a. Renamable a => [a] -> [a]
gol [l]
locs) ([PreExp e l d] -> [PreExp e l d]
forall a. Renamable a => [a] -> [a]
gol [PreExp e l d]
args)
      PreExp e l d
SyncE   -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
      WithArenaE Var
v PreExp e l d
e -> Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE (Var -> Var
forall a. Renamable a => a -> a
go Var
v) (PreExp e l d -> PreExp e l d
forall a. Renamable a => a -> a
go PreExp e l d
e)
      Ext e l d
ext -> e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (e l d -> e l d
forall a. Renamable a => a -> a
go e l d
ext)
      MapE{}  -> PreExp e l d
ex
      FoldE{} -> PreExp e l d
ex
     where
       go :: forall a. Renamable a => a -> a
       go :: forall a. Renamable a => a -> a
go = Map Var Var -> a -> a
forall e. Renamable e => Map Var Var -> e -> e
gRename Map Var Var
env

       gol :: forall a. Renamable a => [a] -> [a]
       gol :: forall a. Renamable a => [a] -> [a]
gol [a]
ls = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. Renamable a => a -> a
go [a]
ls

instance Renamable a => Renamable (UrTy a) where
  gRename :: Map Var Var -> UrTy a -> UrTy a
gRename Map Var Var
env = (a -> a) -> UrTy a -> UrTy a
forall a b. (a -> b) -> UrTy a -> UrTy b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Var Var -> a -> a
forall e. Renamable e => Map Var Var -> e -> e
gRename Map Var Var
env)


--------------------------------------------------------------------------------
-- Helpers operating on expressions
--------------------------------------------------------------------------------

-- | Apply a function to the extension points only.
mapExt :: (e1 l d -> e2 l d) -> PreExp e1 l d -> PreExp e2 l d
mapExt :: forall (e1 :: * -> * -> *) l d (e2 :: * -> * -> *).
(e1 l d -> e2 l d) -> PreExp e1 l d -> PreExp e2 l d
mapExt e1 l d -> e2 l d
fn = (l -> l)
-> (e1 l d -> e2 l d) -> (d -> d) -> PreExp e1 l d -> PreExp e2 l d
forall l1 l2 (e1 :: * -> * -> *) (e2 :: * -> * -> *) d1 d2.
(l1 -> l2)
-> (e1 l1 d1 -> e2 l2 d2)
-> (d1 -> d2)
-> PreExp e1 l1 d1
-> PreExp e2 l2 d2
visitExp l -> l
forall a. a -> a
id e1 l d -> e2 l d
fn d -> d
forall a. a -> a
id

-- | Apply a function to the locations only.
mapLocs :: (e l2 d -> e l2 d) -> PreExp e l2 d -> PreExp e l2 d
mapLocs :: forall (e :: * -> * -> *) l2 d.
(e l2 d -> e l2 d) -> PreExp e l2 d -> PreExp e l2 d
mapLocs e l2 d -> e l2 d
fn = (l2 -> l2)
-> (e l2 d -> e l2 d) -> (d -> d) -> PreExp e l2 d -> PreExp e l2 d
forall l1 l2 (e1 :: * -> * -> *) (e2 :: * -> * -> *) d1 d2.
(l1 -> l2)
-> (e1 l1 d1 -> e2 l2 d2)
-> (d1 -> d2)
-> PreExp e1 l1 d1
-> PreExp e2 l2 d2
visitExp l2 -> l2
forall a. a -> a
id e l2 d -> e l2 d
fn d -> d
forall a. a -> a
id

-- | Transform the expressions within a program.
mapExprs :: (e -> e) -> Prog e -> Prog e
mapExprs :: forall e. (e -> e) -> Prog e -> Prog e
mapExprs e -> e
fn prg :: Prog e
prg@Prog{FunDefs e
fundefs :: FunDefs e
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs,Maybe (e, TyOf e)
mainExp :: Maybe (e, TyOf e)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} =
  let mainExp' :: Maybe (e, TyOf e)
mainExp' = case Maybe (e, TyOf e)
mainExp of
                   Maybe (e, TyOf e)
Nothing -> Maybe (e, TyOf e)
forall a. Maybe a
Nothing
                   Just (e
ex,TyOf e
ty) -> (e, TyOf e) -> Maybe (e, TyOf e)
forall a. a -> Maybe a
Just (e -> e
fn e
ex, TyOf e
ty)
  in
  Prog e
prg{ fundefs :: FunDefs e
fundefs = (FunDef e -> FunDef e) -> FunDefs e -> FunDefs e
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\FunDef e
g -> FunDef e
g {funBody :: e
funBody = e -> e
fn (FunDef e -> e
forall ex. FunDef ex -> ex
funBody FunDef e
g)}) FunDefs e
fundefs
     , mainExp :: Maybe (e, TyOf e)
mainExp =  Maybe (e, TyOf e)
mainExp' }

-- | Monadic 'mapExprs'.
mapMExprs :: Monad m => (e -> m e) -> Prog e -> m (Prog e)
mapMExprs :: forall (m :: * -> *) e.
Monad m =>
(e -> m e) -> Prog e -> m (Prog e)
mapMExprs e -> m e
fn prg :: Prog e
prg@Prog{FunDefs e
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs e
fundefs,Maybe (e, TyOf e)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (e, TyOf e)
mainExp} = do
  Maybe (e, TyOf e)
mainExp' <- case Maybe (e, TyOf e)
mainExp of
                Maybe (e, TyOf e)
Nothing -> Maybe (e, TyOf e) -> m (Maybe (e, TyOf e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (e, TyOf e)
forall a. Maybe a
Nothing
                Just (e
ex,TyOf e
ty) -> do e
ex' <- e -> m e
fn e
ex
                                   Maybe (e, TyOf e) -> m (Maybe (e, TyOf e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (e, TyOf e) -> m (Maybe (e, TyOf e)))
-> Maybe (e, TyOf e) -> m (Maybe (e, TyOf e))
forall a b. (a -> b) -> a -> b
$ (e, TyOf e) -> Maybe (e, TyOf e)
forall a. a -> Maybe a
Just (e
ex', TyOf e
ty)
  FunDefs e
fundefs' <- (FunDef e -> m (FunDef e)) -> FunDefs e -> m (FunDefs e)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Var a -> f (Map Var b)
traverse (\FunDef e
g -> do e
funBody' <- e -> m e
fn (FunDef e -> e
forall ex. FunDef ex -> ex
funBody FunDef e
g)
                                 FunDef e -> m (FunDef e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef e -> m (FunDef e)) -> FunDef e -> m (FunDef e)
forall a b. (a -> b) -> a -> b
$ FunDef e
g {funBody :: e
funBody = e
funBody'})
                       FunDefs e
fundefs
  Prog e -> m (Prog e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prog e -> m (Prog e)) -> Prog e -> m (Prog e)
forall a b. (a -> b) -> a -> b
$ Prog e
prg { fundefs :: FunDefs e
fundefs = FunDefs e
fundefs', mainExp :: Maybe (e, TyOf e)
mainExp = Maybe (e, TyOf e)
mainExp' }


-- | Apply a function to the locations, extensions, and
-- binder-decorations, respectively.
visitExp :: forall l1 l2 e1 e2 d1 d2 .
            (l1 -> l2) -> (e1 l1 d1 -> e2 l2 d2) -> (d1 -> d2) ->
            PreExp e1 l1 d1 -> PreExp e2 l2  d2
visitExp :: forall l1 l2 (e1 :: * -> * -> *) (e2 :: * -> * -> *) d1 d2.
(l1 -> l2)
-> (e1 l1 d1 -> e2 l2 d2)
-> (d1 -> d2)
-> PreExp e1 l1 d1
-> PreExp e2 l2 d2
visitExp l1 -> l2
_fl e1 l1 d1 -> e2 l2 d2
fe d1 -> d2
_fd PreExp e1 l1 d1
exp0 = PreExp e1 l1 d1 -> PreExp e2 l2 d2
go PreExp e1 l1 d1
exp0
 where
   go :: (PreExp e1 l1  d1) -> (PreExp e2 l2 d2)
   go :: PreExp e1 l1 d1 -> PreExp e2 l2 d2
go PreExp e1 l1 d1
ex =
     case PreExp e1 l1 d1
ex of
       Ext  e1 l1 d1
x  -> e2 l2 d2 -> PreExp e2 l2 d2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (e1 l1 d1 -> e2 l2 d2
fe e1 l1 d1
x)
       PreExp e1 l1 d1
_       -> PreExp e2 l2 d2
_finishme


-- | Substitute an expression in place of a variable.
subst :: HasSubstitutable e l d
      => Var -> (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d)
subst :: forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst Var
old PreExp e l d
new PreExp e l d
ex =
  let go :: PreExp e l d -> PreExp e l d
go = Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst Var
old PreExp e l d
new in
  case PreExp e l d
ex of
    VarE Var
v | Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old  -> PreExp e l d
new
           | Bool
otherwise -> Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
    LitE Int
_             -> PreExp e l d
ex
    CharE{}            -> PreExp e l d
ex
    FloatE{}           -> PreExp e l d
ex
    LitSymE Var
_          -> PreExp e l d
ex
    AppE Var
v [l]
loc [PreExp e l d]
ls      -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [l]
loc ((PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls)
    PrimAppE Prim d
p [PreExp e l d]
ls      -> Prim d -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim d
p ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    LetE (Var
v,[l]
loc,d
t,PreExp e l d
rhs) PreExp e l d
bod | Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old  -> (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[l]
loc,d
t,PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) PreExp e l d
bod
                           | Bool
otherwise -> (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[l]
loc,d
t,PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)
    ProjE Int
i PreExp e l d
e  -> Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (PreExp e l d -> PreExp e l d
go PreExp e l d
e)
    CaseE PreExp e l d
e [(DataCon, [(Var, l)], PreExp e l d)]
ls ->
                  PreExp e l d
-> [(DataCon, [(Var, l)], PreExp e l d)] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(DataCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (PreExp e l d -> PreExp e l d
go PreExp e l d
e) (((DataCon, [(Var, l)], PreExp e l d)
 -> (DataCon, [(Var, l)], PreExp e l d))
-> [(DataCon, [(Var, l)], PreExp e l d)]
-> [(DataCon, [(Var, l)], PreExp e l d)]
forall a b. (a -> b) -> [a] -> [b]
L.map (DataCon, [(Var, l)], PreExp e l d)
-> (DataCon, [(Var, l)], PreExp e l d)
f [(DataCon, [(Var, l)], PreExp e l d)]
ls)
                      where f :: (DataCon, [(Var, l)], PreExp e l d)
-> (DataCon, [(Var, l)], PreExp e l d)
f (DataCon
c,[(Var, l)]
vs,PreExp e l d
er) = if Var -> [Var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.elem Var
old (((Var, l) -> Var) -> [(Var, l)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var, l) -> Var
forall a b. (a, b) -> a
fst [(Var, l)]
vs)
                                          then (DataCon
c,[(Var, l)]
vs,PreExp e l d
er)
                                          else (DataCon
c,[(Var, l)]
vs,PreExp e l d -> PreExp e l d
go PreExp e l d
er)
    MkProdE [PreExp e l d]
ls        -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    DataConE l
loc DataCon
k [PreExp e l d]
ls -> l -> DataCon -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
loc -> DataCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE l
loc DataCon
k ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    TimeIt PreExp e l d
e d
t Bool
b      -> PreExp e l d -> d -> Bool -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp e l d -> PreExp e l d
go PreExp e l d
e) d
t Bool
b
    IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c         -> PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp e l d -> PreExp e l d
go PreExp e l d
a) (PreExp e l d -> PreExp e l d
go PreExp e l d
b) (PreExp e l d -> PreExp e l d
go PreExp e l d
c)

    SpawnE Var
v [l]
loc [PreExp e l d]
ls   -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [l]
loc ((PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls)
    PreExp e l d
SyncE             -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE

    MapE (Var
v,d
t,PreExp e l d
rhs) PreExp e l d
bod | Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old  -> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE (Var
v,d
t, PreExp e l d
rhs)    (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)
                       | Bool
otherwise -> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE (Var
v,d
t, PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)
    FoldE (Var
v1,d
t1,PreExp e l d
r1) (Var
v2,d
t2,PreExp e l d
r2) PreExp e l d
bod ->
        let r1' :: PreExp e l d
r1' = if Var
v1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old then PreExp e l d
r1 else PreExp e l d -> PreExp e l d
go PreExp e l d
r1
            r2' :: PreExp e l d
r2' = if Var
v2 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old then PreExp e l d
r2 else PreExp e l d -> PreExp e l d
go PreExp e l d
r2
        in (Var, d, PreExp e l d)
-> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> (Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec
-> PreExp ext loc dec
FoldE (Var
v1,d
t1,PreExp e l d
r1') (Var
v2,d
t2,PreExp e l d
r2') (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)

    Ext e l d
ext -> e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreExp e l d -> e l d -> e l d
forall e ext. SubstitutableExt e ext => Var -> e -> ext -> ext
gSubstExt Var
old PreExp e l d
new e l d
ext)

    WithArenaE Var
v PreExp e l d
e | Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
old  -> Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v PreExp e l d
e
                   | Bool
otherwise -> Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (PreExp e l d -> PreExp e l d
go PreExp e l d
e)


-- | Expensive 'subst' that looks for a whole matching sub-EXPRESSION.
-- If the old expression is a variable, this still avoids going under binder.
substE :: HasSubstitutable e l d
       => (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d)
substE :: forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp e l d
old PreExp e l d
new PreExp e l d
ex =
  let go :: PreExp e l d -> PreExp e l d
go = PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp e l d
old PreExp e l d
new in
  case PreExp e l d
ex of
    PreExp e l d
_ | PreExp e l d
ex PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old   -> PreExp e l d
new

    VarE Var
v          -> Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
    LitE Int
_          -> PreExp e l d
ex
    CharE Char
_         -> PreExp e l d
ex
    FloatE{}        -> PreExp e l d
ex
    LitSymE Var
_       -> PreExp e l d
ex
    AppE Var
v [l]
loc [PreExp e l d]
ls   -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [l]
loc ((PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls)
    PrimAppE Prim d
p [PreExp e l d]
ls   -> Prim d -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim d
p ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    LetE (Var
v,[l]
loc,d
t,PreExp e l d
rhs) PreExp e l d
bod | (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v) PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old  -> (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[l]
loc,d
t,PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) PreExp e l d
bod
                           | Bool
otherwise -> (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[l]
loc,d
t,PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)

    ProjE Int
i PreExp e l d
e         -> Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (PreExp e l d -> PreExp e l d
go PreExp e l d
e)
    CaseE PreExp e l d
e [(DataCon, [(Var, l)], PreExp e l d)]
ls        -> PreExp e l d
-> [(DataCon, [(Var, l)], PreExp e l d)] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(DataCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (PreExp e l d -> PreExp e l d
go PreExp e l d
e) (((DataCon, [(Var, l)], PreExp e l d)
 -> (DataCon, [(Var, l)], PreExp e l d))
-> [(DataCon, [(Var, l)], PreExp e l d)]
-> [(DataCon, [(Var, l)], PreExp e l d)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(DataCon
c,[(Var, l)]
vs,PreExp e l d
er) -> (DataCon
c,[(Var, l)]
vs,PreExp e l d -> PreExp e l d
go PreExp e l d
er)) [(DataCon, [(Var, l)], PreExp e l d)]
ls)
    MkProdE [PreExp e l d]
ls        -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    DataConE l
loc DataCon
k [PreExp e l d]
ls -> l -> DataCon -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
loc -> DataCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE l
loc DataCon
k ([PreExp e l d] -> PreExp e l d) -> [PreExp e l d] -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls
    TimeIt PreExp e l d
e d
t Bool
b      -> PreExp e l d -> d -> Bool -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp e l d -> PreExp e l d
go PreExp e l d
e) d
t Bool
b
    IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c         -> PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp e l d -> PreExp e l d
go PreExp e l d
a) (PreExp e l d -> PreExp e l d
go PreExp e l d
b) (PreExp e l d -> PreExp e l d
go PreExp e l d
c)
    SpawnE Var
v [l]
loc [PreExp e l d]
ls   -> Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [l]
loc ((PreExp e l d -> PreExp e l d) -> [PreExp e l d] -> [PreExp e l d]
forall a b. (a -> b) -> [a] -> [b]
map PreExp e l d -> PreExp e l d
go [PreExp e l d]
ls)
    PreExp e l d
SyncE             -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    MapE (Var
v,d
t,PreExp e l d
rhs) PreExp e l d
bod | Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old  -> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE (Var
v,d
t, PreExp e l d
rhs)    (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)
                       | Bool
otherwise -> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE (Var
v,d
t, PreExp e l d -> PreExp e l d
go PreExp e l d
rhs) (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)
    FoldE (Var
v1,d
t1,PreExp e l d
r1) (Var
v2,d
t2,PreExp e l d
r2) PreExp e l d
bod ->
        let r1' :: PreExp e l d
r1' = if Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v1 PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old then PreExp e l d
r1 else PreExp e l d -> PreExp e l d
go PreExp e l d
r1
            r2' :: PreExp e l d
r2' = if Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v2 PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old then PreExp e l d
r2 else PreExp e l d -> PreExp e l d
go PreExp e l d
r2
        in (Var, d, PreExp e l d)
-> (Var, d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> (Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec
-> PreExp ext loc dec
FoldE (Var
v1,d
t1,PreExp e l d
r1') (Var
v2,d
t2,PreExp e l d
r2') (PreExp e l d -> PreExp e l d
go PreExp e l d
bod)

    Ext e l d
ext -> e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (PreExp e l d -> PreExp e l d -> e l d -> e l d
forall e ext. SubstitutableExt e ext => e -> e -> ext -> ext
gSubstEExt PreExp e l d
old PreExp e l d
new e l d
ext)

    WithArenaE Var
v PreExp e l d
e | (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v) PreExp e l d -> PreExp e l d -> Bool
forall a. Eq a => a -> a -> Bool
== PreExp e l d
old -> Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v PreExp e l d
e
                   | Bool
otherwise -> Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (PreExp e l d -> PreExp e l d
go PreExp e l d
e)


-- | Does the expression contain a TimeIt form?
hasTimeIt :: (PreExp e l d) -> Bool
hasTimeIt :: forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
rhs =
    case PreExp e l d
rhs of
      TimeIt PreExp e l d
_ d
_ Bool
_ -> Bool
True
      DataConE{}   -> Bool
False
      VarE Var
_       -> Bool
False
      LitE Int
_       -> Bool
False
      CharE Char
_      -> Bool
False
      FloatE{}     -> Bool
False
      LitSymE Var
_    -> Bool
False
      AppE Var
_ [l]
_ [PreExp e l d]
_   -> Bool
False
      PrimAppE Prim d
_ [PreExp e l d]
_ -> Bool
False
      ProjE Int
_ PreExp e l d
e    -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e
      MkProdE [PreExp e l d]
ls   -> (PreExp e l d -> Bool) -> [PreExp e l d] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt [PreExp e l d]
ls
      IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c    -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
a Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
b Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
c
      CaseE PreExp e l d
_ [(DataCon, [(Var, l)], PreExp e l d)]
ls   -> (PreExp e l d -> Bool) -> [PreExp e l d] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt [ PreExp e l d
e | (DataCon
_,[(Var, l)]
_,PreExp e l d
e) <- [(DataCon, [(Var, l)], PreExp e l d)]
ls ]
      LetE (Var
_,[l]
_,d
_,PreExp e l d
e1) PreExp e l d
e2 -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e2
      SpawnE Var
_ [l]
_ [PreExp e l d]
_       -> Bool
False
      PreExp e l d
SyncE              -> Bool
False
      MapE (Var
_,d
_,PreExp e l d
e1) PreExp e l d
e2   -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e2
      FoldE (Var
_,d
_,PreExp e l d
e1) (Var
_,d
_,PreExp e l d
e2) PreExp e l d
e3 -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e2 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e3
      Ext e l d
_ -> Bool
False
      WithArenaE Var
_ PreExp e l d
e -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasTimeIt PreExp e l d
e

hasSpawnsProg :: Prog (PreExp e l d) -> Bool
hasSpawnsProg :: forall (e :: * -> * -> *) l d. Prog (PreExp e l d) -> Bool
hasSpawnsProg (Prog DDefs (TyOf (PreExp e l d))
_ FunDefs (PreExp e l d)
fundefs Maybe (PreExp e l d, TyOf (PreExp e l d))
mainExp) =
  (FunDef (PreExp e l d) -> Bool) -> [FunDef (PreExp e l d)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\FunDef{PreExp e l d
funBody :: forall ex. FunDef ex -> ex
funBody :: PreExp e l d
funBody} -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
funBody) (FunDefs (PreExp e l d) -> [FunDef (PreExp e l d)]
forall k a. Map k a -> [a]
M.elems FunDefs (PreExp e l d)
fundefs) Bool -> Bool -> Bool
||
    case Maybe (PreExp e l d, TyOf (PreExp e l d))
mainExp of
      Maybe (PreExp e l d, TyOf (PreExp e l d))
Nothing      -> Bool
False
      Just (PreExp e l d
e,TyOf (PreExp e l d)
_ty) -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e

-- | Does the expression contain a SpawnE form?
hasSpawns :: (PreExp e l d) -> Bool
hasSpawns :: forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
rhs =
    case PreExp e l d
rhs of
      DataConE{}   -> Bool
False
      VarE{}       -> Bool
False
      LitE{}       -> Bool
False
      CharE{}      -> Bool
False
      FloatE{}     -> Bool
False
      LitSymE{}    -> Bool
False
      AppE{}       -> Bool
False
      PrimAppE{}   -> Bool
False
      ProjE Int
_ PreExp e l d
e    -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e
      MkProdE [PreExp e l d]
ls   -> (PreExp e l d -> Bool) -> [PreExp e l d] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns [PreExp e l d]
ls
      IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c    -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
a Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
b Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
c
      CaseE PreExp e l d
_ [(DataCon, [(Var, l)], PreExp e l d)]
ls   -> (PreExp e l d -> Bool) -> [PreExp e l d] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns [ PreExp e l d
e | (DataCon
_,[(Var, l)]
_,PreExp e l d
e) <- [(DataCon, [(Var, l)], PreExp e l d)]
ls ]
      LetE (Var
_,[l]
_,d
_,PreExp e l d
e1) PreExp e l d
e2 -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e2
      SpawnE{}     -> Bool
True
      PreExp e l d
SyncE        -> Bool
False
      TimeIt PreExp e l d
e d
_ Bool
_ -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e
      MapE (Var
_,d
_,PreExp e l d
e1) PreExp e l d
e2   -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e2
      FoldE (Var
_,d
_,PreExp e l d
e1) (Var
_,d
_,PreExp e l d
e2) PreExp e l d
e3 ->
        PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e1 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e2 Bool -> Bool -> Bool
|| PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e3
      Ext e l d
_ -> Bool
False
      WithArenaE Var
_ PreExp e l d
e -> PreExp e l d -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns PreExp e l d
e

-- | Project something which had better not be the first thing in a tuple.
projNonFirst :: (Out l, Out d, Out (e l d)) => Int -> (PreExp e l d) -> (PreExp e l d)
projNonFirst :: forall l d (e :: * -> * -> *).
(Out l, Out d, Out (e l d)) =>
Int -> PreExp e l d -> PreExp e l d
projNonFirst Int
0 PreExp e l d
e = DataCon -> PreExp e l d
forall a. HasCallStack => DataCon -> a
error (DataCon -> PreExp e l d) -> DataCon -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ DataCon
"projNonFirst: expected nonzero index into expr: " DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ PreExp e l d -> DataCon
forall a. Out a => a -> DataCon
sdoc PreExp e l d
e
projNonFirst Int
i PreExp e l d
e = Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i PreExp e l d
e

-- | Smart constructor that immediately destroys products if it can:
-- Does NOT avoid single-element tuples.
mkProj :: Int -> (PreExp e l d) -> (PreExp e l d)
mkProj :: forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
mkProj Int
ix (MkProdE [PreExp e l d]
ls) = [PreExp e l d]
ls [PreExp e l d] -> Int -> PreExp e l d
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
mkProj Int
ix PreExp e l d
e = (Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix PreExp e l d
e)

-- | Make a product type while avoiding unary products.
mkProd :: [(PreExp e l d)]-> (PreExp e l d)
mkProd :: forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
mkProd [PreExp e l d
e] = PreExp e l d
e
mkProd [PreExp e l d]
ls  = [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [PreExp e l d]
ls

-- | Make a nested series of lets.
mkLets :: [(Var, [loc], dec, (PreExp ext loc dec))] -> (PreExp ext loc dec) -> (PreExp ext loc dec)
mkLets :: forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [] PreExp ext loc dec
bod     = PreExp ext loc dec
bod
mkLets ((Var, [loc], dec, PreExp ext loc dec)
b:[(Var, [loc], dec, PreExp ext loc dec)]
bs) PreExp ext loc dec
bod = (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [loc], dec, PreExp ext loc dec)
b ([(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [loc], dec, PreExp ext loc dec)]
bs PreExp ext loc dec
bod)

-- | Helper function that lifts out Lets on the RHS of other Lets.
-- Absolutely requires unique names.
mkLetE :: (Var, [l], d, (PreExp e l d)) -> (PreExp e l d) -> (PreExp e l d)
mkLetE :: forall l d (e :: * -> * -> *).
(Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
mkLetE (Var
vr,[l]
lvs,d
ty,(LetE (Var, [l], d, PreExp e l d)
bnd PreExp e l d
e)) PreExp e l d
bod = (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
(Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
mkLetE (Var, [l], d, PreExp e l d)
bnd (PreExp e l d -> PreExp e l d) -> PreExp e l d -> PreExp e l d
forall a b. (a -> b) -> a -> b
$ (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
(Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
mkLetE (Var
vr,[l]
lvs,d
ty,PreExp e l d
e) PreExp e l d
bod
mkLetE (Var, [l], d, PreExp e l d)
bnd PreExp e l d
bod = (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [l], d, PreExp e l d)
bnd PreExp e l d
bod

-- | Alternative version of L1.mkLets that also flattens
flatLets :: [(Var,[l],d,(PreExp e l d))] -> (PreExp e l d) -> (PreExp e l d)
flatLets :: forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
flatLets [] PreExp e l d
bod = PreExp e l d
bod
flatLets ((Var, [l], d, PreExp e l d)
b:[(Var, [l], d, PreExp e l d)]
bs) PreExp e l d
bod = (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
(Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
mkLetE (Var, [l], d, PreExp e l d)
b ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
flatLets [(Var, [l], d, PreExp e l d)]
bs PreExp e l d
bod)

tuplizeRefs :: Var -> [Var] -> [d] -> (PreExp e l d) -> (PreExp e l d)
tuplizeRefs :: forall d (e :: * -> * -> *) l.
Var -> [Var] -> [d] -> PreExp e l d -> PreExp e l d
tuplizeRefs Var
ref [Var]
vars [d]
tys =
  [(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d)
-> [(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall a b. (a -> b) -> a -> b
$
    ((Var, d, Int) -> (Var, [l], d, PreExp e l d))
-> [(Var, d, Int)] -> [(Var, [l], d, PreExp e l d)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Var
v,d
ty,Int
ix) -> (Var
v,[],d
ty,Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
mkProj Int
ix (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ref))) ([Var] -> [d] -> [Int] -> [(Var, d, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
L.zip3 [Var]
vars [d]
tys [Int
0..])

--------------------------------------------------------------------------------
-- Helpers operating on types
--------------------------------------------------------------------------------

-- | Same as mkProd, at the type level
mkProdTy :: [UrTy a]-> UrTy a
mkProdTy :: forall loc. [UrTy loc] -> UrTy loc
mkProdTy [UrTy a
t] = UrTy a
t
mkProdTy [UrTy a]
ls  = [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy [UrTy a]
ls

projTy :: (Out a) => Int -> UrTy a -> UrTy a
projTy :: forall a. Out a => Int -> UrTy a -> UrTy a
projTy Int
0 (ProdTy (UrTy a
ty:[UrTy a]
_))  = UrTy a
ty
projTy Int
n (ProdTy (UrTy a
_:[UrTy a]
tys)) = Int -> UrTy a -> UrTy a
forall a. Out a => Int -> UrTy a -> UrTy a
projTy (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ([UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy [UrTy a]
tys)
projTy Int
_ UrTy a
ty = DataCon -> UrTy a
forall a. HasCallStack => DataCon -> a
error (DataCon -> UrTy a) -> DataCon -> UrTy a
forall a b. (a -> b) -> a -> b
$ DataCon
"projTy: " DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ UrTy a -> DataCon
forall a. Out a => a -> DataCon
sdoc UrTy a
ty DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ DataCon
" is not a projection!"

-- | A makeshift void type.
voidTy :: UrTy a
voidTy :: forall loc. UrTy loc
voidTy = [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []

-- | Are values of this type tuples ?
isProdTy :: UrTy a -> Bool
isProdTy :: forall a. UrTy a -> Bool
isProdTy ProdTy{} = Bool
True
isProdTy UrTy a
_ = Bool
False

-- | Do values of this type contain nested tuples ?
isNestedProdTy :: UrTy a -> Bool
isNestedProdTy :: forall a. UrTy a -> Bool
isNestedProdTy UrTy a
ty =
  case UrTy a
ty of
    ProdTy [UrTy a]
tys -> if (UrTy a -> Bool) -> [UrTy a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UrTy a -> Bool
forall a. UrTy a -> Bool
isProdTy [UrTy a]
tys
                  then Bool
True
                  else Bool
False
    UrTy a
_ -> Bool
False

-- | Are values of this type Packed ?
isPackedTy :: UrTy a -> Bool
isPackedTy :: forall a. UrTy a -> Bool
isPackedTy PackedTy{} = Bool
True
isPackedTy UrTy a
_ = Bool
False

isScalarTy :: UrTy a -> Bool
isScalarTy :: forall a. UrTy a -> Bool
isScalarTy UrTy a
IntTy  = Bool
True
isScalarTy UrTy a
CharTy = Bool
True
isScalarTy UrTy a
SymTy  = Bool
True
isScalarTy UrTy a
BoolTy = Bool
True
isScalarTy UrTy a
FloatTy= Bool
True
isScalarTy UrTy a
_      = Bool
False

-- | Lists of scalars or flat products of scalars are allowed.
isValidListElemTy :: UrTy a -> Bool
isValidListElemTy :: forall a. UrTy a -> Bool
isValidListElemTy UrTy a
ty
  | UrTy a -> Bool
forall a. UrTy a -> Bool
isScalarTy UrTy a
ty = Bool
True
  | Bool
otherwise = case UrTy a
ty of
                  VectorTy UrTy a
elty -> UrTy a -> Bool
forall a. UrTy a -> Bool
isValidListElemTy UrTy a
elty
                  ListTy UrTy a
elty   -> UrTy a -> Bool
forall a. UrTy a -> Bool
isValidListElemTy UrTy a
elty
                  ProdTy [UrTy a]
tys    -> (UrTy a -> Bool) -> [UrTy a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all UrTy a -> Bool
forall a. UrTy a -> Bool
isScalarTy [UrTy a]
tys
                  UrTy a
_ -> Bool
False

-- | Do values of this type contain packed data?
hasPacked :: Show a => UrTy a -> Bool
hasPacked :: forall a. Show a => UrTy a -> Bool
hasPacked UrTy a
t =
  case UrTy a
t of
    PackedTy{}     -> Bool
True
    ProdTy [UrTy a]
ls      -> (UrTy a -> Bool) -> [UrTy a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UrTy a -> Bool
forall a. Show a => UrTy a -> Bool
hasPacked [UrTy a]
ls
    UrTy a
SymTy          -> Bool
False
    UrTy a
BoolTy         -> Bool
False
    UrTy a
IntTy          -> Bool
False
    UrTy a
CharTy         -> Bool
False
    UrTy a
FloatTy        -> Bool
False
    SymDictTy Maybe Var
_ UrTy ()
_  -> Bool
False -- hasPacked ty
    PDictTy UrTy a
k UrTy a
v    -> UrTy a -> Bool
forall a. Show a => UrTy a -> Bool
hasPacked UrTy a
k Bool -> Bool -> Bool
|| UrTy a -> Bool
forall a. Show a => UrTy a -> Bool
hasPacked UrTy a
v
    VectorTy UrTy a
ty    -> UrTy a -> Bool
forall a. Show a => UrTy a -> Bool
hasPacked UrTy a
ty
    ListTy UrTy a
ty      -> UrTy a -> Bool
forall a. Show a => UrTy a -> Bool
hasPacked UrTy a
ty
    UrTy a
PtrTy          -> Bool
False
    UrTy a
CursorTy       -> Bool
False
    UrTy a
ArenaTy        -> Bool
False
    UrTy a
SymSetTy       -> Bool
False
    UrTy a
SymHashTy      -> Bool
False
    UrTy a
IntHashTy      -> Bool
False


-- | Get all packed types in a type.
getPackedTys :: Show a => UrTy a -> [UrTy a]
getPackedTys :: forall a. Show a => UrTy a -> [UrTy a]
getPackedTys UrTy a
t =
  case UrTy a
t of
    PackedTy{}     -> [UrTy a
t]
    ProdTy [UrTy a]
ls      -> (UrTy a -> [UrTy a]) -> [UrTy a] -> [UrTy a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UrTy a -> [UrTy a]
forall a. Show a => UrTy a -> [UrTy a]
getPackedTys [UrTy a]
ls
    UrTy a
SymTy          -> []
    UrTy a
BoolTy         -> []
    UrTy a
IntTy          -> []
    UrTy a
CharTy         -> []
    UrTy a
FloatTy        -> []
    SymDictTy Maybe Var
_ UrTy ()
_  -> [] -- getPackedTys ty
    PDictTy UrTy a
k UrTy a
v    -> UrTy a -> [UrTy a]
forall a. Show a => UrTy a -> [UrTy a]
getPackedTys UrTy a
k [UrTy a] -> [UrTy a] -> [UrTy a]
forall a. [a] -> [a] -> [a]
++ UrTy a -> [UrTy a]
forall a. Show a => UrTy a -> [UrTy a]
getPackedTys UrTy a
v
    VectorTy UrTy a
ty    -> UrTy a -> [UrTy a]
forall a. Show a => UrTy a -> [UrTy a]
getPackedTys UrTy a
ty
    ListTy UrTy a
ty      -> UrTy a -> [UrTy a]
forall a. Show a => UrTy a -> [UrTy a]
getPackedTys UrTy a
ty
    UrTy a
PtrTy          -> []
    UrTy a
CursorTy       -> []
    UrTy a
ArenaTy        -> []
    UrTy a
SymSetTy       -> []
    UrTy a
SymHashTy      -> []
    UrTy a
IntHashTy      -> []

-- | Provide a size in bytes, if it is statically known.
sizeOfTy :: UrTy a -> Maybe Int
sizeOfTy :: forall a. UrTy a -> Maybe Int
sizeOfTy UrTy a
t =
  case UrTy a
t of
    PackedTy{}    -> Maybe Int
forall a. Maybe a
Nothing
    ProdTy [UrTy a]
ls     -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> Maybe [Int] -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UrTy a -> Maybe Int) -> [UrTy a] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM UrTy a -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy [UrTy a]
ls
    SymDictTy Maybe Var
_ UrTy ()
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8 -- Always a pointer.
    PDictTy UrTy a
_ UrTy a
_   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8 -- Always a pointer.
    UrTy a
IntTy         -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    UrTy a
CharTy        -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    UrTy a
FloatTy       -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
    UrTy a
SymTy         -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    UrTy a
BoolTy        -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    VectorTy{}    -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8 -- Always a pointer.
    ListTy{}      -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8 -- Always a pointer.
    PtrTy{}       -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8 -- Assuming 64 bit
    CursorTy{}    -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    UrTy a
ArenaTy       -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    UrTy a
SymSetTy      -> DataCon -> Maybe Int
forall a. HasCallStack => DataCon -> a
error DataCon
"sizeOfTy: SymSetTy not handled."
    UrTy a
SymHashTy     -> DataCon -> Maybe Int
forall a. HasCallStack => DataCon -> a
error DataCon
"sizeOfTy: SymHashTy not handled."
    UrTy a
IntHashTy     -> DataCon -> Maybe Int
forall a. HasCallStack => DataCon -> a
error DataCon
"sizeOfTy: SymHashTy not handled."

-- | Type of the arguments for a primitive operation.
primArgsTy :: Prim (UrTy a) -> [UrTy a]
primArgsTy :: forall a. Prim (UrTy a) -> [UrTy a]
primArgsTy Prim (UrTy a)
p =
  case Prim (UrTy a)
p of
    Prim (UrTy a)
AddP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
SubP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
MulP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
DivP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
ModP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
ExpP    -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
FRandP  -> []
    Prim (UrTy a)
FAddP   -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FSubP   -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FMulP   -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FDivP   -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FExpP   -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FSqrtP  -> [UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FTanP   -> [UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FloatToIntP -> [UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
IntToFloatP -> [UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
RandP   -> []
    Prim (UrTy a)
EqSymP  -> [UrTy a
forall loc. UrTy loc
SymTy, UrTy a
forall loc. UrTy loc
SymTy]
    EqBenchProgP DataCon
_ -> []
    Prim (UrTy a)
EqIntP  -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
EqFloatP-> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
EqCharP -> [UrTy a
forall loc. UrTy loc
CharTy, UrTy a
forall loc. UrTy loc
CharTy]
    Prim (UrTy a)
LtP  -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
GtP  -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
LtEqP-> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
GtEqP-> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
FLtP  -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FGtP  -> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FLtEqP-> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
FGtEqP-> [UrTy a
forall loc. UrTy loc
FloatTy, UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
OrP  -> [UrTy a
forall loc. UrTy loc
BoolTy, UrTy a
forall loc. UrTy loc
BoolTy]
    Prim (UrTy a)
AndP -> [UrTy a
forall loc. UrTy loc
BoolTy, UrTy a
forall loc. UrTy loc
BoolTy]
    Prim (UrTy a)
Gensym  -> []
    Prim (UrTy a)
MkTrue  -> []
    Prim (UrTy a)
MkFalse -> []
    Prim (UrTy a)
SizeParam        -> []
    Prim (UrTy a)
IsBig            -> [UrTy a
forall loc. UrTy loc
IntTy, DataCon -> a -> UrTy a
forall loc. DataCon -> loc -> UrTy loc
PackedTy DataCon
"HOLE" a
_error]
    DictEmptyP UrTy a
_ty   -> []
    DictInsertP UrTy a
_ty  -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: dicts not handled yet"
    DictLookupP UrTy a
_ty  -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: dicts not handled yet"
    DictHasKeyP UrTy a
_ty  -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: dicts not handled yet"
    VAllocP UrTy a
_elty  -> [UrTy a
forall loc. UrTy loc
IntTy]
    VFreeP UrTy a
elty   -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty]
    VFree2P UrTy a
elty  -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty]
    VLengthP UrTy a
elty -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty]
    VNthP UrTy a
elty    -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty, UrTy a
forall loc. UrTy loc
IntTy]
    VSliceP UrTy a
elty  -> [UrTy a
forall loc. UrTy loc
IntTy, UrTy a
forall loc. UrTy loc
IntTy, UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty]
    InplaceVUpdateP UrTy a
elty -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty, UrTy a
forall loc. UrTy loc
IntTy, UrTy a
elty]
    VConcatP UrTy a
elty -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy (UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty)]
    -- The voidTy is just a placeholder.
    -- We don't have a type for function pointers.
    VSortP UrTy a
elty        -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty, UrTy a
forall loc. UrTy loc
voidTy]
    InplaceVSortP UrTy a
elty -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty, UrTy a
forall loc. UrTy loc
voidTy]
    VMergeP UrTy a
elty       -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty, UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty]
    PDictInsertP UrTy a
kty UrTy a
vty -> [UrTy a
kty, UrTy a
vty, UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    PDictLookupP UrTy a
kty UrTy a
vty -> [UrTy a
kty, UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    PDictAllocP UrTy a
_kty UrTy a
_vty -> []
    PDictHasKeyP UrTy a
kty UrTy a
vty -> [UrTy a
kty, UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    PDictForkP UrTy a
kty UrTy a
vty -> [UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    PDictJoinP UrTy a
kty UrTy a
vty -> [UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty, UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    LLAllocP UrTy a
_elty -> []
    LLIsEmptyP UrTy a
elty -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLConsP UrTy a
elty  -> [UrTy a
elty, UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLHeadP UrTy a
elty  -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLTailP UrTy a
elty  -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLFreeP UrTy a
elty   -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLFree2P UrTy a
elty  -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    LLCopyP UrTy a
elty  -> [UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty]
    Prim (UrTy a)
GetNumProcessors -> []
    Prim (UrTy a)
PrintInt -> [UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
PrintChar -> [UrTy a
forall loc. UrTy loc
CharTy]
    Prim (UrTy a)
PrintFloat -> [UrTy a
forall loc. UrTy loc
FloatTy]
    Prim (UrTy a)
PrintBool -> [UrTy a
forall loc. UrTy loc
BoolTy]
    Prim (UrTy a)
PrintSym -> [UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
ReadInt  -> []
    Prim (UrTy a)
SymSetEmpty -> []
    Prim (UrTy a)
SymSetInsert -> [UrTy a
forall loc. UrTy loc
SymSetTy, UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
SymSetContains -> [UrTy a
forall loc. UrTy loc
SymSetTy, UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
SymHashEmpty -> []
    Prim (UrTy a)
SymHashInsert -> [UrTy a
forall loc. UrTy loc
SymHashTy,UrTy a
forall loc. UrTy loc
SymTy,UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
SymHashLookup -> [UrTy a
forall loc. UrTy loc
SymHashTy,UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
SymHashContains -> [UrTy a
forall loc. UrTy loc
SymHashTy,UrTy a
forall loc. UrTy loc
SymTy]
    Prim (UrTy a)
IntHashEmpty -> []
    Prim (UrTy a)
IntHashInsert -> [UrTy a
forall loc. UrTy loc
IntHashTy,UrTy a
forall loc. UrTy loc
SymTy,UrTy a
forall loc. UrTy loc
IntTy]
    Prim (UrTy a)
IntHashLookup -> [UrTy a
forall loc. UrTy loc
IntHashTy,UrTy a
forall loc. UrTy loc
SymTy]
    ReadPackedFile{} -> []
    WritePackedFile DataCon
_ UrTy a
ty -> [UrTy a
ty]
    ReadArrayFile{}  -> []
    (ErrorP DataCon
_ UrTy a
_) -> []
    Prim (UrTy a)
RequestEndOf  -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: RequestEndOf not handled yet"
    Prim (UrTy a)
RequestSizeOf -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: RequestSizeOf not handled yet"
    Write3dPpmFile{} -> DataCon -> [UrTy a]
forall a. HasCallStack => DataCon -> a
error DataCon
"primArgsTy: Write3dPpmFile not handled yet"

-- | Return type for a primitive operation.
primRetTy :: Prim (UrTy a) -> (UrTy a)
primRetTy :: forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim (UrTy a)
p =
  case Prim (UrTy a)
p of
    Prim (UrTy a)
AddP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
SubP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
MulP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
DivP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
ModP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
ExpP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
FRandP-> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FAddP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FSubP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FMulP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FDivP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FExpP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FSqrtP-> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FTanP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
FloatToIntP -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
IntToFloatP -> UrTy a
forall loc. UrTy loc
FloatTy
    Prim (UrTy a)
RandP-> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
Gensym  -> UrTy a
forall loc. UrTy loc
SymTy
    Prim (UrTy a)
EqSymP  -> UrTy a
forall loc. UrTy loc
BoolTy
    EqBenchProgP DataCon
_ -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
EqIntP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
EqFloatP-> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
EqCharP -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
LtP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
GtP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
LtEqP-> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
GtEqP-> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
FLtP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
FGtP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
FLtEqP-> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
FGtEqP-> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
OrP  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
AndP -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
MkTrue  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
MkFalse -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
SizeParam      -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
IsBig          -> UrTy a
forall loc. UrTy loc
BoolTy
    DictHasKeyP UrTy a
_  -> UrTy a
forall loc. UrTy loc
BoolTy
    DictEmptyP UrTy a
ty  -> Maybe Var -> UrTy () -> UrTy a
forall loc. Maybe Var -> UrTy () -> UrTy loc
SymDictTy Maybe Var
forall a. Maybe a
Nothing (UrTy () -> UrTy a) -> UrTy () -> UrTy a
forall a b. (a -> b) -> a -> b
$ UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
ty
    DictInsertP UrTy a
ty -> Maybe Var -> UrTy () -> UrTy a
forall loc. Maybe Var -> UrTy () -> UrTy loc
SymDictTy Maybe Var
forall a. Maybe a
Nothing (UrTy () -> UrTy a) -> UrTy () -> UrTy a
forall a b. (a -> b) -> a -> b
$ UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
ty
    DictLookupP UrTy a
ty -> UrTy a
ty
    VAllocP UrTy a
elty   -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    VFreeP UrTy a
_elty   -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    VFree2P UrTy a
_elty  -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    VLengthP UrTy a
_elty -> UrTy a
forall loc. UrTy loc
IntTy
    VNthP UrTy a
elty     -> UrTy a
elty
    VSliceP UrTy a
elty   -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    InplaceVUpdateP UrTy a
elty -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    VConcatP UrTy a
elty  -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    VSortP UrTy a
elty -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    InplaceVSortP UrTy a
elty -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    VMergeP UrTy a
elty -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
VectorTy UrTy a
elty
    PDictInsertP UrTy a
kty UrTy a
vty -> UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty
    PDictLookupP UrTy a
_kty UrTy a
vty -> UrTy a
vty
    PDictAllocP UrTy a
kty UrTy a
vty -> UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty
    PDictHasKeyP UrTy a
_kty UrTy a
_vty -> UrTy a
forall loc. UrTy loc
BoolTy
    PDictForkP UrTy a
kty UrTy a
vty -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy [UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty, UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty]
    PDictJoinP UrTy a
kty UrTy a
vty -> UrTy a -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy UrTy a
kty UrTy a
vty
    LLAllocP UrTy a
elty -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty
    LLIsEmptyP UrTy a
_elty -> UrTy a
forall loc. UrTy loc
BoolTy
    LLConsP UrTy a
elty  -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty
    LLHeadP UrTy a
elty  -> UrTy a
elty
    LLTailP UrTy a
elty  -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty
    LLFreeP UrTy a
_elty  -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    LLFree2P UrTy a
_elty -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    LLCopyP UrTy a
elty  -> UrTy a -> UrTy a
forall loc. UrTy loc -> UrTy loc
ListTy UrTy a
elty
    Prim (UrTy a)
GetNumProcessors -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
PrintInt   -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    Prim (UrTy a)
PrintChar  -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    Prim (UrTy a)
PrintFloat -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    Prim (UrTy a)
PrintBool  -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    Prim (UrTy a)
PrintSym   -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    Prim (UrTy a)
ReadInt    -> UrTy a
forall loc. UrTy loc
IntTy
    Prim (UrTy a)
SymSetEmpty    -> UrTy a
forall loc. UrTy loc
SymSetTy
    Prim (UrTy a)
SymSetInsert   -> UrTy a
forall loc. UrTy loc
SymSetTy
    Prim (UrTy a)
SymSetContains -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
SymHashEmpty   -> UrTy a
forall loc. UrTy loc
SymHashTy
    Prim (UrTy a)
SymHashInsert  -> UrTy a
forall loc. UrTy loc
SymHashTy
    Prim (UrTy a)
SymHashLookup  -> UrTy a
forall loc. UrTy loc
SymTy
    Prim (UrTy a)
SymHashContains  -> UrTy a
forall loc. UrTy loc
BoolTy
    Prim (UrTy a)
IntHashEmpty   -> UrTy a
forall loc. UrTy loc
IntHashTy
    Prim (UrTy a)
IntHashInsert  -> UrTy a
forall loc. UrTy loc
IntHashTy
    Prim (UrTy a)
IntHashLookup  -> UrTy a
forall loc. UrTy loc
IntTy
    (ErrorP DataCon
_ UrTy a
ty)  -> UrTy a
ty
    ReadPackedFile Maybe DataCon
_ DataCon
_ Maybe Var
_ UrTy a
ty -> UrTy a
ty
    WritePackedFile{} -> [UrTy a] -> UrTy a
forall loc. [UrTy loc] -> UrTy loc
ProdTy []
    ReadArrayFile Maybe (DataCon, Int)
_ UrTy a
ty      -> UrTy a
ty
    Prim (UrTy a)
RequestEndOf  -> UrTy a
forall loc. UrTy loc
CursorTy
    Prim (UrTy a)
RequestSizeOf -> UrTy a
forall loc. UrTy loc
IntTy
    Write3dPpmFile{} -> DataCon -> UrTy a
forall a. HasCallStack => DataCon -> a
error DataCon
"primRetTy: Write3dPpmFile not handled yet"

stripTyLocs :: UrTy a -> UrTy ()
stripTyLocs :: forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
ty =
  case UrTy a
ty of
    UrTy a
IntTy     -> UrTy ()
forall loc. UrTy loc
IntTy
    UrTy a
CharTy    -> UrTy ()
forall loc. UrTy loc
CharTy
    UrTy a
FloatTy   -> UrTy ()
forall loc. UrTy loc
FloatTy
    UrTy a
SymTy     -> UrTy ()
forall loc. UrTy loc
SymTy
    UrTy a
BoolTy    -> UrTy ()
forall loc. UrTy loc
BoolTy
    ProdTy [UrTy a]
ls -> [UrTy ()] -> UrTy ()
forall loc. [UrTy loc] -> UrTy loc
ProdTy ([UrTy ()] -> UrTy ()) -> [UrTy ()] -> UrTy ()
forall a b. (a -> b) -> a -> b
$ (UrTy a -> UrTy ()) -> [UrTy a] -> [UrTy ()]
forall a b. (a -> b) -> [a] -> [b]
L.map UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs [UrTy a]
ls
    SymDictTy Maybe Var
v UrTy ()
ty'  -> Maybe Var -> UrTy () -> UrTy ()
forall loc. Maybe Var -> UrTy () -> UrTy loc
SymDictTy Maybe Var
v (UrTy () -> UrTy ()) -> UrTy () -> UrTy ()
forall a b. (a -> b) -> a -> b
$ UrTy () -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy ()
ty'
    PDictTy UrTy a
k UrTy a
v -> UrTy () -> UrTy () -> UrTy ()
forall loc. UrTy loc -> UrTy loc -> UrTy loc
PDictTy (UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
k) (UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
v)
    PackedTy DataCon
tycon a
_ -> DataCon -> () -> UrTy ()
forall loc. DataCon -> loc -> UrTy loc
PackedTy DataCon
tycon ()
    VectorTy UrTy a
ty' -> UrTy () -> UrTy ()
forall loc. UrTy loc -> UrTy loc
VectorTy (UrTy () -> UrTy ()) -> UrTy () -> UrTy ()
forall a b. (a -> b) -> a -> b
$ UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
ty'
    ListTy UrTy a
ty' -> UrTy () -> UrTy ()
forall loc. UrTy loc -> UrTy loc
ListTy (UrTy () -> UrTy ()) -> UrTy () -> UrTy ()
forall a b. (a -> b) -> a -> b
$ UrTy a -> UrTy ()
forall a. UrTy a -> UrTy ()
stripTyLocs UrTy a
ty'
    UrTy a
PtrTy    -> UrTy ()
forall loc. UrTy loc
PtrTy
    UrTy a
CursorTy -> UrTy ()
forall loc. UrTy loc
CursorTy
    UrTy a
SymSetTy -> UrTy ()
forall loc. UrTy loc
SymSetTy
    UrTy a
SymHashTy -> UrTy ()
forall loc. UrTy loc
SymHashTy
    UrTy a
IntHashTy -> UrTy ()
forall loc. UrTy loc
IntHashTy
    UrTy a
ArenaTy   -> UrTy ()
forall loc. UrTy loc
ArenaTy

-- | Get the data constructor type from a type, failing if it's not packed
tyToDataCon :: Show a => UrTy a -> DataCon
tyToDataCon :: forall a. Show a => UrTy a -> DataCon
tyToDataCon (PackedTy DataCon
dcon a
_) = DataCon
dcon
tyToDataCon UrTy a
oth = DataCon -> DataCon
forall a. HasCallStack => DataCon -> a
error (DataCon -> DataCon) -> DataCon -> DataCon
forall a b. (a -> b) -> a -> b
$ DataCon
"tyToDataCon: " DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ UrTy a -> DataCon
forall a. Show a => a -> DataCon
show UrTy a
oth DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++ DataCon
" is not packed"

-- | Ensure that an expression is trivial.
assertTriv :: (HasCallStack, Expression e) => e -> a -> a
assertTriv :: forall e a. (HasCallStack, Expression e) => e -> a -> a
assertTriv e
e =
  if e -> Bool
forall e. Expression e => e -> Bool
isTrivial e
e
  then a -> a
forall a. a -> a
id
  else DataCon -> a -> a
forall a. HasCallStack => DataCon -> a
error(DataCon -> a -> a) -> DataCon -> a -> a
forall a b. (a -> b) -> a -> b
$ DataCon
"Expected trivial argument, got: "DataCon -> DataCon -> DataCon
forall a. [a] -> [a] -> [a]
++e -> DataCon
forall a. Out a => a -> DataCon
sdoc e
e

-- | List version of 'assertTriv'.
assertTrivs :: (HasCallStack, Expression e) => [e] -> a -> a
assertTrivs :: forall e a. (HasCallStack, Expression e) => [e] -> a -> a
assertTrivs [] = a -> a
forall a. a -> a
id
assertTrivs (e
a:[e]
b) = e -> a -> a
forall e a. (HasCallStack, Expression e) => e -> a -> a
assertTriv e
a (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [e] -> a -> a
forall e a. (HasCallStack, Expression e) => [e] -> a -> a
assertTrivs [e]
b