{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}

-- | Convert from L1 to L2, adding region constructs.

module Gibbon.Passes.InferLocations
    (-- data types
     FullEnv, TiM, InferState, Result, UnifyLoc, Failure, Dest(..),
     -- functions for manipulating locations
     fresh, freshUnifyLoc, finalUnifyLoc, fixLoc, freshLocVar, finalLocVar, assocLoc, finishExp,
          prim, emptyEnv,
     -- main functions
     unify, inferLocs, inferExp, inferExp', convertFunTy, copyOutOfOrderPacked, fixRANs, removeAliasesForCopyCalls)
    where

{-
  Basic Strategy
  --------------

The basic strategy here is to use a simple, type-directed pass to translate
programs from L1 to L2. First, we start with a function type, with the
basic starting assumption that all packed values will have distinct locations:

```
  f  :: Int -> Tree -> Tree
  f' :: forall l_1 in r_1, l_2 in r_2 . Int -> Tree l_1 -> Tree l_2
```

After this, the locations from the function type are treated as *fixed*, and
the inference procedure proceeds to walk through the body of the function.

To infer location bindings in an expression, we build up a set of *constraints*
and propogate them up the expression (ie, recurring on a sub-expression will
yield the constraints induced by that sub-expression). After recurring on
all sub-expressions, we use these constraints to determine whether to
emit a binding for a new location or a new region.

Constraints in location inference are very similar to constraints used
in type checking L2. When the expression in consideration is a data type
constructor, a series of constraints are generated: the locations for
each field in the constructor are constrained to occur after the previous one
(enforcing that they occur in the right order), and the first field must
occur after the tag of the data constructor itself.

Knowing all this *isn't enough* to generate the location bindings, however,
since the values that we use in the constructor may have been produced
by multiple different function calls (for example), so the locations
must carefully be bound earlier in the expression at the right locations.
Ideally, we also want them to be bound as tightly as possible, to avoid
binding locations that aren't used (eg, in some branches of a conditional).
So the constraints are *discharged* as the recursion unwinds.

For example, a constraint that location `loc1` occurs after the value `x2`
can safely be discharged after the value `x2` is bound, so in the handling
of a let binding for a packed value, we search through the constraints
returned by recurring on the body of the let and discharge any constraint
that invloves a location occurring after that newly-bound variable.

 Program repair
 --------------

During the inference procedure, unification will occur between locations,
and if two *fixed* locations are unified there will be an error thrown.
To recover, the procedure will have to transform (repair) the expression.
The simplest way to do this is to insert a copy.

Naively, this simple strategy will require lots of copies. For exmaple, the identity
function's type transforms as follows:

```
  id  :: Tree -> Tree
  id' :: forall l1 in r1, l2 in r2 . Tree l1 -> Tree l2
```

With this type, inferExp will immediately fail on the body of 'id x = x', requiring
a copy-insertion tactic to repair the failure and proceed.

Copy-insertion is very simple. For each data type, we generate a copy traversal
function which matches on each element of the structure. These functions undergo
location inference just like normal user code. During location inference when
a unification failure indicates a copy must be inserted, a call to `"copy_Type"`
is emitted, where `Type` is the name of the packed data type that must be copied.

-}

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List as L
import qualified Data.Foldable as F
import Prelude as P
import Data.Maybe
import qualified Control.Monad.Trans.State.Strict as St
import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.Trans (lift)
import Text.PrettyPrint.GenericPretty
import GHC.Stack (HasCallStack)

import Gibbon.Common
import Gibbon.L1.Syntax as L1 hiding (extendVEnv, extendsVEnv, lookupVEnv, lookupFEnv)
import qualified Gibbon.L1.Syntax as L1
import Gibbon.L2.Syntax as L2 hiding (extendVEnv, extendsVEnv, lookupVEnv, lookupFEnv)
import Gibbon.Passes.InlineTriv (inlineTriv)
import Gibbon.Passes.Flatten (flattenL1)

--------------------------------------------------------------------------------
-- Environments
--------------------------------------------------------------------------------

-- | Combine the different kinds of contextual information in-scope.
data FullEnv = FullEnv
    { FullEnv -> DDefs Ty2
dataDefs :: DDefs Ty2 -- ^ Data type definitions
    , FullEnv -> TyEnv Ty2
valEnv :: TyEnv Ty2   -- ^ Type env for local bindings
    , FullEnv -> TyEnv (ArrowTy Ty2)
funEnv :: TyEnv (ArrowTy Ty2)  -- ^ Top level fundef types
    } deriving Int -> FullEnv -> ShowS
[FullEnv] -> ShowS
FullEnv -> String
(Int -> FullEnv -> ShowS)
-> (FullEnv -> String) -> ([FullEnv] -> ShowS) -> Show FullEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FullEnv -> ShowS
showsPrec :: Int -> FullEnv -> ShowS
$cshow :: FullEnv -> String
show :: FullEnv -> String
$cshowList :: [FullEnv] -> ShowS
showList :: [FullEnv] -> ShowS
Show

extendVEnv :: Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv :: Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
v Ty2
ty fe :: FullEnv
fe@FullEnv{TyEnv Ty2
valEnv :: FullEnv -> TyEnv Ty2
valEnv :: TyEnv Ty2
valEnv} = FullEnv
fe { valEnv :: TyEnv Ty2
valEnv = Var -> Ty2 -> TyEnv Ty2 -> TyEnv Ty2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Ty2
ty TyEnv Ty2
valEnv }

extendsVEnv :: TyEnv Ty2 -> FullEnv -> FullEnv
extendsVEnv :: TyEnv Ty2 -> FullEnv -> FullEnv
extendsVEnv TyEnv Ty2
env fe :: FullEnv
fe@FullEnv{TyEnv Ty2
valEnv :: FullEnv -> TyEnv Ty2
valEnv :: TyEnv Ty2
valEnv} = FullEnv
fe { valEnv :: TyEnv Ty2
valEnv = TyEnv Ty2
valEnv TyEnv Ty2 -> TyEnv Ty2 -> TyEnv Ty2
forall a. Semigroup a => a -> a -> a
<> TyEnv Ty2
env }

lookupVEnv :: Var -> FullEnv -> Ty2
lookupVEnv :: Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv{TyEnv Ty2
valEnv :: FullEnv -> TyEnv Ty2
valEnv :: TyEnv Ty2
valEnv} = TyEnv Ty2
valEnv TyEnv Ty2 -> Var -> Ty2
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v

lookupFEnv :: Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv :: Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
v FullEnv{TyEnv (ArrowTy Ty2)
funEnv :: FullEnv -> TyEnv (ArrowTy Ty2)
funEnv :: TyEnv (ArrowTy Ty2)
funEnv} = TyEnv (ArrowTy Ty2)
TyEnv (ArrowTy2 Ty2)
funEnv TyEnv (ArrowTy2 Ty2) -> Var -> ArrowTy2 Ty2
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v

-- Types
--------------------------------------------------------------------------------

-- | This helper exemplifies the simplicity of our current approach.
-- If we assume output regions are disjoint from input ones, then we
-- can instantiate an L1 function type into a polymorphic L2 one,
-- mechanically.
convertFunTy :: ([Ty1],Ty1,Bool) -> PassM (ArrowTy2 Ty2)
convertFunTy :: ([Ty1], Ty1, Bool) -> PassM (ArrowTy2 Ty2)
convertFunTy ([Ty1]
from,Ty1
to,Bool
isPar) = do
    [Ty2]
from' <- (Ty1 -> PassM Ty2) -> [Ty1] -> PassM [Ty2]
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 Ty1 -> PassM Ty2
convertTy [Ty1]
from
    Ty2
to'   <- Ty1 -> PassM Ty2
convertTy Ty1
to
    -- For this simple version, we assume every location is in a separate region:
    [LRM]
lrm1 <- [[LRM]] -> [LRM]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[LRM]] -> [LRM]) -> PassM [[LRM]] -> PassM [LRM]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty2 -> PassM [LRM]) -> [Ty2] -> PassM [[LRM]]
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 (Modality -> Ty2 -> PassM [LRM]
forall {t :: * -> *}.
Foldable t =>
Modality -> t Var -> PassM [LRM]
toLRM Modality
Input) [Ty2]
from'
    [LRM]
lrm2 <- Modality -> Ty2 -> PassM [LRM]
forall {t :: * -> *}.
Foldable t =>
Modality -> t Var -> PassM [LRM]
toLRM Modality
Output Ty2
to'
    ArrowTy2 Ty2 -> PassM (ArrowTy2 Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArrowTy2 Ty2 -> PassM (ArrowTy2 Ty2))
-> ArrowTy2 Ty2 -> PassM (ArrowTy2 Ty2)
forall a b. (a -> b) -> a -> b
$ ArrowTy2 { locVars :: [LRM]
locVars = [LRM]
lrm1 [LRM] -> [LRM] -> [LRM]
forall a. [a] -> [a] -> [a]
++ [LRM]
lrm2
                     , arrIns :: [Ty2]
arrIns  = [Ty2]
from'
                     , arrEffs :: Set Effect
arrEffs = Set Effect
forall a. Set a
S.empty
                     , arrOut :: Ty2
arrOut  = Ty2
to'
                     , locRets :: [LocRet]
locRets = []
                     , hasParallelism :: Bool
hasParallelism = Bool
isPar }
 where
   toLRM :: Modality -> t Var -> PassM [LRM]
toLRM Modality
md t Var
ls =
       (Var -> PassM LRM) -> [Var] -> PassM [LRM]
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 (\Var
v -> do Var
r <- String -> PassM Var
freshLocVar String
"r"
                      LRM -> PassM LRM
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LRM -> PassM LRM) -> LRM -> PassM LRM
forall a b. (a -> b) -> a -> b
$ Var -> Region -> Modality -> LRM
LRM Var
v (Var -> Region
VarR Var
r) Modality
md)
            (t Var -> [Var]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t Var
ls)

convertTy :: Ty1 -> PassM Ty2
convertTy :: Ty1 -> PassM Ty2
convertTy Ty1
ty = (() -> PassM Var) -> Ty1 -> PassM Ty2
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) -> UrTy a -> f (UrTy b)
traverse (PassM Var -> () -> PassM Var
forall a b. a -> b -> a
const (String -> PassM Var
freshLocVar String
"loc")) Ty1
ty

convertDDefs :: DDefs Ty1 -> PassM (DDefs Ty2)
convertDDefs :: DDefs Ty1 -> PassM (DDefs Ty2)
convertDDefs DDefs Ty1
ddefs = (DDef Ty1 -> PassM (DDef Ty2)) -> DDefs Ty1 -> PassM (DDefs Ty2)
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 DDef Ty1 -> PassM (DDef Ty2)
f DDefs Ty1
ddefs
    where f :: DDef Ty1 -> PassM (DDef Ty2)
f (DDef Var
tyargs [TyVar]
n [(String, [(Bool, Ty1)])]
dcs) = do
            [(String, [(Bool, Ty2)])]
dcs' <- [(String, [(Bool, Ty1)])]
-> ((String, [(Bool, Ty1)]) -> PassM (String, [(Bool, Ty2)]))
-> PassM [(String, [(Bool, Ty2)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, [(Bool, Ty1)])]
dcs (((String, [(Bool, Ty1)]) -> PassM (String, [(Bool, Ty2)]))
 -> PassM [(String, [(Bool, Ty2)])])
-> ((String, [(Bool, Ty1)]) -> PassM (String, [(Bool, Ty2)]))
-> PassM [(String, [(Bool, Ty2)])]
forall a b. (a -> b) -> a -> b
$ \(String
dc,[(Bool, Ty1)]
bnds) -> do
                             [(Bool, Ty2)]
bnds' <- [(Bool, Ty1)]
-> ((Bool, Ty1) -> PassM (Bool, Ty2)) -> PassM [(Bool, Ty2)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Bool, Ty1)]
bnds (((Bool, Ty1) -> PassM (Bool, Ty2)) -> PassM [(Bool, Ty2)])
-> ((Bool, Ty1) -> PassM (Bool, Ty2)) -> PassM [(Bool, Ty2)]
forall a b. (a -> b) -> a -> b
$ \(Bool
isb,Ty1
ty) -> do
                                               Ty2
ty' <- Ty1 -> PassM Ty2
convertTy Ty1
ty
                                               (Bool, Ty2) -> PassM (Bool, Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isb, Ty2
ty')
                             (String, [(Bool, Ty2)]) -> PassM (String, [(Bool, Ty2)])
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dc,[(Bool, Ty2)]
bnds')
            DDef Ty2 -> PassM (DDef Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DDef Ty2 -> PassM (DDef Ty2)) -> DDef Ty2 -> PassM (DDef Ty2)
forall a b. (a -> b) -> a -> b
$ Var -> [TyVar] -> [(String, [(Bool, Ty2)])] -> DDef Ty2
forall a. Var -> [TyVar] -> [(String, [(Bool, a)])] -> DDef a
DDef Var
tyargs [TyVar]
n [(String, [(Bool, Ty2)])]
dcs'

-- Inference algorithm
--------------------------------------------------------------------------------

-- | The location inference monad is a stack of ExceptT and StateT.
type TiM a = ExceptT Failure (St.StateT InferState PassM) a

-- | The state of the inference procedure is a map from location variable
-- to `UnifyLoc`, which is explained below.
-- This is a bit awkward, since after inference is done we have to make another
-- pass over the AST to update all the `LocVar`s. One refactoring that would
-- make this less awkward would be to make a type-level distinction between
-- `LocVar`s that occur before and after this pass.
-- Also, it would be more efficient to use mutable state directly for this,
-- or possibly some more sophisticated union find thing.
type InferState = M.Map LocVar UnifyLoc

-- | A location is either fixed or fresh. Two fixed locations cannot unify.
data UnifyLoc = FixedLoc Var
              | FreshLoc Var
                deriving (Int -> UnifyLoc -> ShowS
[UnifyLoc] -> ShowS
UnifyLoc -> String
(Int -> UnifyLoc -> ShowS)
-> (UnifyLoc -> String) -> ([UnifyLoc] -> ShowS) -> Show UnifyLoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnifyLoc -> ShowS
showsPrec :: Int -> UnifyLoc -> ShowS
$cshow :: UnifyLoc -> String
show :: UnifyLoc -> String
$cshowList :: [UnifyLoc] -> ShowS
showList :: [UnifyLoc] -> ShowS
Show, UnifyLoc -> UnifyLoc -> Bool
(UnifyLoc -> UnifyLoc -> Bool)
-> (UnifyLoc -> UnifyLoc -> Bool) -> Eq UnifyLoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnifyLoc -> UnifyLoc -> Bool
== :: UnifyLoc -> UnifyLoc -> Bool
$c/= :: UnifyLoc -> UnifyLoc -> Bool
/= :: UnifyLoc -> UnifyLoc -> Bool
Eq)

data Failure = FailUnify Ty2 Ty2
             | FailInfer Exp1
               deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> String
show :: Failure -> String
$cshowList :: [Failure] -> ShowS
showList :: [Failure] -> ShowS
Show, Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
/= :: Failure -> Failure -> Bool
Eq)

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

-- | Constraints here mean almost the same thing as they do in the L2 type checker.
-- One difference is the presence of an AfterTag constraint, though I'm not opposed to
-- adding one to the L2 language for symmetry.
data Constraint = AfterConstantL LocVar Int LocVar
                | AfterVariableL LocVar Var LocVar
                | AfterTagL LocVar LocVar
                | StartRegionL LocVar Region
                | AfterCopyL LocVar Var Var LocVar Var [LocVar]
                | FreeL LocVar
                  deriving (Int -> Constraint -> ShowS
[Constraint] -> ShowS
Constraint -> String
(Int -> Constraint -> ShowS)
-> (Constraint -> String)
-> ([Constraint] -> ShowS)
-> Show Constraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Constraint -> ShowS
showsPrec :: Int -> Constraint -> ShowS
$cshow :: Constraint -> String
show :: Constraint -> String
$cshowList :: [Constraint] -> ShowS
showList :: [Constraint] -> ShowS
Show, Constraint -> Constraint -> Bool
(Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool) -> Eq Constraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Constraint -> Constraint -> Bool
== :: Constraint -> Constraint -> Bool
$c/= :: Constraint -> Constraint -> Bool
/= :: Constraint -> Constraint -> Bool
Eq, (forall x. Constraint -> Rep Constraint x)
-> (forall x. Rep Constraint x -> Constraint) -> Generic Constraint
forall x. Rep Constraint x -> Constraint
forall x. Constraint -> Rep Constraint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Constraint -> Rep Constraint x
from :: forall x. Constraint -> Rep Constraint x
$cto :: forall x. Rep Constraint x -> Constraint
to :: forall x. Rep Constraint x -> Constraint
Generic)

instance Out Constraint

-- | The result type for this pass.  Return a new expression and its
-- type, which includes/implies its location.
type Result = (Exp2, Ty2, [Constraint])

data DCArg = ArgFixed Int
           | ArgVar Var
           | ArgCopy Var Var Var [LocVar]
  deriving Int -> DCArg -> ShowS
[DCArg] -> ShowS
DCArg -> String
(Int -> DCArg -> ShowS)
-> (DCArg -> String) -> ([DCArg] -> ShowS) -> Show DCArg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DCArg -> ShowS
showsPrec :: Int -> DCArg -> ShowS
$cshow :: DCArg -> String
show :: DCArg -> String
$cshowList :: [DCArg] -> ShowS
showList :: [DCArg] -> ShowS
Show

inferLocs :: Prog1 -> PassM L2.Prog2
inferLocs :: Prog1 -> PassM Prog2
inferLocs Prog1
initPrg = do
  -- p@(Prog dfs fds me) <- addRepairFns initPrg
  (Prog DDefs (TyOf Exp1)
dfs FunDefs Exp1
fds Maybe (Exp1, TyOf Exp1)
me) <- do Prog1
p0 <- Prog1 -> PassM Prog1
flattenL1 Prog1
initPrg
                          Prog1 -> PassM Prog1
forall (e :: * -> * -> *) l d.
HasSimplifiable e l d =>
Prog (PreExp e l d) -> PassM (Prog (PreExp e l d))
inlineTriv Prog1
p0
  let m :: ExceptT Failure (StateT InferState PassM) Prog2
m = do
          DDefs Ty2
dfs' <- StateT InferState PassM (DDefs Ty2)
-> ExceptT Failure (StateT InferState PassM) (DDefs Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (DDefs Ty2)
 -> ExceptT Failure (StateT InferState PassM) (DDefs Ty2))
-> StateT InferState PassM (DDefs Ty2)
-> ExceptT Failure (StateT InferState PassM) (DDefs Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (DDefs Ty2) -> StateT InferState PassM (DDefs Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (DDefs Ty2) -> StateT InferState PassM (DDefs Ty2))
-> PassM (DDefs Ty2) -> StateT InferState PassM (DDefs Ty2)
forall a b. (a -> b) -> a -> b
$ DDefs Ty1 -> PassM (DDefs Ty2)
convertDDefs DDefs (TyOf Exp1)
DDefs Ty1
dfs
          TyEnv (ArrowTy2 Ty2)
fenv <- FunDefs Exp1
-> (FunDef Exp1
    -> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2))
-> ExceptT Failure (StateT InferState PassM) (TyEnv (ArrowTy2 Ty2))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM FunDefs Exp1
fds ((FunDef Exp1
  -> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2))
 -> ExceptT
      Failure (StateT InferState PassM) (TyEnv (ArrowTy2 Ty2)))
-> (FunDef Exp1
    -> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2))
-> ExceptT Failure (StateT InferState PassM) (TyEnv (ArrowTy2 Ty2))
forall a b. (a -> b) -> a -> b
$ \(FunDef Var
_ [Var]
_ ([Ty1]
intys, Ty1
outty) Exp1
bod FunMeta
_meta) -> do
                  let has_par :: Bool
has_par = Exp1 -> Bool
forall (e :: * -> * -> *) l d. PreExp e l d -> Bool
hasSpawns Exp1
bod
                  StateT InferState PassM (ArrowTy2 Ty2)
-> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (ArrowTy2 Ty2)
 -> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2))
-> StateT InferState PassM (ArrowTy2 Ty2)
-> ExceptT Failure (StateT InferState PassM) (ArrowTy2 Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (ArrowTy2 Ty2) -> StateT InferState PassM (ArrowTy2 Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (ArrowTy2 Ty2) -> StateT InferState PassM (ArrowTy2 Ty2))
-> PassM (ArrowTy2 Ty2) -> StateT InferState PassM (ArrowTy2 Ty2)
forall a b. (a -> b) -> a -> b
$ ([Ty1], Ty1, Bool) -> PassM (ArrowTy2 Ty2)
convertFunTy ([Ty1]
intys,Ty1
outty,Bool
has_par)
          let fe :: FullEnv
fe = DDefs Ty2 -> TyEnv Ty2 -> TyEnv (ArrowTy Ty2) -> FullEnv
FullEnv DDefs Ty2
dfs' TyEnv Ty2
forall k a. Map k a
M.empty TyEnv (ArrowTy Ty2)
TyEnv (ArrowTy2 Ty2)
fenv
          Maybe (Exp2, Ty2)
me' <- case Maybe (Exp1, TyOf Exp1)
me of
            -- We ignore the type of the main expression inferred in L1..
            -- Probably should add a small check here
            Just (Exp1
me,TyOf Exp1
_ty) -> do
              (Exp2
me',Ty2
ty') <- FullEnv -> Exp1 -> [Var] -> Dest -> TiM (Exp2, Ty2)
inferExp' FullEnv
fe Exp1
me [] Dest
NoDest
              Maybe (Exp2, Ty2)
-> ExceptT Failure (StateT InferState PassM) (Maybe (Exp2, Ty2))
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp2, Ty2)
 -> ExceptT Failure (StateT InferState PassM) (Maybe (Exp2, Ty2)))
-> Maybe (Exp2, Ty2)
-> ExceptT Failure (StateT InferState PassM) (Maybe (Exp2, Ty2))
forall a b. (a -> b) -> a -> b
$ (Exp2, Ty2) -> Maybe (Exp2, Ty2)
forall a. a -> Maybe a
Just (Exp2
me',Ty2
ty')
            Maybe (Exp1, TyOf Exp1)
Nothing -> Maybe (Exp2, Ty2)
-> ExceptT Failure (StateT InferState PassM) (Maybe (Exp2, Ty2))
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp2, Ty2)
forall a. Maybe a
Nothing
          Map Var (FunDef Exp2)
fds' <- FunDefs Exp1
-> (FunDef Exp1
    -> ExceptT Failure (StateT InferState PassM) (FunDef Exp2))
-> ExceptT
     Failure (StateT InferState PassM) (Map Var (FunDef Exp2))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM FunDefs Exp1
fds ((FunDef Exp1
  -> ExceptT Failure (StateT InferState PassM) (FunDef Exp2))
 -> ExceptT
      Failure (StateT InferState PassM) (Map Var (FunDef Exp2)))
-> (FunDef Exp1
    -> ExceptT Failure (StateT InferState PassM) (FunDef Exp2))
-> ExceptT
     Failure (StateT InferState PassM) (Map Var (FunDef Exp2))
forall a b. (a -> b) -> a -> b
$ \(FunDef Var
fn [Var]
fa ([Ty1]
intty,Ty1
outty) Exp1
fbod FunMeta
meta) -> do
                                   let arrty :: ArrowTy2 Ty2
arrty = Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
fn FullEnv
fe
                                       fe' :: FullEnv
fe' = TyEnv Ty2 -> FullEnv -> FullEnv
extendsVEnv ([(Var, Ty2)] -> TyEnv Ty2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty2)] -> TyEnv Ty2) -> [(Var, Ty2)] -> TyEnv Ty2
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty2] -> [(Var, Ty2)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Var]
fa (ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 Ty2
arrty)) FullEnv
fe
                                       boundLocs :: [Var]
boundLocs = [[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ (Ty2 -> [Var]) -> [Ty2] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
map Ty2 -> [Var]
locsInTy (ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 Ty2
arrty [Ty2] -> [Ty2] -> [Ty2]
forall a. [a] -> [a] -> [a]
++ [ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty])
                                   Dest
dest <- Ty2 -> TiM Dest
destFromType (ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty)
                                   (Ty2 -> ExceptT Failure (StateT InferState PassM) ())
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ty2 -> ExceptT Failure (StateT InferState PassM) ()
fixType_ (ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 Ty2
arrty)
                                   (Exp2
fbod',Ty2
_) <- FullEnv -> Exp1 -> [Var] -> Dest -> TiM (Exp2, Ty2)
inferExp' FullEnv
fe' Exp1
fbod [Var]
boundLocs Dest
dest
                                   FunDef Exp2
-> ExceptT Failure (StateT InferState PassM) (FunDef Exp2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp2
 -> ExceptT Failure (StateT InferState PassM) (FunDef Exp2))
-> FunDef Exp2
-> ExceptT Failure (StateT InferState PassM) (FunDef Exp2)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp2) -> Exp2 -> FunMeta -> FunDef Exp2
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
fn [Var]
fa ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
arrty Exp2
fbod' FunMeta
meta
          Prog2 -> ExceptT Failure (StateT InferState PassM) Prog2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog2 -> ExceptT Failure (StateT InferState PassM) Prog2)
-> Prog2 -> ExceptT Failure (StateT InferState PassM) Prog2
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp2)
-> Map Var (FunDef Exp2) -> Maybe (Exp2, TyOf Exp2) -> Prog2
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp2)
DDefs Ty2
dfs' Map Var (FunDef Exp2)
fds' Maybe (Exp2, TyOf Exp2)
Maybe (Exp2, Ty2)
me'
  (Either Failure Prog2, InferState)
prg <- StateT InferState PassM (Either Failure Prog2)
-> InferState -> PassM (Either Failure Prog2, InferState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
St.runStateT (ExceptT Failure (StateT InferState PassM) Prog2
-> StateT InferState PassM (Either Failure Prog2)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Failure (StateT InferState PassM) Prog2
m) InferState
forall k a. Map k a
M.empty
  case (Either Failure Prog2, InferState) -> Either Failure Prog2
forall a b. (a, b) -> a
fst (Either Failure Prog2, InferState)
prg of
    Right Prog2
a -> Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prog2
a
    Left Failure
a -> String -> PassM Prog2
forall a. HasCallStack => String -> a
err (String -> PassM Prog2) -> String -> PassM Prog2
forall a b. (a -> b) -> a -> b
$ Failure -> String
forall a. Show a => a -> String
show Failure
a

-- | Destination can be a single location var, a tuple of destinations,
-- or nothing (for scalar values)
data Dest = SingleDest LocVar -- TODO: refactor to just be list of locations, or actually enforce invariants of non-empty list, etc
          | TupleDest [Dest]
          | NoDest
            deriving (Int -> Dest -> ShowS
[Dest] -> ShowS
Dest -> String
(Int -> Dest -> ShowS)
-> (Dest -> String) -> ([Dest] -> ShowS) -> Show Dest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dest -> ShowS
showsPrec :: Int -> Dest -> ShowS
$cshow :: Dest -> String
show :: Dest -> String
$cshowList :: [Dest] -> ShowS
showList :: [Dest] -> ShowS
Show, (forall x. Dest -> Rep Dest x)
-> (forall x. Rep Dest x -> Dest) -> Generic Dest
forall x. Rep Dest x -> Dest
forall x. Dest -> Rep Dest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Dest -> Rep Dest x
from :: forall x. Dest -> Rep Dest x
$cto :: forall x. Rep Dest x -> Dest
to :: forall x. Rep Dest x -> Dest
Generic)

instance Out Dest

locsInDest :: Dest -> [LocVar]
locsInDest :: Dest -> [Var]
locsInDest Dest
d = case Dest
d of
                 SingleDest Var
c -> [Var
c]
                 TupleDest [Dest]
ls -> (Dest -> [Var]) -> [Dest] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap Dest -> [Var]
locsInDest [Dest]
ls
                 Dest
NoDest -> []

destFromType :: Ty2 -> TiM Dest
destFromType :: Ty2 -> TiM Dest
destFromType Ty2
frt =
  case Ty2
frt of
    PackedTy String
_tc Var
lv -> Var -> TiM UnifyLoc
fixLoc Var
lv TiM UnifyLoc -> TiM Dest -> TiM Dest
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> ExceptT Failure (StateT InferState PassM) b
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Dest
SingleDest Var
lv)
    ProdTy [Ty2]
tys -> (Ty2 -> TiM Dest)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Dest]
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 Ty2 -> TiM Dest
destFromType [Ty2]
tys ExceptT Failure (StateT InferState PassM) [Dest]
-> ([Dest] -> TiM Dest) -> TiM Dest
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dest -> TiM Dest) -> ([Dest] -> Dest) -> [Dest] -> TiM Dest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dest] -> Dest
TupleDest
    Ty2
_ -> Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Dest
NoDest

destFromType' :: Ty2 -> TiM Dest
destFromType' :: Ty2 -> TiM Dest
destFromType' Ty2
frt =
  case Ty2
frt of
    PackedTy String
_tc Var
lv -> Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Dest
SingleDest Var
lv)
    ProdTy [Ty2]
tys -> (Ty2 -> TiM Dest)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Dest]
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 Ty2 -> TiM Dest
destFromType' [Ty2]
tys ExceptT Failure (StateT InferState PassM) [Dest]
-> ([Dest] -> TiM Dest) -> TiM Dest
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dest -> TiM Dest) -> ([Dest] -> Dest) -> [Dest] -> TiM Dest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dest] -> Dest
TupleDest
    Ty2
_ -> Dest -> TiM Dest
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Dest
NoDest

freshTyLocs :: Ty2 -> TiM Ty2
freshTyLocs :: Ty2 -> TiM Ty2
freshTyLocs Ty2
ty =
    case Ty2
ty of
      PackedTy String
tc Var
lv -> TiM Var
fresh TiM Var -> (Var -> TiM Ty2) -> TiM Ty2
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ty2 -> TiM Ty2) -> (Var -> Ty2) -> Var -> TiM Ty2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tc
      ProdTy [Ty2]
tys -> (Ty2 -> TiM Ty2)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
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 Ty2 -> TiM Ty2
freshTyLocs [Ty2]
tys ExceptT Failure (StateT InferState PassM) [Ty2]
-> ([Ty2] -> TiM Ty2) -> TiM Ty2
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ty2 -> TiM Ty2) -> ([Ty2] -> Ty2) -> [Ty2] -> TiM Ty2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy
      Ty2
_ -> Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Ty2
ty

fixType_ :: Ty2 -> TiM ()
fixType_ :: Ty2 -> ExceptT Failure (StateT InferState PassM) ()
fixType_ Ty2
ty =
    case Ty2
ty of
      PackedTy String
_tc Var
lv -> Var -> TiM UnifyLoc
fixLoc Var
lv TiM UnifyLoc
-> ExceptT Failure (StateT InferState PassM) ()
-> ExceptT Failure (StateT InferState PassM) ()
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> ExceptT Failure (StateT InferState PassM) b
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ExceptT Failure (StateT InferState PassM) ()
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ProdTy [Ty2]
tys -> (Ty2 -> ExceptT Failure (StateT InferState PassM) ())
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ty2 -> ExceptT Failure (StateT InferState PassM) ()
fixType_ [Ty2]
tys
      Ty2
_ -> () -> ExceptT Failure (StateT InferState PassM) ()
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Wrap the inferExp procedure, and consume all remaining constraints
inferExp' :: FullEnv -> Exp1 -> [LocVar] -> Dest -> TiM (L2.Exp2, L2.Ty2)
inferExp' :: FullEnv -> Exp1 -> [Var] -> Dest -> TiM (Exp2, Ty2)
inferExp' FullEnv
env Exp1
exp [Var]
bound Dest
dest=
  let

      -- TODO: These should not be necessary, eventually

      bindAllUnbound :: L2.Exp2 -> [LocVar] -> TiM L2.Exp2
      bindAllUnbound :: Exp2 -> [Var] -> TiM Exp2
bindAllUnbound Exp2
e (Var
lv:[Var]
ls) = do
        Region
r <- StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Region
 -> ExceptT Failure (StateT InferState PassM) Region)
-> StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall a b. (a -> b) -> a -> b
$ PassM Region -> StateT InferState PassM Region
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Region -> StateT InferState PassM Region)
-> PassM Region -> StateT InferState PassM Region
forall a b. (a -> b) -> a -> b
$ PassM Region
freshRegVar
        Exp2
e' <- Exp2 -> [Var] -> TiM Exp2
bindAllUnbound Exp2
e [Var]
ls
        Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
Undefined Maybe RegionType
forall a. Maybe a
Nothing (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv (Region -> PreLocExp Var
forall loc. Region -> PreLocExp loc
StartOfRegionLE Region
r) Exp2
e')))
      bindAllUnbound Exp2
e [Var]
_ = Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp2
e

      bindAllLocations :: Result -> TiM Result
      bindAllLocations :: Result -> TiM Result
bindAllLocations (Exp2
expr,Ty2
ty,[Constraint]
constrs) = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> TiM Result) -> Result -> TiM Result
forall a b. (a -> b) -> a -> b
$ (Exp2
expr',Ty2
ty,[])
          where constrs' :: [Constraint]
constrs' = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
constrs
                expr' :: Exp2
expr' = (Constraint -> Exp2 -> Exp2) -> Exp2 -> [Constraint] -> Exp2
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Constraint -> Exp2 -> Exp2
addLetLoc Exp2
expr [Constraint]
constrs'
                addLetLoc :: Constraint -> Exp2 -> Exp2
addLetLoc Constraint
i Exp2
a =
                    case Constraint
i of
                      AfterConstantL Var
lv1 Int
v Var
lv2 -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1 (Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
v Var
lv2) Exp2
a)
                      AfterVariableL Var
lv1 Var
v Var
lv2 -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1 (Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v Var
lv2 Bool
True) Exp2
a)
                      StartRegionL Var
lv Region
r -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
Undefined Maybe RegionType
forall a. Maybe a
Nothing (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv (Region -> PreLocExp Var
forall loc. Region -> PreLocExp loc
StartOfRegionLE Region
r) Exp2
a)))
                      AfterTagL Var
lv1 Var
lv2 -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1 (Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
1 Var
lv2) Exp2
a)
                      FreeL Var
lv -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv PreLocExp Var
forall loc. PreLocExp loc
FreeLE Exp2
a)
                      AfterCopyL Var
lv1 Var
v1 Var
v' Var
lv2 Var
f [Var]
lvs ->
                        let arrty :: Ty2
arrty = ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut (ArrowTy2 Ty2 -> Ty2) -> ArrowTy2 Ty2 -> Ty2
forall a b. (a -> b) -> a -> b
$ Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
                            -- Substitute the location occurring at the call site
                            -- in place of the one in the function's return type
                            copyRetTy :: Ty2
copyRetTy = case Ty2
arrty of
                                          PackedTy String
_ Var
loc -> Map Var Var -> Ty2 -> Ty2
substLoc (Var -> Var -> Map Var Var
forall k a. k -> a -> Map k a
M.singleton Var
loc Var
lv2) Ty2
arrty
                                          Ty2
_ -> String -> Ty2
forall a. HasCallStack => String -> a
error String
"bindAllLocations: Not a packed type"
                            a' :: Exp2
a' = Var -> Exp2 -> Exp2 -> Exp2
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst Var
v1 (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v') Exp2
a
                        in (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v',[],Ty2
copyRetTy, Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Var]
lvs [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v1]) (Exp2 -> Exp2) -> Exp2 -> Exp2
forall a b. (a -> b) -> a -> b
$
                           E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1 (Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v' Var
lv2 Bool
True) Exp2
a')

  in do Result
res <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
exp Dest
dest
        (Exp2
e,Ty2
ty,[Constraint]
cs) <-  Result -> TiM Result
bindAllLocations Result
res
        Exp2
e' <-   Exp2 -> TiM Exp2
finishExp Exp2
e
        let (Exp2
e'',Set Var
s) = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e'
            unbound :: Set Var
unbound = (Set Var
s Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
bound)
        Exp2
e''' <- Exp2 -> [Var] -> TiM Exp2
bindAllUnbound Exp2
e'' (Set Var -> [Var]
forall a. Set a -> [a]
S.toList Set Var
unbound)
        (Exp2, Ty2) -> TiM (Exp2, Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e''',Ty2
ty)

-- | We proceed in a destination-passing style given the target region
-- into which we must produce the resulting value.
inferExp :: FullEnv -> Exp1 -> Dest -> TiM Result
inferExp :: FullEnv -> Exp1 -> Dest -> TiM Result
inferExp env :: FullEnv
env@FullEnv{DDefs Ty2
dataDefs :: FullEnv -> DDefs Ty2
dataDefs :: DDefs Ty2
dataDefs} Exp1
ex0 Dest
dest =
  let

      -- | Check if there are any StartRegion constraints that can be dischaged here.
      -- The basic logic is that if we know a location `loc` is the start of a region `r`,
      -- and we know that there are no constraints for anything after `loc` left
      -- to be discharged, then we can insert the region binding for `r`.
      tryBindReg :: Result -> TiM Result
      tryBindReg :: Result -> TiM Result
tryBindReg (Exp2
e,Ty2
ty,((StartRegionL Var
lv Region
r) : [Constraint]
cs)) =
          do Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             (Exp2
e',Ty2
ty',[Constraint]
cs') <- Result -> TiM Result
tryBindReg (Exp2
e,Ty2
ty,[Constraint]
cs)
             Bool
b1 <- Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv' [Constraint]
cs' [Constraint]
cs'
             if Bool
b1
             then do (Exp2
e'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv' (Exp2
e',Ty2
ty',[Constraint]
cs')
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
Undefined Maybe RegionType
forall a. Maybe a
Nothing (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv' (Region -> PreLocExp Var
forall loc. Region -> PreLocExp loc
StartOfRegionLE Region
r) Exp2
e''))), Ty2
ty'', [Constraint]
cs'')
             else Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',(Var -> Region -> Constraint
StartRegionL Var
lv Region
r)Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      tryBindReg (Exp2
e,Ty2
ty,Constraint
c:[Constraint]
cs) =
          do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Result -> TiM Result
tryBindReg (Exp2
e,Ty2
ty,[Constraint]
cs)
             Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      tryBindReg (Exp2
e,Ty2
ty,[]) = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e,Ty2
ty,[])

      -- | Check the existing list of constraints to determine if we need to introduce a new
      -- StartRegion constraint based on an existing AfterTag constraint.
      -- The logic here is that if we have an AfterTag constraint on two locations loc1 and loc2,
      -- (ie, loc2 is a data structure and loc1 is its first field), and we know that nothing is
      -- before loc2 and it isn't a fixed location, then it might be the start of a new region.
      -- We can't just bind the region immediately, though, so this function just adds a new
      -- constraint when appropriate, which will be discharged later.
      -- TODO: refactor and merge this function with other logic for region insertion
      tryInRegion :: [Constraint] -> TiM [Constraint]
      tryInRegion :: [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs = [Constraint] -> [Constraint] -> TiM [Constraint]
tryInRegion' [Constraint]
cs [Constraint]
cs

      -- Hack, need a full copy of the constraint set in addition to the one being iterated over.
      tryInRegion' :: [Constraint] -> [Constraint] -> TiM [Constraint]
      tryInRegion' :: [Constraint] -> [Constraint] -> TiM [Constraint]
tryInRegion' [Constraint]
fcs (Constraint
c:[Constraint]
cs) =
          case Constraint
c of
            AfterTagL Var
lv1 Var
lv2 ->
                do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
                   Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
                   Bool
b1 <- Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv2' [Constraint]
fcs
                   Bool
b2 <- Var -> [Constraint] -> TiM Bool
noRegionStart Var
lv2' [Constraint]
fcs
                   Bool
b3 <- Var -> TiM Bool
notFixedLoc Var
lv2'
                   if Bool
b1 Bool -> Bool -> Bool
&& Bool
b2 Bool -> Bool -> Bool
&& Bool
b3
                   then do [Constraint]
cs' <- [Constraint] -> [Constraint] -> TiM [Constraint]
tryInRegion' [Constraint]
fcs [Constraint]
cs
                           Region
r <- StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Region
 -> ExceptT Failure (StateT InferState PassM) Region)
-> StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall a b. (a -> b) -> a -> b
$ PassM Region -> StateT InferState PassM Region
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Region -> StateT InferState PassM Region)
-> PassM Region -> StateT InferState PassM Region
forall a b. (a -> b) -> a -> b
$ PassM Region
freshRegVar
                           let c' :: Constraint
c' = Var -> Region -> Constraint
StartRegionL Var
lv2' Region
r
                           [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint
c'Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
                   else do [Constraint]
cs' <- [Constraint] -> [Constraint] -> TiM [Constraint]
tryInRegion' [Constraint]
fcs [Constraint]
cs
                           [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
            Constraint
_ -> do [Constraint]
cs' <- [Constraint] -> [Constraint] -> TiM [Constraint]
tryInRegion' [Constraint]
fcs [Constraint]
cs
                    [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      tryInRegion' [Constraint]
_ [] = [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return []

      -- | This function looks at a series of locations and a type, and determines if
      -- any of those locations could be the start of a region. Similar to `tryInRegion`.
      -- A location might be the start of a region if there's nothing before it and
      -- it isn't fixed.
      tryNeedRegion :: [LocVar] -> Ty2 -> [Constraint] -> TiM [Constraint]
      tryNeedRegion :: [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion (Var
l:[Var]
ls) Ty2
ty [Constraint]
cs =
          do Var
lv <- Var -> TiM Var
finalLocVar Var
l
             [Var]
vls <- (Var -> TiM Var)
-> [Var] -> ExceptT Failure (StateT InferState PassM) [Var]
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 Var -> TiM Var
finalLocVar (Ty2 -> [Var]
locsInTy Ty2
ty)
             if Bool -> Bool
not (Var
lv Var -> [Var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Var]
vls)
             then do Bool
b1 <- Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv [Constraint]
cs
                     Bool
b2 <- Var -> [Constraint] -> TiM Bool
noRegionStart Var
lv [Constraint]
cs
                     Bool
b3 <- Var -> TiM Bool
notFixedLoc Var
lv
                     if Bool
b1 Bool -> Bool -> Bool
&& Bool
b2 Bool -> Bool -> Bool
&& Bool
b3
                     then do [Constraint]
cs' <- [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion [Var]
ls Ty2
ty [Constraint]
cs
                             Region
r <- StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Region
 -> ExceptT Failure (StateT InferState PassM) Region)
-> StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall a b. (a -> b) -> a -> b
$ PassM Region -> StateT InferState PassM Region
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Region -> StateT InferState PassM Region)
-> PassM Region -> StateT InferState PassM Region
forall a b. (a -> b) -> a -> b
$ PassM Region
freshRegVar
                             let c :: Constraint
c = Var -> Region -> Constraint
StartRegionL Var
lv Region
r
                             [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
                     else [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion [Var]
ls Ty2
ty [Constraint]
cs
             else [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion [Var]
ls Ty2
ty [Constraint]
cs
      tryNeedRegion [] Ty2
_ [Constraint]
cs = [Constraint] -> TiM [Constraint]
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Constraint]
cs

      -- | This function will transform a result to wrap the sub-expression with any
      -- simple location bindings for locations from the provided list.
      -- For example, if a location `loc1` is known from an AfterTag constraint,
      -- and `[loc1]` is passed in, the `letloc` binding for `loc1` will be wrapped
      -- around the expression in the result.
      bindImmediateDependentLocs :: [LocVar] -> Result -> TiM Result
      bindImmediateDependentLocs :: [Var] -> Result -> TiM Result
bindImmediateDependentLocs (Var
lv:[Var]
lvs) (Exp2
bod,Ty2
ty,[Constraint]
cs) =
          do (Exp2
bod',Ty2
ty',[Constraint]
cs') <- [Var] -> Result -> TiM Result
bindImmediateDependentLocs [Var]
lvs (Exp2
bod,Ty2
ty,[Constraint]
cs)
             Var -> Result -> TiM Result
bindImmediateDependentLoc Var
lv (Exp2
bod',Ty2
ty',[Constraint]
cs')
      bindImmediateDependentLocs [] Result
res = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res

      -- single location variant of above function
      bindImmediateDependentLoc :: LocVar -> Result -> TiM Result
      bindImmediateDependentLoc :: Var -> Result -> TiM Result
bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,((AfterTagL Var
lv1 Var
lv2) : [Constraint]
cs)) =
          do Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
             Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv1'
             then do (Exp2
bod',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,[Constraint]
cs)
                     let bod'' :: Exp2
bod'' = E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1' (Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
1 Var
lv2') Exp2
bod')
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
bod'',Ty2
ty',[Constraint]
cs')
             else do (Exp2
bod',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,[Constraint]
cs)
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
bod',Ty2
ty',(Var -> Var -> Constraint
AfterTagL Var
lv1 Var
lv2)Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,(Constraint
c:[Constraint]
cs)) =
          do (Exp2
bod',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,[Constraint]
cs)
             Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
bod',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      bindImmediateDependentLoc Var
lv (Exp2
bod,Ty2
ty,[]) = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
bod,Ty2
ty,[])

      -- | This transforms a result to add location bindings that can be inserted safely
      -- once the variable passed in is in scope.
      -- This is expected to be called on the *whole let expression*, not its body.
      handleTrailingBindLoc :: Var -> Result -> TiM Result
      handleTrailingBindLoc :: Var -> Result -> TiM Result
handleTrailingBindLoc Var
v Result
res =
          do (Exp2
e,Ty2
ty,[Constraint]
cs) <- Var -> Result -> TiM Result
bindAfterLoc Var
v Result
res
             case Exp2
e of
               (Ext (LetLocE Var
lv1 (AfterVariableLE Var
v Var
lv2 Bool
True) Exp2
e)) ->
                   do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv1 (Exp2
e,Ty2
ty,[Constraint]
cs)
                      Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1 (Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v Var
lv2 Bool
True) Exp2
e'), Ty2
ty', [Constraint]
cs')
               Exp2
_ -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e,Ty2
ty,[Constraint]
cs) -- Should this signal an error instead of silently returning?

      -- | Transforms a result by adding a location binding derived from an AfterVariable constraint
      -- associated with the passed-in variable.
      bindAfterLoc :: Var -> Result -> TiM Result
      bindAfterLoc :: Var -> Result -> TiM Result
bindAfterLoc Var
v (Exp2
e,Ty2
ty,Constraint
c:[Constraint]
cs) =
          case Constraint
c of
            AfterVariableL Var
lv1 Var
v' Var
lv2 ->
                if Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v'
                then do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
                        Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
                        let res' :: Result
res' = (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1' (Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v Var
lv2 Bool
True) Exp2
e), Ty2
ty, [Constraint]
cs)
                        Result
res'' <- Var -> Result -> TiM Result
bindAfterLoc Var
v Result
res'
                        Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res''
                else do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindAfterLoc Var
v (Exp2
e,Ty2
ty,[Constraint]
cs)
                        Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
            AfterCopyL Var
lv1 Var
v1 Var
v' Var
lv2 Var
f [Var]
lvs ->
                if Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v1
                then do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
                        Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
                        let arrty :: ArrowTy2 Ty2
arrty = Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
                            -- Substitute the location occurring at the call site
                            -- in place of the one in the function's return type
                            copyRetTy :: Ty2
copyRetTy = case ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty of
                                          PackedTy String
_ Var
loc -> Map Var Var -> Ty2 -> Ty2
substLoc (Var -> Var -> Map Var Var
forall k a. k -> a -> Map k a
M.singleton Var
loc Var
lv2) (ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty)
                                          Ty2
_ -> String -> Ty2
forall a. HasCallStack => String -> a
error String
"bindAfterLoc: Not a packed type"
                        let res' :: Result
res'  = ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v',[],Ty2
copyRetTy,Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Var]
lvs [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v1]) (Exp2 -> Exp2) -> Exp2 -> Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1' (Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v' Var
lv2' Bool
True) Exp2
e), Ty2
ty, [Constraint]
cs)
                        Result
res'' <- Var -> Result -> TiM Result
bindAfterLoc Var
v Result
res'
                        Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res''
                else do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindAfterLoc Var
v (Exp2
e,Ty2
ty,[Constraint]
cs)
                        Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
            Constraint
_ -> do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindAfterLoc Var
v (Exp2
e,Ty2
ty,[Constraint]
cs)
                    Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      bindAfterLoc Var
_ (Exp2
e,Ty2
ty,[]) = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e,Ty2
ty,[])

      -- | Transform a result by discharging AfterVariable constraints corresponding to
      -- a list of newly bound variables.
      -- NOTE : Reversing the order in which bindings are discharged seems to fix the location type check error. 
      bindAfterLocs :: [Var] -> Result -> TiM Result
      bindAfterLocs :: [Var] -> Result -> TiM Result
bindAfterLocs (Var
v:[Var]
vs) Result
res =
          do Result
res'' <- [Var] -> Result -> TiM Result
bindAfterLocs [Var]
vs Result
res
             Var -> Result -> TiM Result
bindAfterLoc Var
v Result
res''
      bindAfterLocs [] Result
res = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res

      -- | Transforms a result by binding any additional locations that are safe to be bound
      -- once the location passed in has been bound. For example, if we know `loc1` is `n`
      -- bytes after `loc2`, and `loc2` has been passed in, we can bind `loc1`.
      bindTrivialAfterLoc :: LocVar -> Result -> TiM Result
      bindTrivialAfterLoc :: Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv (Exp2
e,Ty2
ty,Constraint
c:[Constraint]
cs) =
          case Constraint
c of
            AfterTagL Var
lv1 Var
lv2 ->
                do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
                   Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
                   Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                   if Var
lv2' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv'
                   then do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv1 (Exp2
e,Ty2
ty,[Constraint]
cs)
                           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1' (Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
1 Var
lv2') Exp2
e'), Ty2
ty', [Constraint]
cs')
                   else do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv (Exp2
e,Ty2
ty,[Constraint]
cs)
                           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
            AfterConstantL Var
lv1 Int
v Var
lv2 ->
                do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
                   Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
                   Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                   if Var
lv2' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv'
                   then do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv1 (Exp2
e,Ty2
ty,[Constraint]
cs)
                           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
lv1' (Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
v Var
lv2') Exp2
e'), Ty2
ty', [Constraint]
cs')
                   else do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv (Exp2
e,Ty2
ty,[Constraint]
cs)
                           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
            Constraint
_ -> do (Exp2
e',Ty2
ty',[Constraint]
cs') <- Var -> Result -> TiM Result
bindTrivialAfterLoc Var
lv (Exp2
e,Ty2
ty,[Constraint]
cs)
                    Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',Constraint
cConstraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[Constraint]
cs')
      bindTrivialAfterLoc Var
_ (Exp2
e,Ty2
ty,[]) = Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e,Ty2
ty,[])

      -- | To handle a case expression, we need to bind locations
      -- appropriately for all the fields.
      doCase :: DDefs Ty2 -> FullEnv -> LocVar -> Dest
             -> (DataCon, [(Var,())], Exp1) ->
             TiM ((DataCon, [(Var,LocVar)], L2.Exp2), Ty2, [Constraint])
      doCase :: DDefs Ty2
-> FullEnv
-> Var
-> Dest
-> (String, [(Var, ())], Exp1)
-> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
doCase DDefs Ty2
ddfs FullEnv
env Var
src Dest
dst (String
con,[(Var, ())]
vars,Exp1
rhs) = do
        [(Var, Var)]
vars' <- [(Var, ())]
-> ((Var, ())
    -> ExceptT Failure (StateT InferState PassM) (Var, Var))
-> ExceptT Failure (StateT InferState PassM) [(Var, Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Var, ())]
vars (((Var, ())
  -> ExceptT Failure (StateT InferState PassM) (Var, Var))
 -> ExceptT Failure (StateT InferState PassM) [(Var, Var)])
-> ((Var, ())
    -> ExceptT Failure (StateT InferState PassM) (Var, Var))
-> ExceptT Failure (StateT InferState PassM) [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ \(Var
v,()
_) -> do Var
lv <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"case"
                                          UnifyLoc
_ <- Var -> TiM UnifyLoc
fixLoc Var
lv
                                          (Var, Var) -> ExceptT Failure (StateT InferState PassM) (Var, Var)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
v,Var
lv)
        let contys :: [Ty2]
contys = DDefs Ty2 -> String -> [Ty2]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs Ty2
ddfs String
con
            newtys :: [Ty2]
newtys = ((Ty2, (Var, Var)) -> Ty2) -> [(Ty2, (Var, Var))] -> [Ty2]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Ty2
ty,(Var
_,Var
lv)) -> (Var -> Var) -> Ty2 -> Ty2
forall a b. (a -> b) -> UrTy a -> UrTy b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var -> Var -> Var
forall a b. a -> b -> a
const Var
lv) Ty2
ty) ([(Ty2, (Var, Var))] -> [Ty2]) -> [(Ty2, (Var, Var))] -> [Ty2]
forall a b. (a -> b) -> a -> b
$ [Ty2] -> [(Var, Var)] -> [(Ty2, (Var, Var))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ty2]
contys [(Var, Var)]
vars'
            env' :: FullEnv
env' = ((Var, Ty2) -> FullEnv -> FullEnv)
-> FullEnv -> [(Var, Ty2)] -> FullEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (\(Var
v,Ty2
ty) FullEnv
a -> Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
v Ty2
ty FullEnv
a) FullEnv
env ([(Var, Ty2)] -> FullEnv) -> [(Var, Ty2)] -> FullEnv
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty2] -> [(Var, Ty2)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var, Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Var)]
vars') [Ty2]
newtys
        Result
res <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env' Exp1
rhs Dest
dst
        (Exp2
rhs',Ty2
ty',[Constraint]
cs') <-   [Var] -> Result -> TiM Result
bindAfterLocs (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
rhs) Result
res
        -- let cs'' = removeLocs (L.map snd vars') cs'
        -- TODO: check constraints are correct and fail/repair if they're not!!!
        ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
-> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
con,[(Var, Var)]
vars',Exp2
rhs'),Ty2
ty',[Constraint]
cs')


  in
  case Exp1
ex0 of
    VarE Var
v ->
      let e' :: Exp2
e' = Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v in
      case Dest
dest of
        Dest
NoDest -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e', Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv
env, [])
        TupleDest [Dest]
ds ->
           let ProdTy [Ty2]
tys = Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv
env
           in [Dest] -> [Ty2] -> TiM Result -> TiM Result -> TiM Result
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys
              (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e', [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [Ty2]
tys, []))
              (String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"TODO: support copying parts of tuples " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dest] -> String
forall a. Out a => a -> String
sdoc [Dest]
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for types " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Ty2] -> String
forall a. Out a => a -> String
sdoc [Ty2]
tys)
        SingleDest Var
d  -> do
                  let ty :: Ty2
ty  = Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv
env
                  Var
loc <- case Ty2
ty of
                           PackedTy String
_ Var
lv -> Var -> TiM Var
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
lv
                           -- TODO: refactor this so we never try to put a non-packed type
                           -- in a location
                           Ty2
_ -> StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"imm"
                  let ty' :: Ty2
ty' = case Ty2
ty of
                              PackedTy String
k Var
lv -> String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
k Var
d
                              Ty2
t -> Ty2
t
                  Var -> Var -> TiM Result -> TiM Result -> TiM Result
forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
d Var
loc
                            (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',[]))
                            (Result -> Var -> TiM Result
copy (Exp2
e',Ty2
ty,[]) Var
d)

    ProjE Int
i Exp1
w -> do
        (Exp2
e', Ty2
ty) <- case Exp1
w of
          VarE Var
v -> (Exp2, Ty2) -> TiM (Exp2, Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v), let ProdTy [Ty2]
tys = Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv
env in [Ty2]
tys [Ty2] -> Int -> Ty2
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
          Exp1
w' -> (\(Exp2
e, ProdTy [Ty2]
bs, [Constraint]
_) -> (Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp2
e, [Ty2]
bs [Ty2] -> Int -> Ty2
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)) (Result -> (Exp2, Ty2)) -> TiM Result -> TiM (Exp2, Ty2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
w Dest
dest
        case Dest
dest of
            Dest
NoDest -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e', Ty2
ty, [])
            TupleDest [Dest]
ds -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"TODO: handle tuple of destinations for ProjE"
            SingleDest Var
d -> do
                Var
loc <- case Ty2
ty of
                          PackedTy String
_ Var
lv -> Var -> TiM Var
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
lv
                          Ty2
_ -> StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"imm"
                let ty' :: Ty2
ty' = case Ty2
ty of
                            PackedTy String
k Var
lv -> String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
k Var
d
                            Ty2
t -> Ty2
t
                Var -> Var -> TiM Result -> TiM Result -> TiM Result
forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
d Var
loc
                          (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
ty',[]))
                          (Result -> Var -> TiM Result
copy (Exp2
e',Ty2
ty,[]) Var
d)

    MkProdE [Exp1]
ls ->
      case Dest
dest of
        Dest
NoDest -> do [Result]
results <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Exp1]
ls
                     let pty :: Ty2
pty = case [Result]
results of
                                 [(Exp2
_,Ty2
ty,[Constraint]
_)] -> Ty2
ty
                                 [Result]
_ -> [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy ([Ty2
b | (Exp2
_,Ty2
b,[Constraint]
_) <- [Result]
results])
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
results]), Ty2
pty,
                               [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
results])
        SingleDest Var
d -> case [Exp1]
ls of
                          [Exp1
e] -> do (Exp2
e',Ty2
ty,[Constraint]
les) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
dest
                                    Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp2
e'], Ty2
ty, [Constraint]
les)
                          [Exp1]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Cannot match single destination to tuple: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Show a => a -> String
show Exp1
ex0
        TupleDest [Dest]
ds -> do [Result]
results <- ((Exp1, Dest) -> TiM Result)
-> [(Exp1, Dest)]
-> ExceptT Failure (StateT InferState PassM) [Result]
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 (\(Exp1
e,Dest
d) -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
d) ([(Exp1, Dest)]
 -> ExceptT Failure (StateT InferState PassM) [Result])
-> [(Exp1, Dest)]
-> ExceptT Failure (StateT InferState PassM) [Result]
forall a b. (a -> b) -> a -> b
$ [Exp1] -> [Dest] -> [(Exp1, Dest)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp1]
ls [Dest]
ds
                           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
results]),
                                     [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy ([Ty2
b | (Exp2
_,Ty2
b,[Constraint]
_) <- [Result]
results]),
                                     [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
results])


    SpawnE Var
f [()]
_ [Exp1]
args -> do
      (Exp2
ex0', Ty2
ty, [Constraint]
acs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp1]
args) Dest
dest
      case Exp2
ex0' of
        AppE Var
f' [Var]
locs [Exp2]
args' -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f' [Var]
locs [Exp2]
args', Ty2
ty, [Constraint]
acs)
        Exp2
oth -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"SpawnE: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
oth

    Exp1
SyncE -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE, [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [], [])

    LitE Int
n  -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Exp2
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
n, Ty2
forall loc. UrTy loc
IntTy, [])
    CharE Char
n -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Exp2
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
CharE Char
n, Ty2
forall loc. UrTy loc
CharTy, [])
    FloatE Double
n-> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Exp2
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
FloatE Double
n, Ty2
forall loc. UrTy loc
FloatTy, [])

    LitSymE Var
s -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE Var
s, Ty2
forall loc. UrTy loc
SymTy, [])

    AppE Var
f [()]
_ [Exp1]
args ->
        do let arrty :: ArrowTy2 Ty2
arrty = Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
           Ty2
valTy    <- Ty2 -> TiM Ty2
freshTyLocs (Ty2 -> TiM Ty2) -> Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty
           -- /cc @vollmerm
           [Ty2]
argTys   <- (Ty2 -> TiM Ty2)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
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 Ty2 -> TiM Ty2
freshTyLocs ([Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2])
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
forall a b. (a -> b) -> a -> b
$ ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 Ty2
arrty
           [Dest]
argDests <- (Ty2 -> TiM Dest)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Dest]
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 Ty2 -> TiM Dest
destFromType' [Ty2]
argTys
           ([Exp2]
args', [Ty2]
atys, [[Constraint]]
acss) <- [Result] -> ([Exp2], [Ty2], [[Constraint]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
L.unzip3 ([Result] -> ([Exp2], [Ty2], [[Constraint]]))
-> ExceptT Failure (StateT InferState PassM) [Result]
-> ExceptT
     Failure (StateT InferState PassM) ([Exp2], [Ty2], [[Constraint]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Exp1, Dest) -> TiM Result)
-> [(Exp1, Dest)]
-> ExceptT Failure (StateT InferState PassM) [Result]
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 ((Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result)
-> (Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result
forall a b. (a -> b) -> a -> b
$ FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env) ([Exp1] -> [Dest] -> [(Exp1, Dest)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp1]
args [Dest]
argDests)
           let acs :: [Constraint]
acs = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Constraint]]
acss
           case Dest
dest of
             SingleDest Var
d -> do
               case Ty2 -> [Var]
locsInTy Ty2
valTy of
                 [Var
outloc] -> Var -> Var -> TiM Result -> TiM Result -> TiM Result
forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
d Var
outloc
                               (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.AppE Var
f ((Ty2 -> [Var]) -> [Ty2] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [Var]
locsInTy [Ty2]
atys [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Dest -> [Var]
locsInDest Dest
dest) [Exp2]
args', Ty2
valTy, [Constraint]
acs))
                               (String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"(AppE) Cannot unify" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
outloc)
                 [Var]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"AppE expected a single output location in type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ty2 -> String
forall a. Out a => a -> String
sdoc Ty2
valTy
             TupleDest [Dest]
ds ->
               case Ty2
valTy of
                 ProdTy [Ty2]
tys -> [Dest] -> [Ty2] -> TiM Result -> TiM Result -> TiM Result
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys
                                 (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.AppE Var
f ((Ty2 -> [Var]) -> [Ty2] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [Var]
locsInTy [Ty2]
atys [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Dest -> [Var]
locsInDest Dest
dest) [Exp2]
args', Ty2
valTy, [Constraint]
acs))
                                 (String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"(AppE) Cannot unify" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dest] -> String
forall a. Out a => a -> String
sdoc [Dest]
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Ty2] -> String
forall a. Out a => a -> String
sdoc [Ty2]
tys)
                 Ty2
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"(AppE) Cannot unify" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dest -> String
forall a. Out a => a -> String
sdoc Dest
dest String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ty2 -> String
forall a. Out a => a -> String
sdoc Ty2
valTy
             Dest
NoDest ->
               case Ty2 -> [Var]
locsInTy Ty2
valTy of
                 [] -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.AppE Var
f ((Ty2 -> [Var]) -> [Ty2] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [Var]
locsInTy [Ty2]
atys [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Dest -> [Var]
locsInDest Dest
dest) [Exp2]
args', Ty2
valTy, [Constraint]
acs)
                 [Var]
_  -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"(AppE) Cannot unify NoDest with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ty2 -> String
forall a. Out a => a -> String
sdoc Ty2
valTy String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". This might be caused by a main expression having a packed type." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0

    TimeIt Exp1
e Ty1
t Bool
b ->
        do (Exp2
e',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
dest
           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp2
e' Ty2
ty' Bool
b, Ty2
ty', [Constraint]
cs')

    WithArenaE Var
v Exp1
e ->
        do (Exp2
e',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
v Ty2
forall loc. UrTy loc
ArenaTy FullEnv
env) Exp1
e Dest
dest
           Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp2
e', Ty2
ty', [Constraint]
cs')

    DataConE () String
k [] -> do
        case Dest
dest of
          Dest
NoDest -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Expected single location destination for DataConE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0
          TupleDest [Dest]
_ds -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Expected single location destination for DataConE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0
          SingleDest Var
d ->
              do Var
fakeLoc <- TiM Var
fresh
                 let constrs :: [Constraint]
constrs = [Var -> Var -> Constraint
AfterTagL Var
fakeLoc Var
d]
                 Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
d String
k [], String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy (DDefs Ty2 -> ShowS
forall a. Out a => DDefs a -> ShowS
getTyOfDataCon DDefs Ty2
dataDefs String
k) Var
d, [Constraint]
constrs)

    DataConE () String
k [Exp1]
ls ->
      case Dest
dest of
        Dest
NoDest -> do
          -- CSK: Should this really be an error ?
          Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"datacon"
          (Exp2
e',Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (() -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () String
k [Exp1]
ls) (Var -> Dest
SingleDest Var
loc)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs
          Result -> TiM Result
tryBindReg (Exp2
e', Ty2
ty, [Constraint]
fcs)
        TupleDest [Dest]
_ds -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Expected single location destination for DataConE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0
        SingleDest Var
d -> do
                  [Var]
locs <- [TiM Var] -> ExceptT Failure (StateT InferState PassM) [Var]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([TiM Var] -> ExceptT Failure (StateT InferState PassM) [Var])
-> [TiM Var] -> ExceptT Failure (StateT InferState PassM) [Var]
forall a b. (a -> b) -> a -> b
$ Int -> TiM Var -> [TiM Var]
forall a. Int -> a -> [a]
replicate ([Exp1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp1]
ls) TiM Var
fresh
                  (Var -> TiM UnifyLoc)
-> [Var] -> ExceptT Failure (StateT InferState PassM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Var -> TiM UnifyLoc
fixLoc [Var]
locs -- Don't allow argument locations to freely unify
                  [Result]
ls' <- ((Exp1, Var) -> TiM Result)
-> [(Exp1, Var)]
-> ExceptT Failure (StateT InferState PassM) [Result]
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 (\(Exp1
e,Var
lv) -> (FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e (Dest -> TiM Result) -> Dest -> TiM Result
forall a b. (a -> b) -> a -> b
$ Var -> Dest
SingleDest Var
lv)) ([(Exp1, Var)]
 -> ExceptT Failure (StateT InferState PassM) [Result])
-> [(Exp1, Var)]
-> ExceptT Failure (StateT InferState PassM) [Result]
forall a b. (a -> b) -> a -> b
$ [Exp1] -> [Var] -> [(Exp1, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp1]
ls [Var]
locs
                  -- let ls'' = L.map unNestLet ls'
                  --     bnds = catMaybes $ L.map pullBnds ls'
                  --     env' = addCopyVarToEnv ls' env
                  -- Arguments are either a fixed size or a variable
                  -- TODO: audit this!
                  [DCArg]
argLs <- [Exp2]
-> (Exp2 -> ExceptT Failure (StateT InferState PassM) DCArg)
-> ExceptT Failure (StateT InferState PassM) [DCArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
ls'] ((Exp2 -> ExceptT Failure (StateT InferState PassM) DCArg)
 -> ExceptT Failure (StateT InferState PassM) [DCArg])
-> (Exp2 -> ExceptT Failure (StateT InferState PassM) DCArg)
-> ExceptT Failure (StateT InferState PassM) [DCArg]
forall a b. (a -> b) -> a -> b
$ \Exp2
arg ->
                           case Exp2
arg of
                             (VarE Var
v) -> case Var -> FullEnv -> Ty2
lookupVEnv Var
v FullEnv
env of
                                               Ty2
CursorTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed Int
8
                                               Ty2
IntTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
IntTy)
                                               Ty2
FloatTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
FloatTy)
                                               Ty2
SymTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
SymTy)
                                               Ty2
BoolTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
BoolTy)
                                               Ty2
CharTy -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
CharTy)
                                               VectorTy Ty2
elt -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Ty2 -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy (Ty2 -> Ty2
forall loc. UrTy loc -> UrTy loc
VectorTy Ty2
elt))
                                               ListTy Ty2
elt -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Ty2 -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy (Ty2 -> Ty2
forall loc. UrTy loc -> UrTy loc
ListTy Ty2
elt))
                                               Ty2
_ -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Var -> DCArg
ArgVar Var
v
                             (LitE Int
_) -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
IntTy)
                             (FloatE Double
_) -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
FloatTy)
                             (LitSymE Var
_) -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
SymTy)
                             (PrimAppE Prim Ty2
MkTrue []) -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
BoolTy)
                             (PrimAppE Prim Ty2
MkFalse []) -> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Int -> DCArg
ArgFixed (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
BoolTy)
                             (AppE Var
f [Var]
lvs [(VarE Var
v)]) -> do Var
v' <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"cpy"
                                                           DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCArg -> ExceptT Failure (StateT InferState PassM) DCArg)
-> DCArg -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ Var -> Var -> Var -> [Var] -> DCArg
ArgCopy Var
v Var
v' Var
f [Var]
lvs
                             Exp2
_ -> String -> ExceptT Failure (StateT InferState PassM) DCArg
forall a. HasCallStack => String -> a
err (String -> ExceptT Failure (StateT InferState PassM) DCArg)
-> String -> ExceptT Failure (StateT InferState PassM) DCArg
forall a b. (a -> b) -> a -> b
$ String
"Expected argument to be trivial, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Exp2 -> String
forall a. Show a => a -> String
show Exp2
arg)
                  [Var]
newLocs <- (Var -> TiM Var)
-> [Var] -> ExceptT Failure (StateT InferState PassM) [Var]
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 Var -> TiM Var
finalLocVar [Var]
locs
                  let afterVar :: (DCArg, Maybe LocVar, Maybe LocVar) -> Maybe Constraint
                      afterVar :: (DCArg, Maybe Var, Maybe Var) -> Maybe Constraint
afterVar ((ArgVar Var
v), (Just Var
loc1), (Just Var
loc2)) =
                          Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just (Constraint -> Maybe Constraint) -> Constraint -> Maybe Constraint
forall a b. (a -> b) -> a -> b
$ Var -> Var -> Var -> Constraint
AfterVariableL Var
loc1 Var
v Var
loc2
                      afterVar ((ArgFixed Int
s), (Just Var
loc1), (Just Var
loc2)) =
                          Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just (Constraint -> Maybe Constraint) -> Constraint -> Maybe Constraint
forall a b. (a -> b) -> a -> b
$ Var -> Int -> Var -> Constraint
AfterConstantL Var
loc1 Int
s Var
loc2
                      afterVar ((ArgCopy Var
v Var
v' Var
f [Var]
lvs), (Just Var
loc1), (Just Var
loc2)) =
                          Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just (Constraint -> Maybe Constraint) -> Constraint -> Maybe Constraint
forall a b. (a -> b) -> a -> b
$ Var -> Var -> Var -> Var -> Var -> [Var] -> Constraint
AfterCopyL Var
loc1 Var
v Var
v' Var
loc2 Var
f [Var]
lvs
                      afterVar (DCArg, Maybe Var, Maybe Var)
_ = Maybe Constraint
forall a. Maybe a
Nothing
                      constrs :: [Constraint]
constrs = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
ls']
                      constrs' :: [Constraint]
constrs' = if [Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
locs
                                 then [Constraint]
constrs
                                 else let tmpconstrs :: [Constraint]
tmpconstrs = [Var -> Var -> Constraint
AfterTagL ([Var] -> Var
forall a. HasCallStack => [a] -> a
L.head [Var]
locs) Var
d] [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++
                                                       (((DCArg, Maybe Var, Maybe Var) -> Maybe Constraint)
-> [(DCArg, Maybe Var, Maybe Var)] -> [Constraint]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DCArg, Maybe Var, Maybe Var) -> Maybe Constraint
afterVar ([(DCArg, Maybe Var, Maybe Var)] -> [Constraint])
-> [(DCArg, Maybe Var, Maybe Var)] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [DCArg]
-> [Maybe Var] -> [Maybe Var] -> [(DCArg, Maybe Var, Maybe Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3
                                                         -- ((map Just $ L.tail ([a | (a,_,_) <- ls' ])) ++ [Nothing])
                                                        [DCArg]
argLs
                                                         -- (map Just locs)
                                                        (((Var -> Maybe Var) -> [Var] -> [Maybe Var]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Maybe Var
forall a. a -> Maybe a
Just ([Var] -> [Maybe Var]) -> [Var] -> [Maybe Var]
forall a b. (a -> b) -> a -> b
$ [Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail [Var]
locs) [Maybe Var] -> [Maybe Var] -> [Maybe Var]
forall a. [a] -> [a] -> [a]
++ [Maybe Var
forall a. Maybe a
Nothing])
                                                        ((Var -> Maybe Var) -> [Var] -> [Maybe Var]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Maybe Var
forall a. a -> Maybe a
Just [Var]
locs))
                                                         -- ((map Just $ L.tail locs) ++ [Nothing])) ++
                                      in [Constraint]
tmpconstrs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
constrs
                  -- traceShow k $ traceShow locs $
                  --let newe = buildLets bnds $ DataConE d k [ e' | (e',_,_)  <- ls'']
                  [Result]
ls'' <- [(DCArg, Result)]
-> ((DCArg, Result) -> TiM Result)
-> ExceptT Failure (StateT InferState PassM) [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([DCArg] -> [Result] -> [(DCArg, Result)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DCArg]
argLs [Result]
ls') (((DCArg, Result) -> TiM Result)
 -> ExceptT Failure (StateT InferState PassM) [Result])
-> ((DCArg, Result) -> TiM Result)
-> ExceptT Failure (StateT InferState PassM) [Result]
forall a b. (a -> b) -> a -> b
$ \(DCArg
arg,(Exp2
e,Ty2
ty,[Constraint]
cs)) -> do
                            case Exp2
e of
                              (AppE Var
_ [Var]
_ [Exp2]
_) -> case DCArg
arg of
                                                    ArgCopy Var
_ Var
v' Var
_ [Var]
_ -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v',Ty2
ty,[Constraint]
cs)
                                                    DCArg
_ -> TiM Result
forall a. HasCallStack => a
undefined
                              Exp2
_ -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e,Ty2
ty,[Constraint]
cs)
                  -- bod <- return $ DataConE d k [ e' | (e',_,_)  <- ls'']
                  Exp2
bod <- if ([Exp1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp1]
ls) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Exp2 -> Bool
isCpyCall (Exp2 -> Bool) -> Exp2 -> Bool
forall a b. (a -> b) -> a -> b
$ [Exp2] -> Exp2
forall a. HasCallStack => [a] -> a
last [Exp2
e | (Exp2
e,Ty2
_,[Constraint]
_) <- [Result]
ls'])
                         then case [Exp2] -> Exp2
forall a. HasCallStack => [a] -> a
last [Exp2
e | (Exp2
e,Ty2
_,[Constraint]
_) <- [Result]
ls'] of
                                (AppE Var
f [Var]
lvs [Exp2]
e) ->
                                    let (ArgCopy Var
_ Var
v' Var
_ [Var]
copy_locs) = [DCArg] -> DCArg
forall a. HasCallStack => [a] -> a
last [DCArg]
argLs
                                        arrty :: Ty2
arrty = ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut (ArrowTy2 Ty2 -> Ty2) -> ArrowTy2 Ty2 -> Ty2
forall a b. (a -> b) -> a -> b
$ Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
                                        -- Substitute the location occurring at the call site
                                        -- in place of the one in the function's return type
                                        -- re:last because we want the output location.
                                        copyRetTy :: Ty2
copyRetTy = case Ty2
arrty of
                                          PackedTy String
_ Var
loc -> Map Var Var -> Ty2 -> Ty2
substLoc (Var -> Var -> Map Var Var
forall k a. k -> a -> Map k a
M.singleton Var
loc ([Var] -> Var
forall a. HasCallStack => [a] -> a
last [Var]
copy_locs)) Ty2
arrty
                                          Ty2
_ -> String -> Ty2
forall a. HasCallStack => String -> a
error String
"inferExp: Not a packed type"
                                    in Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v',[],Ty2
copyRetTy, Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Var]
lvs [Exp2]
e) (Exp2 -> Exp2) -> Exp2 -> Exp2
forall a b. (a -> b) -> a -> b
$
                                       Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
d String
k [ Exp2
e' | (Exp2
e',Ty2
_,[Constraint]
_) <- [Result]
ls'']
                                Exp2
_ -> String -> TiM Exp2
forall a. HasCallStack => String -> a
error String
"inferExp: Unexpected pattern <error1>"
                         else Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
d String
k [ Exp2
e' | (Exp2
e',Ty2
_,[Constraint]
_)  <- [Result]
ls'']
                  Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
bod, String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy (DDefs Ty2 -> ShowS
forall a. Out a => DDefs a -> ShowS
getTyOfDataCon DDefs Ty2
dataDefs String
k) Var
d, [Constraint]
constrs')

    IfE Exp1
a Exp1
b c :: Exp1
c@Exp1
ce -> do
       -- Here we blithely assume BoolTy because L1 typechecking has already passed:
       (Exp2
a',Ty2
bty,[Constraint]
acs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
a Dest
NoDest
       Ty2 -> Ty2 -> ExceptT Failure (StateT InferState PassM) ()
forall a.
(Eq a, Show a) =>
a -> a -> ExceptT Failure (StateT InferState PassM) ()
assumeEq Ty2
bty Ty2
forall loc. UrTy loc
BoolTy
       -- Here BOTH branches are unified into the destination, so
       -- there is no need to unify with eachother.
       Result
res    <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
b Dest
dest
       -- bind variables after if branch
       -- This ensures that the location bindings are not freely floated up to the upper level expressions
       (Exp2
b',Ty2
tyb,[Constraint]
csb) <-   [Var] -> Result -> TiM Result
bindAfterLocs ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
removeDuplicates (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
b)) Result
res

       -- Else branch
       Result
res'    <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
c Dest
dest
       -- bind variables after else branch
       -- This ensures that the location bindings are not freely floated up to the upper level expressions
       (Exp2
c',Ty2
tyc,[Constraint]
csc) <-   [Var] -> Result -> TiM Result
bindAfterLocs ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
removeDuplicates (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
c)) Result
res'

       Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp2
a' Exp2
b' Exp2
c', Ty2
tyc, [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
acs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
csb [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
csc)

    PrimAppE (DictInsertP Ty1
dty) [(VarE Var
var),Exp1
d,Exp1
k,Exp1
v] ->
      case Dest
dest of
        SingleDest Var
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictInsert with destination"
        TupleDest [Dest]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictInsert with destination"
        Dest
NoDest -> do (Exp2
d',SymDictTy Maybe Var
ar Ty1
dty',[Constraint]
_dcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
d Dest
NoDest
                     (Exp2
k',Ty2
_,[Constraint]
_kcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
k Dest
NoDest
                     Ty2
dty'' <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
dty
                     Region
r <- StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Region
 -> ExceptT Failure (StateT InferState PassM) Region)
-> StateT InferState PassM Region
-> ExceptT Failure (StateT InferState PassM) Region
forall a b. (a -> b) -> a -> b
$ PassM Region -> StateT InferState PassM Region
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Region -> StateT InferState PassM Region)
-> PassM Region -> StateT InferState PassM Region
forall a b. (a -> b) -> a -> b
$ PassM Region
freshRegVar
                     Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"ins"
                     -- _ <- fixLoc loc
                     (Exp2
v',Ty2
vty,[Constraint]
vcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
v (Dest -> TiM Result) -> Dest -> TiM Result
forall a b. (a -> b) -> a -> b
$ Var -> Dest
SingleDest Var
loc
                     let cs :: [Constraint]
cs = [Constraint]
vcs -- (StartRegionL loc r) : vcs
                     Ty2
dummyDty <- Ty1 -> TiM Ty2
forall (f :: * -> *). Applicative f => Ty1 -> f Ty2
dummyTyLocs Ty1
dty'
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictInsertP Ty2
dummyDty) [(Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
var),Exp2
d',Exp2
k',Exp2
v'], Maybe Var -> Ty1 -> Ty2
forall loc. Maybe Var -> Ty1 -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
var) (Ty1 -> Ty2) -> Ty1 -> Ty2
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty1
forall a. UrTy a -> Ty1
stripTyLocs Ty2
dty'', [Constraint]
cs)

    PrimAppE (DictLookupP Ty1
dty) [Exp1
d,Exp1
k] ->
      case Dest
dest of
        SingleDest Var
loc -> do (Exp2
d',SymDictTy Maybe Var
_ Ty1
_dty,[Constraint]
_dcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
d Dest
NoDest
                             (Exp2
k',Ty2
_,[Constraint]
_kcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
k Dest
NoDest
                             Ty2
dty' <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
dty
                             let loc' :: Var
loc' = Ty2 -> Var
locOfTy Ty2
dty'
                             UnifyLoc
_ <- Var -> TiM UnifyLoc
fixLoc Var
loc'
                             let e' :: Exp2
e' = Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictLookupP Ty2
dty') [Exp2
d',Exp2
k']
                                 cs :: [Constraint]
cs = [Var -> Constraint
FreeL Var
loc']
                             Var -> Var -> TiM Result -> TiM Result -> TiM Result
forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
loc Var
loc'
                                   (Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
e',Ty2
dty',[Constraint]
cs))
                                   (Result -> Var -> TiM Result
copy (Exp2
e',Ty2
dty',[Constraint]
cs) Var
loc)
        TupleDest [Dest]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictLookup with tuple destination"
        Dest
NoDest -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictLookup with no destination"

    PrimAppE (DictEmptyP Ty1
dty) [(VarE Var
var)] ->
      case Dest
dest of
        SingleDest Var
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictEmpty with destination"
        TupleDest [Dest]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictEmpty with destination"
        Dest
NoDest -> do Ty2
dty' <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
dty
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictEmptyP Ty2
dty') [(Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
var)], Maybe Var -> Ty1 -> Ty2
forall loc. Maybe Var -> Ty1 -> UrTy loc
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
var) (Ty1 -> Ty2) -> Ty1 -> Ty2
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty1
forall a. UrTy a -> Ty1
stripTyLocs Ty2
dty', [])

    PrimAppE (DictHasKeyP Ty1
dty) [Exp1
d,Exp1
k] ->
      case Dest
dest of
        SingleDest Var
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictEmpty with destination"
        TupleDest [Dest]
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err String
"Cannot unify DictEmpty with destination"
        Dest
NoDest -> do (Exp2
d',SymDictTy Maybe Var
_ Ty1
dty',[Constraint]
_dcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
d Dest
NoDest
                     (Exp2
k',Ty2
_,[Constraint]
_kcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
k Dest
NoDest
                     Ty2
dummyDty <- Ty1 -> TiM Ty2
forall (f :: * -> *). Applicative f => Ty1 -> f Ty2
dummyTyLocs Ty1
dty'
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictHasKeyP Ty2
dummyDty) [Exp2
d',Exp2
k'], Ty2
forall loc. UrTy loc
BoolTy, [])

    -- Special case for VSortP because we don't want to lookup fp in
    -- the type environment.
    PrimAppE pr :: Prim Ty1
pr@(VSortP{}) [VarE Var
ls, VarE Var
fp] ->
      case Dest
dest of
        SingleDest Var
d -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Cannot unify primop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim Ty1 -> String
forall a. Out a => a -> String
sdoc Prim Ty1
pr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with destination " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
d
        TupleDest  [Dest]
d -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Cannot unify primop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim Ty1 -> String
forall a. Out a => a -> String
sdoc Prim Ty1
pr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with destination " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dest] -> String
forall a. Out a => a -> String
sdoc [Dest]
d
        Dest
NoDest -> do [Result]
results <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ls]
                     -- Assume arguments to PrimAppE are trivial
                     -- so there's no need to deal with constraints or locations
                     Ty2
ty <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy (Ty1 -> PassM Ty2) -> Ty1 -> PassM Ty2
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> Ty1
forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim Ty1
pr
                     Prim Ty2
pr' <- StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (Prim Ty2)
 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2))
-> PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> PassM (Prim Ty2)
prim Prim Ty1
pr
                     let args :: [Exp2]
args = [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
results] [Exp2] -> [Exp2] -> [Exp2]
forall a. [a] -> [a] -> [a]
++ [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty2
pr' [Exp2]
args, Ty2
ty, [])

    PrimAppE Prim Ty1
pr [Exp1]
es ->
      case Dest
dest of
        SingleDest Var
d -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Cannot unify primop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim Ty1 -> String
forall a. Out a => a -> String
sdoc Prim Ty1
pr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with destination " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dest -> String
forall a. Out a => a -> String
sdoc Dest
dest String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0
        TupleDest  [Dest]
d ->
          case Prim Ty1
pr of
            Prim Ty1
PrintInt -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex0 Dest
NoDest
            Prim Ty1
PrintFloat -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex0 Dest
NoDest
            Prim Ty1
PrintBool -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex0 Dest
NoDest
            Prim Ty1
PrintSym -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex0 Dest
NoDest
            VNthP{} -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex0 Dest
NoDest
            Prim Ty1
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Cannot unify primop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim Ty1 -> String
forall a. Out a => a -> String
sdoc Prim Ty1
pr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with destination " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dest -> String
forall a. Out a => a -> String
sdoc Dest
dest String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0
        Dest
NoDest -> do [Result]
results <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Exp1]
es
                     -- Assume arguments to PrimAppE are trivial
                     -- so there's no need to deal with constraints or locations
                     Ty2
ty <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy (Ty1 -> PassM Ty2) -> Ty1 -> PassM Ty2
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> Ty1
forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim Ty1
pr
                     Prim Ty2
pr' <- StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (Prim Ty2)
 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2))
-> PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> PassM (Prim Ty2)
prim Prim Ty1
pr
                     Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty2
pr' [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
results], Ty2
ty, [])

    CaseE Exp1
ex [(String, [(Var, ())], Exp1)]
ls -> do
      -- Case expressions introduce fresh destinations for the scrutinee:
      Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"scrut"
      (Exp2
ex',Ty2
ty2,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex (Var -> Dest
SingleDest Var
loc)
      let src :: Var
src = Ty2 -> Var
locOfTy Ty2
ty2
      [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs <- ((String, [(Var, ())], Exp1)
 -> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint]))
-> [(String, [(Var, ())], Exp1)]
-> ExceptT
     Failure
     (StateT InferState PassM)
     [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
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 (DDefs Ty2
-> FullEnv
-> Var
-> Dest
-> (String, [(Var, ())], Exp1)
-> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
doCase DDefs Ty2
dataDefs FullEnv
env Var
src Dest
dest) [(String, [(Var, ())], Exp1)]
ls
      Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp2
ex' ([(String, [(Var, Var)], Exp2)
a | ((String, [(Var, Var)], Exp2)
a,Ty2
_,[Constraint]
_) <- [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs]),
              (\((String, [(Var, Var)], Exp2)
_,Ty2
b,[Constraint]
_)->Ty2
b) ([((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
-> ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
forall a. HasCallStack => [a] -> a
L.head [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs),
              ([[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | ((String, [(Var, Var)], Exp2)
_,Ty2
_,[Constraint]
c) <- [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs]))

    Ext (L1.AddFixed Var
cur Int
i) -> Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
L2.Ext (Var -> Int -> E2Ext Var Ty2
forall loc dec. Var -> Int -> E2Ext loc dec
L2.AddFixed Var
cur Int
i), Ty2
forall loc. UrTy loc
CursorTy, [])
    Ext (L1.StartOfPkdCursor Var
cur) -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"unbound " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0

    LetE (Var
vr,[()]
locs,Ty1
bty,Exp1
rhs) Exp1
bod | [] <- [()]
locs ->
      case Exp1
rhs of
        VarE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Unexpected variable aliasing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
ex0)

        AppE Var
f [] [Exp1]
args -> do
          let arrty :: ArrowTy2 Ty2
arrty = Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
          Ty2
valTy <- Ty2 -> TiM Ty2
freshTyLocs (Ty2 -> TiM Ty2) -> Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 Ty2
arrty
          -- /cc @vollmerm
          [Ty2]
argTys   <- (Ty2 -> TiM Ty2)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
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 Ty2 -> TiM Ty2
freshTyLocs ([Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2])
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
forall a b. (a -> b) -> a -> b
$ ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 Ty2
arrty
          [Dest]
argDests <- (Ty2 -> TiM Dest)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Dest]
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 Ty2 -> TiM Dest
destFromType' [Ty2]
argTys
          ([Exp2]
args', [Ty2]
atys, [[Constraint]]
acss) <- [Result] -> ([Exp2], [Ty2], [[Constraint]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
L.unzip3 ([Result] -> ([Exp2], [Ty2], [[Constraint]]))
-> ExceptT Failure (StateT InferState PassM) [Result]
-> ExceptT
     Failure (StateT InferState PassM) ([Exp2], [Ty2], [[Constraint]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Exp1, Dest) -> TiM Result)
-> [(Exp1, Dest)]
-> ExceptT Failure (StateT InferState PassM) [Result]
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 ((Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result)
-> (Exp1 -> Dest -> TiM Result) -> (Exp1, Dest) -> TiM Result
forall a b. (a -> b) -> a -> b
$ FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env) ([Exp1] -> [Dest] -> [(Exp1, Dest)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp1]
args [Dest]
argDests)
          let acs :: [Constraint]
acs = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Constraint]]
acss
          Exp1
tupBod <- Ty2 -> Exp1 -> Exp1 -> TiM Exp1
projTups Ty2
valTy (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vr) Exp1
bod
          Result
res <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
valTy FullEnv
env) Exp1
tupBod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr Result
res
          [Constraint]
vcs <- [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion (Ty2 -> [Var]
locsInTy Ty2
valTy) Ty2
ty'' ([Constraint] -> TiM [Constraint])
-> [Constraint] -> TiM [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
acs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs''
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
vcs
          -- fcs <- tryInRegion $ acs ++ cs''
          Result
res' <- Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[], Ty2
valTy, Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.AppE Var
f ((Ty2 -> [Var]) -> [Ty2] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [Var]
locsInTy [Ty2]
atys [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Ty2 -> [Var]
locsInTy Ty2
valTy) [Exp2]
args') Exp2
bod'', Ty2
ty'', [Constraint]
fcs)
          [Var] -> Result -> TiM Result
bindImmediateDependentLocs ((Ty2 -> [Var]) -> [Ty2] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [Var]
locsInTy [Ty2]
atys [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ Ty2 -> [Var]
locsInTy Ty2
valTy) Result
res'

        AppE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Malformed function application: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
ex0)

        SpawnE Var
f [()]
_ [Exp1]
args -> do
          let _ret_ty :: Ty2
_ret_ty = ArrowTy2 Ty2 -> Ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut (ArrowTy2 Ty2 -> Ty2) -> ArrowTy2 Ty2 -> Ty2
forall a b. (a -> b) -> a -> b
$ Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
f FullEnv
env
          -- if isScalarTy ret_ty || isPackedTy ret_ty
          -- then do
          (Exp2
ex0', Ty2
ty, [Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env ((Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
vr,[()]
locs,Ty1
bty,(Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Exp1]
args)) Exp1
bod) Dest
dest
          -- Assume that all args are VarE's
          let args2 :: [Exp2]
args2 = (Exp1 -> Exp2) -> [Exp1] -> [Exp2]
forall a b. (a -> b) -> [a] -> [b]
map (\Exp1
e -> case Exp1
e of
                                   (VarE Var
v) -> Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                                   (LitSymE Var
v) -> Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE Var
v
                                   (LitE Int
n) -> Int -> Exp2
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
n
                                   (FloatE Double
n) -> Double -> Exp2
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
FloatE Double
n
                                   Exp1
oth -> String -> Exp2
forall a. HasCallStack => String -> a
error (String -> Exp2) -> String -> Exp2
forall a b. (a -> b) -> a -> b
$ String
"inferExp: spawne, arg not simple: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
oth)
                          [Exp1]
args
              ex0'' :: Exp2
ex0'' = Var -> [Exp2] -> Exp2 -> Exp2
forall loc dec.
(Eq loc, Eq dec) =>
Var
-> [PreExp E2Ext loc dec]
-> PreExp E2Ext loc dec
-> PreExp E2Ext loc dec
changeAppToSpawn Var
f [Exp2]
args2 Exp2
ex0'
          -- pure (moveProjsAfterSync vr ex0'', ty, cs)
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2
ex0'', Ty2
ty, [Constraint]
cs)

        Exp1
SyncE -> do
          (Exp2
bod',Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
bod Dest
dest
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
vr,[],[Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [],Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE) Exp2
bod', Ty2
ty, [Constraint]
cs)

        IfE Exp1
a Exp1
b Exp1
c -> do
          (Exp2
boda,Ty2
tya,[Constraint]
csa) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
a Dest
NoDest
           -- just assuming tyb == tyc
          Result
res <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
b Dest
NoDest 
          (Exp2
bodb,Ty2
tyb,[Constraint]
csb) <-   [Var] -> Result -> TiM Result
bindAfterLocs ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
removeDuplicates (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
b)) Result
res
          Result
res' <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
c Dest
NoDest
          (Exp2
bodc,Ty2
tyc,[Constraint]
csc) <-   [Var] -> Result -> TiM Result
bindAfterLocs ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
removeDuplicates (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
c)) Result
res'
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
tyc FullEnv
env) Exp1
bod Dest
dest 
          let cs :: [Constraint]
cs = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
csa [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
csb [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
csc [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs'
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
tyc,Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
L2.IfE Exp2
boda Exp2
bodb Exp2
bodc) Exp2
bod', Ty2
ty', [Constraint]
cs)

        LetE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Expected let spine, encountered nested lets: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp1 -> String
forall a. Out a => a -> String
sdoc Exp1
ex0

        LitE Int
i -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
IntTy FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
IntTy,Int -> Exp2
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
L2.LitE Int
i) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        CharE Char
i -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
CharTy FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
CharTy,Char -> Exp2
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
L2.CharE Char
i) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        FloatE Double
i -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
FloatTy FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
FloatTy,Double -> Exp2
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
L2.FloatE Double
i) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        -- TODO: docs
        PrimAppE (ReadPackedFile Maybe String
fp String
tycon Maybe Var
_ Ty1
ty) [] -> do
          Var
r <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"r"
          Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"mmap_file"
          let rhs' :: Exp2
rhs' = Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Maybe String -> String -> Maybe Var -> Ty2 -> Prim Ty2
forall ty. Maybe String -> String -> Maybe Var -> ty -> Prim ty
ReadPackedFile Maybe String
fp String
tycon (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
r) (String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon Var
loc)) []
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr (String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon Var
loc) FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'
          Result -> TiM Result
tryBindReg ( E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext(E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE (Var -> Region
MMapR Var
r) RegionSize
Undefined Maybe RegionType
forall a. Maybe a
Nothing (Exp2 -> E2Ext Var Ty2) -> Exp2 -> E2Ext Var Ty2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
loc (Region -> PreLocExp Var
forall loc. Region -> PreLocExp loc
StartOfRegionLE (Var -> Region
MMapR Var
r)) (Exp2 -> E2Ext Var Ty2) -> Exp2 -> E2Ext Var Ty2
forall a b. (a -> b) -> a -> b
$
                        (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon Var
loc,Exp2
rhs') Exp2
bod''
                     , Ty2
ty', [Constraint]
fcs)


        PrimAppE (WritePackedFile String
fp Ty1
_ty0) [VarE Var
packd] -> do
          Ty2
bty' <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
bty' FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          let (PackedTy String
tycon Var
loc) = Var -> FullEnv -> Ty2
lookupVEnv Var
packd FullEnv
env
          UnifyLoc
unifyloc2 <- Var -> TiM UnifyLoc
lookupUnifyLoc Var
loc
          let loc2 :: Var
loc2 = case UnifyLoc
unifyloc2 of
                       FreshLoc Var
lc -> Var
lc
                       FixedLoc Var
lc -> Var
lc
          let rhs' :: Exp2
rhs' = Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (String -> Ty2 -> Prim Ty2
forall ty. String -> ty -> Prim ty
WritePackedFile String
fp (String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon Var
loc2)) [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
packd]
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
bty',Exp2
rhs') Exp2
bod'', Ty2
ty'', [Constraint]
fcs)


        PrimAppE (ReadArrayFile Maybe (String, Int)
fp Ty1
ty0) [] -> do
          Ty2
ty <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          Ty2
ty0' <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
ty0
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty, Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.PrimAppE (Maybe (String, Int) -> Ty2 -> Prim Ty2
forall ty. Maybe (String, Int) -> ty -> Prim ty
ReadArrayFile Maybe (String, Int)
fp Ty2
ty0') []) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        -- Don't process the StartOf or SizeOf operation at all, just recur through it
        PrimAppE Prim Ty1
RequestSizeOf [(VarE Var
v)] -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
CursorTy FullEnv
env) Exp1
bod Dest
dest
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
IntTy, Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.PrimAppE Prim Ty2
forall ty. Prim ty
RequestSizeOf [(Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L2.VarE Var
v)]) Exp2
bod', Ty2
ty', [Constraint]
cs')

        PrimAppE (DictInsertP Ty1
dty) [Exp1]
ls -> do
          (Exp2
e,Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty1 -> Prim Ty1
forall ty. ty -> Prim ty
DictInsertP Ty1
dty) [Exp1]
ls) Dest
NoDest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod',Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Exp2
e) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        PrimAppE (DictLookupP Ty1
dty) [Exp1]
ls -> do
          Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"dict"
          (Exp2
e,Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty1 -> Prim Ty1
forall ty. ty -> Prim ty
DictLookupP Ty1
dty) [Exp1]
ls) (Dest -> TiM Result) -> Dest -> TiM Result
forall a b. (a -> b) -> a -> b
$ Var -> Dest
SingleDest Var
loc
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Exp2
e) Exp2
bod'',Ty2
ty'', [Constraint]
fcs)

        PrimAppE (DictEmptyP Ty1
dty) [Exp1]
ls -> do
          (Exp2
e,Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty1 -> Prim Ty1
forall ty. ty -> Prim ty
DictEmptyP Ty1
dty) [Exp1]
ls) Dest
NoDest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod',Ty2
ty',[Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Exp2
e) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        PrimAppE (DictHasKeyP Ty1
dty) [Exp1]
ls -> do
          (Exp2
e,Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty1 -> Prim Ty1
forall ty. ty -> Prim ty
DictHasKeyP Ty1
dty) [Exp1]
ls) Dest
NoDest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod',Ty2
ty',[Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Exp2
e) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        -- Special case for VSortP because we don't want to lookup fp in
        -- the type environment.
        PrimAppE p :: Prim Ty1
p@(VSortP Ty1
ty) [VarE Var
ls, VarE Var
fp] -> do
          [Result]
lsrec <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
ls]
          Ty2
ty <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          let ls' :: [Exp2]
ls' = [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
lsrec] [Exp2] -> [Exp2] -> [Exp2]
forall a. [a] -> [a] -> [a]
++ [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
fp]
              cs'' :: [Constraint]
cs'' = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
lsrec]
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs'')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Prim Ty2
p' <- StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (Prim Ty2)
 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2))
-> PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> PassM (Prim Ty2)
prim Prim Ty1
p
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty, Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.PrimAppE Prim Ty2
p' [Exp2]
ls') Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        PrimAppE Prim Ty1
p [Exp1]
ls -> do
          [Result]
lsrec <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Exp1]
ls
          Ty2
ty <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          let ls' :: [Exp2]
ls' = [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
lsrec]
              cs'' :: [Constraint]
cs'' = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
lsrec]
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs'')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Prim Ty2
p' <- StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM (Prim Ty2)
 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> StateT InferState PassM (Prim Ty2)
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2))
-> PassM (Prim Ty2) -> StateT InferState PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> PassM (Prim Ty2)
prim Prim Ty1
p
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty, Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
L2.PrimAppE Prim Ty2
p' [Exp2]
ls') Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        DataConE ()
_loc String
k [Exp1]
ls  -> do
          Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"datacon"
          (Exp2
rhs',Ty2
rty,[Constraint]
rcs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env (() -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () String
k [Exp1]
ls) (Dest -> TiM Result) -> Dest -> TiM Result
forall a b. (a -> b) -> a -> b
$ Var -> Dest
SingleDest Var
loc
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr (String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy (DDefs Ty2 -> ShowS
forall a. Out a => DDefs a -> ShowS
getTyOfDataCon DDefs Ty2
dataDefs String
k) Var
loc) FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
rcs)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy (DDefs Ty2 -> ShowS
forall a. Out a => DDefs a -> ShowS
getTyOfDataCon DDefs Ty2
dataDefs String
k) Var
loc,Exp2
rhs') Exp2
bod'',
                    Ty2
ty', [Constraint]
fcs)

        LitSymE Var
x       -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
IntTy FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
SymTy,Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
L2.LitSymE Var
x) Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        ProjE Int
i Exp1
arg     -> do
          (Exp2
e,ProdTy [Ty2]
tys,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
arg Dest
NoDest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr ([Ty2]
tys [Ty2] -> Int -> Ty2
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],[Ty2]
tys [Ty2] -> Int -> Ty2
forall a. HasCallStack => [a] -> Int -> a
!! Int
i,Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
L2.ProjE Int
i Exp2
e) Exp2
bod'',
                             Ty2
ty'', [Constraint]
fcs)

        CaseE Exp1
ex [(String, [(Var, ())], Exp1)]
ls    -> do
          Var
loc <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"scrut"
          (Exp2
ex',Ty2
ty2,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
ex (Var -> Dest
SingleDest Var
loc)
          let src :: Var
src = Ty2 -> Var
locOfTy Ty2
ty2
          Ty2
rhsTy <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          Dest
caseDest <- Ty2 -> TiM Dest
destFromType' Ty2
rhsTy
          [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs <- ((String, [(Var, ())], Exp1)
 -> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint]))
-> [(String, [(Var, ())], Exp1)]
-> ExceptT
     Failure
     (StateT InferState PassM)
     [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
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 (DDefs Ty2
-> FullEnv
-> Var
-> Dest
-> (String, [(Var, ())], Exp1)
-> TiM ((String, [(Var, Var)], Exp2), Ty2, [Constraint])
doCase DDefs Ty2
dataDefs FullEnv
env Var
src Dest
caseDest) [(String, [(Var, ())], Exp1)]
ls
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
rhsTy FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint]
cs')
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs''
          let ccs :: [Constraint]
ccs  = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
fcs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ ([[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | ((String, [(Var, Var)], Exp2)
_,Ty2
_,[Constraint]
c) <- [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs])
              cexp :: Exp2
cexp = Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
L2.CaseE Exp2
ex' ([(String, [(Var, Var)], Exp2)
a | ((String, [(Var, Var)], Exp2)
a,Ty2
_,[Constraint]
_) <- [((String, [(Var, Var)], Exp2), Ty2, [Constraint])]
pairs])
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,Ty2 -> [Var]
locsInTy Ty2
rhsTy,Ty2
rhsTy, Exp2
cexp) Exp2
bod'',
                      Ty2
ty'', [Constraint]
ccs)

        MkProdE [Exp1]
ls    -> do
          -- ckoparkar: Shouldn't this check the types of things in ls
          -- before recurring with a NoDest ? Some things in this list may
          -- need fresh destinations. I think it's set up this way because
          -- there's an assumption that things in a MkProdE will always be a
          -- variable reference (because of ANF), and the AppE/DataConE cases
          -- above will do the right thing.
          [Result]
lsrec <- (Exp1 -> TiM Result)
-> [Exp1] -> ExceptT Failure (StateT InferState PassM) [Result]
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 (\Exp1
e -> FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
NoDest) [Exp1]
ls
          ty :: Ty2
ty@(ProdTy [Ty2]
tys) <- StateT InferState PassM Ty2 -> TiM Ty2
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Ty2 -> TiM Ty2)
-> StateT InferState PassM Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ PassM Ty2 -> StateT InferState PassM Ty2
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Ty2 -> StateT InferState PassM Ty2)
-> PassM Ty2 -> StateT InferState PassM Ty2
forall a b. (a -> b) -> a -> b
$ Ty1 -> PassM Ty2
convertTy Ty1
bty
          let env' :: FullEnv
env' = Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env' Exp1
bod Dest
dest
          let als :: [Exp2]
als = [Exp2
a | (Exp2
a,Ty2
_,[Constraint]
_) <- [Result]
lsrec]
              acs :: [Constraint]
acs = [[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Constraint]] -> [Constraint]) -> [[Constraint]] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [[Constraint]
c | (Exp2
_,Ty2
_,[Constraint]
c) <- [Result]
lsrec]
              aty :: [Ty2]
aty = [Ty2
b | (Exp2
_,Ty2
b,[Constraint]
_) <- [Result]
lsrec]
           -- unify projection locations with variable type locations: this kind of does what copyTuple should be doing
          [Dest]
adests <- (Ty2 -> TiM Dest)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Dest]
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 Ty2 -> TiM Dest
destFromType' [Ty2]
tys
          let e' :: Exp2
e' = (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[], Ty2
ty, [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
L2.MkProdE [Exp2]
als) Exp2
bod'
          let go :: (Exp2, [Ty2])
-> (Exp2, Ty2, Dest)
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
go (Exp2
e'', [Ty2]
tys) r :: (Exp2, Ty2, Dest)
r@(Exp2
l, Ty2
t, Dest
dt)
                = case Ty2
t of
                      PackedTy String
_ Var
loc -> case Dest
dt of
                        SingleDest Var
lv -> do
                          Var
v <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"copyProj"
                          (Exp2
l', Ty2
t', []) <- Result -> Var -> TiM Result
copy (Exp2
l, Ty2
t, []) Var
lv
                          (Exp2, [Ty2])
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
v,[],Ty2
t',Exp2
l') Exp2
e'', Ty2
tTy2 -> [Ty2] -> [Ty2]
forall a. a -> [a] -> [a]
:[Ty2]
tys)
                        TupleDest [Dest]
ds -> do
                          String -> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a. HasCallStack => String -> a
error (String -> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2]))
-> String
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a b. (a -> b) -> a -> b
$ String
"tupledest: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Exp2, Ty2, Dest) -> String
forall a. Show a => a -> String
show (Exp2, Ty2, Dest)
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e''
                        Dest
NoDest -> (Exp2, [Ty2])
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2
e'', [Ty2]
tys)
                      Ty2
_ -> (Exp2, [Ty2])
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2
e'', [Ty2]
tys)
          (L2.LetE bind :: (Var, [Var], Ty2, Exp2)
bind@(Var
vr',[Var]
_,Ty2
_,Exp2
_) Exp2
bod1, [Ty2]
ty1) <- ((Exp2, [Ty2])
 -> (Exp2, Ty2, Dest)
 -> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2]))
-> (Exp2, [Ty2])
-> [(Exp2, Ty2, Dest)]
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Exp2, [Ty2])
-> (Exp2, Ty2, Dest)
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
go (Exp2
e', [Ty2]
aty) ([(Exp2, Ty2, Dest)]
 -> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2]))
-> [(Exp2, Ty2, Dest)]
-> ExceptT Failure (StateT InferState PassM) (Exp2, [Ty2])
forall a b. (a -> b) -> a -> b
$ [Exp2] -> [Ty2] -> [Dest] -> [(Exp2, Ty2, Dest)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Exp2]
als [Ty2]
aty [Dest]
adests
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs''') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr' (Exp2
bod1, [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [Ty2]
ty1, [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs' [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
acs)
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
cs'''
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var, [Var], Ty2, Exp2)
bind Exp2
bod'', Ty2
ty'', [Constraint]
fcs)

        WithArenaE Var
v Exp1
e -> do
          (Exp2
e',Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
v Ty2
forall loc. UrTy loc
ArenaTy FullEnv
env) Exp1
e Dest
NoDest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs')
          [Constraint]
vcs <- [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion (Ty2 -> [Var]
locsInTy Ty2
ty) Ty2
ty'' [Constraint]
cs''
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
vcs
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp2
e') Exp2
bod'',
                        Ty2
ty'', [Constraint]
fcs)

        TimeIt Exp1
e Ty1
t Bool
b       -> do
          Var
lv <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"timeit"
          let subdest :: Dest
subdest = case Ty1
bty of
                          PackedTy String
_ ()
_ -> Var -> Dest
SingleDest Var
lv
                          Ty1
_ -> Dest
NoDest
          (Exp2
e',Ty2
ty,[Constraint]
cs) <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e Dest
subdest
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
ty FullEnv
env) Exp1
bod Dest
dest
          (Exp2
bod'',Ty2
ty'',[Constraint]
cs'') <- Var -> Result -> TiM Result
handleTrailingBindLoc Var
vr (Exp2
bod', Ty2
ty', [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cs [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cs')
          [Constraint]
vcs <- [Var] -> Ty2 -> [Constraint] -> TiM [Constraint]
tryNeedRegion (Ty2 -> [Var]
locsInTy Ty2
ty) Ty2
ty'' [Constraint]
cs''
          [Constraint]
fcs <- [Constraint] -> TiM [Constraint]
tryInRegion [Constraint]
vcs
          Result -> TiM Result
tryBindReg ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
ty,Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp2
e' Ty2
ty Bool
b) Exp2
bod'',
                    Ty2
ty'', [Constraint]
fcs)

        MapE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"MapE unsupported"
        FoldE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"FoldE unsupported"

        Ext (L1.AddFixed Var
cur Int
i) -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
CursorTy FullEnv
env) Exp1
bod Dest
dest
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
L2.CursorTy,E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
L2.Ext (Var -> Int -> E2Ext Var Ty2
forall loc dec. Var -> Int -> E2Ext loc dec
L2.AddFixed Var
cur Int
i)) Exp2
bod', Ty2
ty', [Constraint]
cs')

        Ext (L1.StartOfPkdCursor Var
cur) -> do
          (Exp2
bod',Ty2
ty',[Constraint]
cs') <- FullEnv -> Exp1 -> Dest -> TiM Result
inferExp (Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
vr Ty2
forall loc. UrTy loc
CursorTy FullEnv
env) Exp1
bod Dest
dest
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L2.LetE (Var
vr,[],Ty2
forall loc. UrTy loc
L2.CursorTy,E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
L2.Ext (Var -> E2Ext Var Ty2
forall loc dec. Var -> E2Ext loc dec
L2.StartOfPkdCursor Var
cur)) Exp2
bod', Ty2
ty', [Constraint]
cs')

        Ext(BenchE{}) -> String -> TiM Result
forall a. HasCallStack => String -> a
error String
"inferExp: BenchE not handled."

    LetE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Malformed let expression: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
ex0)
    MapE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"MapE unsupported"
    FoldE{} -> String -> TiM Result
forall a. HasCallStack => String -> a
err(String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"FoldE unsupported"
    -- Just-in-time convert this to TimeIt
    Ext (BenchE Var
fn [()]
locs [Exp1]
args Bool
b) ->
      let fn_ty :: ArrowTy2 Ty2
fn_ty = Var -> FullEnv -> ArrowTy2 Ty2
lookupFEnv Var
fn FullEnv
env
          retty :: Ty2
          retty :: Ty2
retty = ArrowTy Ty2 -> Ty2
forall ty. FunctionTy ty => ArrowTy ty -> ty
outTy ArrowTy Ty2
ArrowTy2 Ty2
fn_ty
          e' :: Exp1
e' = Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fn [()]
locs [Exp1]
args) (Ty2 -> Ty1
forall a. UrTy a -> Ty1
stripTyLocs Ty2
retty) Bool
b
      in FullEnv -> Exp1 -> Dest -> TiM Result
inferExp FullEnv
env Exp1
e' Dest
dest


-- TODO: Should eventually allow src and dest regions to be the same
-- for in-place updates packed data with linear types.

-- | Transforms an expression by updating all locations to their final mapping
-- as a result of unification.
finishExp :: Exp2 -> TiM (Exp2)
finishExp :: Exp2 -> TiM Exp2
finishExp Exp2
e = 
    case Exp2
e of
      VarE Var
v -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
      LitE Int
i -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Int -> Exp2
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
i
      CharE Char
i -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Char -> Exp2
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
CharE Char
i
      FloatE Double
i  -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Double -> Exp2
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
FloatE Double
i
      LitSymE Var
v -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE Var
v
      AppE Var
v [Var]
ls [Exp2]
es -> do
             [Exp2]
es' <- (Exp2 -> TiM Exp2)
-> [Exp2] -> ExceptT Failure (StateT InferState PassM) [Exp2]
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 Exp2 -> TiM Exp2
finishExp [Exp2]
es
             [Var]
ls' <- (Var -> TiM Var)
-> [Var] -> ExceptT Failure (StateT InferState PassM) [Var]
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 Var -> TiM Var
finalLocVar [Var]
ls
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [Var]
ls' [Exp2]
es'
      PrimAppE Prim Ty2
pr [Exp2]
es -> do
             [Exp2]
es' <- (Exp2 -> TiM Exp2)
-> [Exp2] -> ExceptT Failure (StateT InferState PassM) [Exp2]
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 Exp2 -> TiM Exp2
finishExp [Exp2]
es
             Prim Ty2
pr' <- Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
finishPr Prim Ty2
pr
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty2
pr' [Exp2]
es'
      LetE (Var
v,[Var]
ls,Ty2
t,Exp2
e1) Exp2
e2 -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Exp2
e2' <- Exp2 -> TiM Exp2
finishExp Exp2
e2
             [Var]
ls' <- (Var -> TiM Var)
-> [Var] -> ExceptT Failure (StateT InferState PassM) [Var]
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 Var -> TiM Var
finalLocVar [Var]
ls
             Ty2
t' <- Ty2 -> TiM Ty2
finishTy Ty2
t
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
ls',Ty2
t',Exp2
e1') Exp2
e2'
      IfE Exp2
e1 Exp2
e2 Exp2
e3 -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Exp2
e2' <- Exp2 -> TiM Exp2
finishExp Exp2
e2
             Exp2
e3' <- Exp2 -> TiM Exp2
finishExp Exp2
e3
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp2
e1' Exp2
e2' Exp2
e3'
      MkProdE [Exp2]
es -> do
             [Exp2]
es' <- (Exp2 -> TiM Exp2)
-> [Exp2] -> ExceptT Failure (StateT InferState PassM) [Exp2]
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 Exp2 -> TiM Exp2
finishExp [Exp2]
es
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp2]
es'
      ProjE Int
i Exp2
e1 -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp2
e1'
      CaseE Exp2
e1 [(String, [(Var, Var)], Exp2)]
prs -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             [(String, [(Var, Var)], Exp2)]
prs' <- [(String, [(Var, Var)], Exp2)]
-> ((String, [(Var, Var)], Exp2)
    -> ExceptT
         Failure (StateT InferState PassM) (String, [(Var, Var)], Exp2))
-> ExceptT
     Failure (StateT InferState PassM) [(String, [(Var, Var)], Exp2)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, [(Var, Var)], Exp2)]
prs (((String, [(Var, Var)], Exp2)
  -> ExceptT
       Failure (StateT InferState PassM) (String, [(Var, Var)], Exp2))
 -> ExceptT
      Failure (StateT InferState PassM) [(String, [(Var, Var)], Exp2)])
-> ((String, [(Var, Var)], Exp2)
    -> ExceptT
         Failure (StateT InferState PassM) (String, [(Var, Var)], Exp2))
-> ExceptT
     Failure (StateT InferState PassM) [(String, [(Var, Var)], Exp2)]
forall a b. (a -> b) -> a -> b
$ \(String
dc, [(Var, Var)]
lvs, Exp2
e2) -> do
                         Exp2
e2' <- Exp2 -> TiM Exp2
finishExp Exp2
e2
                         [(Var, Var)]
lvs' <- [(Var, Var)]
-> ((Var, Var)
    -> ExceptT Failure (StateT InferState PassM) (Var, Var))
-> ExceptT Failure (StateT InferState PassM) [(Var, Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Var, Var)]
lvs (((Var, Var)
  -> ExceptT Failure (StateT InferState PassM) (Var, Var))
 -> ExceptT Failure (StateT InferState PassM) [(Var, Var)])
-> ((Var, Var)
    -> ExceptT Failure (StateT InferState PassM) (Var, Var))
-> ExceptT Failure (StateT InferState PassM) [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ \(Var
v,Var
lv) -> do
                                                    Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                                                    (Var, Var) -> ExceptT Failure (StateT InferState PassM) (Var, Var)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
v,Var
lv')
                         (String, [(Var, Var)], Exp2)
-> ExceptT
     Failure (StateT InferState PassM) (String, [(Var, Var)], Exp2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dc,[(Var, Var)]
lvs',Exp2
e2')
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp2
e1' [(String, [(Var, Var)], Exp2)]
prs'
      DataConE Var
lv String
dc [Exp2]
es -> do
             [Exp2]
es' <- (Exp2 -> TiM Exp2)
-> [Exp2] -> ExceptT Failure (StateT InferState PassM) [Exp2]
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 Exp2 -> TiM Exp2
finishExp [Exp2]
es
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
lv' String
dc [Exp2]
es'
      TimeIt Exp2
e1 Ty2
t Bool
b -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Ty2
t' <- case Ty2
t of
                     PackedTy String
tc Var
lv ->
                         do Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                            Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ty2 -> TiM Ty2) -> Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tc Var
lv'
                     Ty2
_ -> Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Ty2
t
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp2
e1' Ty2
t' Bool
b

      SpawnE Var
v [Var]
ls [Exp2]
es -> do
        [Exp2]
es' <- (Exp2 -> TiM Exp2)
-> [Exp2] -> ExceptT Failure (StateT InferState PassM) [Exp2]
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 Exp2 -> TiM Exp2
finishExp [Exp2]
es
        [Var]
ls' <- (Var -> TiM Var)
-> [Var] -> ExceptT Failure (StateT InferState PassM) [Var]
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 Var -> TiM Var
finalLocVar [Var]
ls
        Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [Var]
ls' [Exp2]
es'

      Exp2
SyncE -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE

      WithArenaE Var
v Exp2
e -> do
             Exp2
e' <- Exp2 -> TiM Exp2
finishExp Exp2
e
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp2
e'

      Ext (LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e1) -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e1')
      Ext (LetLocE Var
loc PreLocExp Var
lex Exp2
e1) -> do
             Exp2
e1' <- Exp2 -> TiM Exp2
finishExp Exp2
e1
             Var
loc' <- Var -> TiM Var
finalLocVar Var
loc
             PreLocExp Var
lex' <- case PreLocExp Var
lex of
                       AfterConstantLE Int
i Var
lv -> do
                                    Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                                    PreLocExp Var
-> ExceptT Failure (StateT InferState PassM) (PreLocExp Var)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PreLocExp Var
 -> ExceptT Failure (StateT InferState PassM) (PreLocExp Var))
-> PreLocExp Var
-> ExceptT Failure (StateT InferState PassM) (PreLocExp Var)
forall a b. (a -> b) -> a -> b
$ Int -> Var -> PreLocExp Var
forall loc. Int -> loc -> PreLocExp loc
AfterConstantLE Int
i Var
lv'
                       AfterVariableLE Var
v Var
lv Bool
b -> do
                                    Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
                                    PreLocExp Var
-> ExceptT Failure (StateT InferState PassM) (PreLocExp Var)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PreLocExp Var
 -> ExceptT Failure (StateT InferState PassM) (PreLocExp Var))
-> PreLocExp Var
-> ExceptT Failure (StateT InferState PassM) (PreLocExp Var)
forall a b. (a -> b) -> a -> b
$ Var -> Var -> Bool -> PreLocExp Var
forall loc. Var -> loc -> Bool -> PreLocExp loc
AfterVariableLE Var
v Var
lv' Bool
b
                       PreLocExp Var
oth -> PreLocExp Var
-> ExceptT Failure (StateT InferState PassM) (PreLocExp Var)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return PreLocExp Var
oth
             Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
loc' PreLocExp Var
lex' Exp2
e1')
      Ext (L2.AddFixed Var
cur Int
i) -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Int -> E2Ext Var Ty2
forall loc dec. Var -> Int -> E2Ext loc dec
L2.AddFixed Var
cur Int
i)
      Ext (L2.StartOfPkdCursor Var
cur) -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> E2Ext Var Ty2
forall loc dec. Var -> E2Ext loc dec
L2.StartOfPkdCursor Var
cur)
      Ext (L2.TagCursor Var
a Var
b) -> Exp2 -> TiM Exp2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp2 -> TiM Exp2) -> Exp2 -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Var -> E2Ext Var Ty2
forall loc dec. Var -> Var -> E2Ext loc dec
L2.TagCursor Var
a Var
b)
      Ext (LetParRegionE{})       -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (RetE{})                -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (FromEndE{})            -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (BoundsCheck{})         -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (IndirectionE{})        -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (GetCilkWorkerNum{})    -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (LetAvail{})            -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (AllocateTagHere{})     -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (AllocateScalarsHere{}) -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (SSPush{})              -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (SSPop{})               -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err (String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      MapE{}  -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err(String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"MapE not supported"
      FoldE{} -> String -> TiM Exp2
forall a. HasCallStack => String -> a
err(String -> TiM Exp2) -> String -> TiM Exp2
forall a b. (a -> b) -> a -> b
$ String
"FoldE not supported"

finishTy :: Ty2 -> TiM Ty2
finishTy :: Ty2 -> TiM Ty2
finishTy Ty2
t =
    case Ty2
t of
      PackedTy String
tc Var
lv ->
          do Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ty2 -> TiM Ty2) -> Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tc Var
lv'
      ProdTy [Ty2]
pls ->
           do [Ty2]
pls' <- (Ty2 -> TiM Ty2)
-> [Ty2] -> ExceptT Failure (StateT InferState PassM) [Ty2]
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 Ty2 -> TiM Ty2
finishTy [Ty2]
pls
              Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ty2 -> TiM Ty2) -> Ty2 -> TiM Ty2
forall a b. (a -> b) -> a -> b
$ [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [Ty2]
pls'
      Ty2
_ -> Ty2 -> TiM Ty2
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Ty2
t

finishPr :: Prim Ty2 -> TiM (Prim Ty2)
finishPr :: Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
finishPr Prim Ty2
pr =
    case Prim Ty2
pr of
      DictInsertP Ty2
bty -> Ty2 -> TiM Ty2
finishTy Ty2
bty TiM Ty2
-> (Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> (Ty2 -> Prim Ty2)
-> Ty2
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictInsertP
      DictLookupP Ty2
bty -> Ty2 -> TiM Ty2
finishTy Ty2
bty TiM Ty2
-> (Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> (Ty2 -> Prim Ty2)
-> Ty2
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictLookupP
      DictEmptyP Ty2
bty  -> Ty2 -> TiM Ty2
finishTy Ty2
bty TiM Ty2
-> (Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> (Ty2 -> Prim Ty2)
-> Ty2
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictEmptyP
      DictHasKeyP Ty2
bty -> Ty2 -> TiM Ty2
finishTy Ty2
bty TiM Ty2
-> (Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a b.
ExceptT Failure (StateT InferState PassM) a
-> (a -> ExceptT Failure (StateT InferState PassM) b)
-> ExceptT Failure (StateT InferState PassM) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2))
-> (Ty2 -> Prim Ty2)
-> Ty2
-> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictHasKeyP
      Prim Ty2
_ -> Prim Ty2 -> ExceptT Failure (StateT InferState PassM) (Prim Ty2)
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
pr

-- | Remove unused location bindings
-- Returns pair of (new exp, set of free locations)
-- TODO: avoid generating location bindings for immediate values
cleanExp :: Exp2 -> (Exp2, S.Set LocVar)
cleanExp :: Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e =
    case Exp2
e of
      VarE Var
v -> (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v, Set Var
forall a. Set a
S.empty)
      LitE Int
v -> (Int -> Exp2
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
v, Set Var
forall a. Set a
S.empty)
      CharE Char
v -> (Char -> Exp2
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
CharE Char
v, Set Var
forall a. Set a
S.empty)
      FloatE Double
v -> (Double -> Exp2
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
FloatE Double
v, Set Var
forall a. Set a
S.empty)
      LitSymE Var
v -> (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE Var
v, Set Var
forall a. Set a
S.empty)
      AppE Var
v [Var]
ls [Exp2]
e -> let ([Exp2]
e',[Set Var]
s') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
e
                     in (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [Var]
ls [Exp2]
e', ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
s') Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls))
      PrimAppE (DictInsertP Ty2
ty) [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                        in (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictInsertP Ty2
ty) [Exp2]
es',
                             Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls') ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList ([Var] -> Set Var) -> [Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ Ty2 -> [Var]
locsInTy Ty2
ty))
      PrimAppE (DictLookupP Ty2
ty) [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                        in (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictLookupP Ty2
ty) [Exp2]
es',
                             Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls') ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList ([Var] -> Set Var) -> [Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ Ty2 -> [Var]
locsInTy Ty2
ty))
      PrimAppE (DictEmptyP Ty2
ty) [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                        in (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictEmptyP Ty2
ty) [Exp2]
es',
                             Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls') ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList ([Var] -> Set Var) -> [Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ Ty2 -> [Var]
locsInTy Ty2
ty))
      PrimAppE (DictHasKeyP Ty2
ty) [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                        in (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictHasKeyP Ty2
ty) [Exp2]
es',
                             Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls') ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList ([Var] -> Set Var) -> [Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ Ty2 -> [Var]
locsInTy Ty2
ty))
      PrimAppE Prim Ty2
pr [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                        in (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty2
pr [Exp2]
es', [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls')
      -- StartOfPkdCursor and AddFixed actually bind locations outside LetLoc forms,
      -- these should be removed from the set of free locations.
      LetE (Var
v,[Var]
ls,Ty2
t,e1 :: Exp2
e1@(Ext (L2.StartOfPkdCursor Var
_cur))) Exp2
e2 ->
                        let (Exp2
e1', Set Var
s1') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e1
                            (Exp2
e2', Set Var
s2') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e2
                        in ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
ls,Ty2
t,Exp2
e1') Exp2
e2', Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var
s1',Set Var
s2',[Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls]))
      LetE (Var
v,[Var]
ls,Ty2
t,e1 :: Exp2
e1@(Ext (L2.AddFixed Var
_cur Int
_i))) Exp2
e2 ->
                        let (Exp2
e2', Set Var
s2') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e2
                        in ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
ls,Ty2
t,Exp2
e1) Exp2
e2', Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var
s2',[Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls]))
      LetE (Var
v,[Var]
ls,Ty2
t,Exp2
e1) Exp2
e2 -> let (Exp2
e1', Set Var
s1') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e1
                                 (Exp2
e2', Set Var
s2') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e2
                             in ((Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
ls,Ty2
t,Exp2
e1') Exp2
e2', [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var
s1',Set Var
s2',[Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls])
      IfE Exp2
e1 Exp2
e2 Exp2
e3 -> let (Exp2
e1',Set Var
s1') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e1
                          (Exp2
e2',Set Var
s2') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e2
                          (Exp2
e3',Set Var
s3') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e3
                      in (Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp2
e1' Exp2
e2' Exp2
e3', [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var
s1',Set Var
s2',Set Var
s3'])
      MkProdE [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                    in ([Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp2]
es', [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls')
      ProjE Int
i Exp2
e -> let (Exp2
e',Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                   in (Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp2
e', Set Var
s')
      CaseE Exp2
e1 [(String, [(Var, Var)], Exp2)]
prs -> let (Exp2
e1',Set Var
s1') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e1
                          ([(String, [(Var, Var)], Exp2)]
prs', [Set Var]
ls2') = [((String, [(Var, Var)], Exp2), Set Var)]
-> ([(String, [(Var, Var)], Exp2)], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((String, [(Var, Var)], Exp2), Set Var)]
 -> ([(String, [(Var, Var)], Exp2)], [Set Var]))
-> [((String, [(Var, Var)], Exp2), Set Var)]
-> ([(String, [(Var, Var)], Exp2)], [Set Var])
forall a b. (a -> b) -> a -> b
$ ((String, [(Var, Var)], Exp2)
 -> ((String, [(Var, Var)], Exp2), Set Var))
-> [(String, [(Var, Var)], Exp2)]
-> [((String, [(Var, Var)], Exp2), Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map
                                         (\(String
dc,[(Var, Var)]
lvs,Exp2
e2) -> let (Exp2
e2', Set Var
s2) = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e2
                                                          in ((String
dc,[(Var, Var)]
lvs,Exp2
e2'), Set Var
s2 Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList (((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Var) -> Var
forall a b. (a, b) -> b
snd [(Var, Var)]
lvs))) [(String, [(Var, Var)], Exp2)]
prs
                      in (Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp2
e1' [(String, [(Var, Var)], Exp2)]
prs', Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union Set Var
s1' (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls2')
      DataConE Var
lv String
dc [Exp2]
es -> let ([Exp2]
es',[Set Var]
ls') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
es
                           in (Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
lv String
dc [Exp2]
es', Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union (Var -> Set Var
forall a. a -> Set a
S.singleton Var
lv) (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
ls')
      TimeIt Exp2
e Ty2
d Bool
b -> let (Exp2
e',Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                      in (Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp2
e' Ty2
d Bool
b, Set Var
s')

      SpawnE Var
v [Var]
ls [Exp2]
e -> let ([Exp2]
e',[Set Var]
s') = [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp2, Set Var)] -> ([Exp2], [Set Var]))
-> [(Exp2, Set Var)] -> ([Exp2], [Set Var])
forall a b. (a -> b) -> a -> b
$ (Exp2 -> (Exp2, Set Var)) -> [Exp2] -> [(Exp2, Set Var)]
forall a b. (a -> b) -> [a] -> [b]
map Exp2 -> (Exp2, Set Var)
cleanExp [Exp2]
e
                       in (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [Var]
ls [Exp2]
e', ([Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Var]
s') Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls))

      Exp2
SyncE -> (Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE, Set Var
forall a. Set a
S.empty)

      WithArenaE Var
v Exp2
e -> let (Exp2
e',Set Var
s) = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                        in (Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp2
e', Set Var
s)

      Ext (LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e) -> let (Exp2
e',Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                              in (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e'), Set Var
s')
      Ext (LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e) -> let (Exp2
e',Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                                 in (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
e'), Set Var
s')
      Ext (LetLocE Var
loc PreLocExp Var
FreeLE Exp2
e) -> let (Exp2
e', Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                                    in if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
loc Set Var
s'
                                       then (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
loc PreLocExp Var
forall loc. PreLocExp loc
FreeLE Exp2
e'), Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
loc Set Var
s')
                                       else (Exp2
e',Set Var
s')
      Ext (LetLocE Var
loc PreLocExp Var
lex Exp2
e) -> let (Exp2
e',Set Var
s') = Exp2 -> (Exp2, Set Var)
cleanExp Exp2
e
                                 in if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
loc Set Var
s'
                                    then let ls :: [Var]
ls = case PreLocExp Var
lex of
                                                    AfterConstantLE Int
_i Var
lv   -> [Var
lv]
                                                    AfterVariableLE Var
_v Var
lv Bool
_ -> [Var
lv]
                                                    PreLocExp Var
oth -> []
                                         in (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
loc PreLocExp Var
lex Exp2
e'),
                                              Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
loc (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.union Set Var
s' (Set Var -> Set Var) -> Set Var -> Set Var
forall a b. (a -> b) -> a -> b
$ [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
ls)
                                    else (Exp2
e',Set Var
s')
      Ext (L2.AddFixed Var
cur Int
i) -> (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Int -> E2Ext Var Ty2
forall loc dec. Var -> Int -> E2Ext loc dec
L2.AddFixed Var
cur Int
i), Set Var
forall a. Set a
S.empty)
      Ext (L2.StartOfPkdCursor Var
cur) -> (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> E2Ext Var Ty2
forall loc dec. Var -> E2Ext loc dec
L2.StartOfPkdCursor Var
cur), Set Var
forall a. Set a
S.empty)
      Ext (L2.TagCursor Var
a Var
b) -> (E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Var -> E2Ext Var Ty2
forall loc dec. Var -> Var -> E2Ext loc dec
L2.TagCursor Var
a Var
b), Set Var
forall a. Set a
S.empty)
      Ext (RetE{})                -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (FromEndE{})            -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (BoundsCheck{})         -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (IndirectionE{})        -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (GetCilkWorkerNum{})    -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (LetAvail{})            -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (AllocateTagHere{})     -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (AllocateScalarsHere{}) -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (SSPush{})              -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      Ext (SSPop{})               -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err (String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
e
      MapE{} -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err(String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"MapE not supported"
      FoldE{} -> String -> (Exp2, Set Var)
forall a. HasCallStack => String -> a
err(String -> (Exp2, Set Var)) -> String -> (Exp2, Set Var)
forall a b. (a -> b) -> a -> b
$ String
"FoldE not supported"

projTups :: Ty2 -> Exp1 -> Exp1 -> TiM Exp1
projTups :: Ty2 -> Exp1 -> Exp1 -> TiM Exp1
projTups Ty2
t Exp1
proj Exp1
e =
    case Ty2
t of
      ProdTy [Ty2]
ts -> (Exp1 -> (Ty2, Int) -> TiM Exp1)
-> Exp1 -> [(Ty2, Int)] -> TiM Exp1
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp1
e (Ty2
t,Int
i) ->
                   case Ty2
t of
                     ProdTy [Ty2]
ts ->
                          do Var
v <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"proj")
                             Exp1
e' <- Ty2 -> Exp1 -> Exp1 -> TiM Exp1
projTups Ty2
t (Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
proj) Exp1
e
                             let ty :: Ty1
ty = Ty2 -> Ty1
forall a. UrTy a -> Ty1
stripTyLocs (Ty2 -> Ty1) -> Ty2 -> Ty1
forall a b. (a -> b) -> a -> b
$ [Ty2] -> Ty2
forall loc. [UrTy loc] -> UrTy loc
ProdTy [Ty2]
ts
                             Exp1 -> TiM Exp1
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> TiM Exp1) -> Exp1 -> TiM Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty1
ty,Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
proj) Exp1
e'
                     PackedTy String
tc Var
lv ->
                          do Var
v <- StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"proj")
                             let ty :: Ty1
ty = Ty2 -> Ty1
forall a. UrTy a -> Ty1
stripTyLocs (Ty2 -> Ty1) -> Ty2 -> Ty1
forall a b. (a -> b) -> a -> b
$ String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tc Var
lv
                             Exp1 -> TiM Exp1
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> TiM Exp1) -> Exp1 -> TiM Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[],Ty1
ty,Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
proj) (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
forall k a. Map k a
M.empty Var
v (Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
proj) Exp1
e
                     Ty2
_ -> Exp1 -> TiM Exp1
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
e) Exp1
e ([(Ty2, Int)] -> TiM Exp1) -> [(Ty2, Int)] -> TiM Exp1
forall a b. (a -> b) -> a -> b
$ [Ty2] -> [Int] -> [(Ty2, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ty2]
ts [Int
0..]
      Ty2
_ -> Exp1 -> TiM Exp1
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
e

fixProj :: M.Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj :: Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e =
    let eEq :: a -> a -> Bool
eEq a
e1 a
e2 = a
e1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e2
    in
    case Exp1
e of
      VarE Var
v -> case Var -> Map Var Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v Map Var Var
renam of
                  Maybe Var
Nothing -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                  Just Var
v' -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v'
      LitE Int
v -> Int -> Exp1
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
v
      CharE Char
v -> Char -> Exp1
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
CharE Char
v
      FloatE Double
v -> Double -> Exp1
forall (ext :: * -> * -> *) loc dec. Double -> PreExp ext loc dec
FloatE Double
v
      LitSymE Var
v -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE Var
v
      AppE Var
v [()]
ls [Exp1]
es -> let es' :: [Exp1]
es' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj) [Exp1]
es
                      in Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [()]
ls [Exp1]
es'
      PrimAppE Prim Ty1
pr [Exp1]
es -> let es' :: [Exp1]
es' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj) [Exp1]
es
                        in Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
pr [Exp1]
es'
      LetE (Var
v,[()]
ls,Ty1
t,Exp1
e1) Exp1
e2 ->
          if Exp1
e1 Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
`eEq` Exp1
proj
          then Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj (Var -> Var -> Map Var Var -> Map Var Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Var
pvar Map Var Var
renam) Var
pvar Exp1
proj Exp1
e2
          else let e1' :: Exp1
e1' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e1
                   e2' :: Exp1
e2' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e2
               in (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[()]
ls,Ty1
t,Exp1
e1') Exp1
e2'
      IfE Exp1
e1 Exp1
e2 Exp1
e3 -> let e1' :: Exp1
e1' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e1
                          e2' :: Exp1
e2' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e2
                          e3' :: Exp1
e3' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e3
                      in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp1
e1' Exp1
e2' Exp1
e3'
      MkProdE [Exp1]
es -> let es' :: [Exp1]
es' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj) [Exp1]
es
                    in [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp1]
es'
      ProjE Int
i Exp1
e1 -> if Exp1
e Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
`eEq` Exp1
proj then Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
pvar else
                        let e1' :: Exp1
e1' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e1
                        in Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
e1'
      CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
prs -> let e1' :: Exp1
e1' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e1
                          prs' :: [(String, [(Var, ())], Exp1)]
prs' = ((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
dc,[(Var, ())]
lvs,Exp1
e2) ->
                                          (String
dc,[(Var, ())]
lvs,Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e2)) [(String, [(Var, ())], Exp1)]
prs
                      in Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e1' [(String, [(Var, ())], Exp1)]
prs'
      DataConE ()
lv String
dc [Exp1]
es -> let es' :: [Exp1]
es' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj) [Exp1]
es
                           in () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
lv String
dc [Exp1]
es'
      TimeIt Exp1
e1 Ty1
d Bool
b -> let e1' :: Exp1
e1' = Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e1
                       in Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp1
e1' Ty1
d Bool
b
      SpawnE Var
v [()]
ls [Exp1]
es -> let es' :: [Exp1]
es' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj) [Exp1]
es
                        in Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [()]
ls [Exp1]
es'
      Exp1
SyncE -> Exp1
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
      WithArenaE Var
v Exp1
e -> Var -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Map Var Var -> Var -> Exp1 -> Exp1 -> Exp1
fixProj Map Var Var
renam Var
pvar Exp1
proj Exp1
e
      Ext (L1.AddFixed{}) -> Exp1
e
      Ext (L1.StartOfPkdCursor{}) -> Exp1
e
      Ext (BenchE{}) -> String -> Exp1
forall a. HasCallStack => String -> a
err(String -> Exp1) -> String -> Exp1
forall a b. (a -> b) -> a -> b
$ String
"BenchE not supported"
      MapE{} -> String -> Exp1
forall a. HasCallStack => String -> a
err(String -> Exp1) -> String -> Exp1
forall a b. (a -> b) -> a -> b
$ String
"MapE not supported"
      FoldE{} -> String -> Exp1
forall a. HasCallStack => String -> a
err(String -> Exp1) -> String -> Exp1
forall a b. (a -> b) -> a -> b
$ String
"FoldE not supported"


-- Runs after projTups in the SpawnE case in inferExp.
moveProjsAfterSync :: Var -> Exp2 -> Exp2
moveProjsAfterSync :: Var -> Exp2 -> Exp2
moveProjsAfterSync Var
sv Exp2
ex = [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [] (Var -> Set Var
forall a. a -> Set a
S.singleton Var
sv) Exp2
ex
  where
    go :: [Binds (Exp2)] -> S.Set Var -> Exp2 -> Exp2
    go :: [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
ex =
      case Exp2
ex of
        VarE{}    -> Exp2
ex
        LitE{}    -> Exp2
ex
        CharE{}    -> Exp2
ex
        FloatE{}  -> Exp2
ex
        LitSymE{} -> Exp2
ex
        AppE Var
v [Var]
locs [Exp2]
ls   -> Exp2
ex
        PrimAppE Prim Ty2
pr [Exp2]
args -> Exp2
ex
        LetE (Var
v,[Var]
locs,Ty2
ty,Exp2
SyncE) Exp2
bod ->
          let bod' :: Exp2
bod' = [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [] Set Var
forall a. Set a
S.empty Exp2
bod
          in (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
locs,Ty2
ty,Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE) ([(Var, [Var], Ty2, Exp2)] -> Exp2 -> Exp2
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [Var], Ty2, Exp2)]
[Binds Exp2]
acc1 Exp2
bod')
        LetE (Var
v,[Var]
locs,Ty2
ty,Exp2
rhs) Exp2
bod ->
          let vars :: Set Var
vars = Exp2 -> Set Var
allFreeVars Exp2
rhs
          in if Set Var -> Bool
forall a. Set a -> Bool
S.null (Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set Var
vars Set Var
pending)
             then (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [Var]
locs, Ty2
ty, Exp2
rhs) ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
bod)
             else [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go ((Var
v, [Var]
locs, Ty2
ty, Exp2
rhs)(Var, [Var], Ty2, Exp2)
-> [(Var, [Var], Ty2, Exp2)] -> [(Var, [Var], Ty2, Exp2)]
forall a. a -> [a] -> [a]
:[(Var, [Var], Ty2, Exp2)]
[Binds Exp2]
acc1) (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
v Set Var
pending) Exp2
bod
        IfE Exp2
a Exp2
b Exp2
c   -> Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
a) ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
b) ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
c)
        MkProdE [Exp2]
ls  -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp2] -> Exp2) -> [Exp2] -> Exp2
forall a b. (a -> b) -> a -> b
$ (Exp2 -> Exp2) -> [Exp2] -> [Exp2]
forall a b. (a -> b) -> [a] -> [b]
L.map ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending) [Exp2]
ls
        ProjE Int
i Exp2
arg -> Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp2 -> Exp2) -> Exp2 -> Exp2
forall a b. (a -> b) -> a -> b
$ [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
arg
        CaseE Exp2
scrt [(String, [(Var, Var)], Exp2)]
ls -> Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
scrt) ([(String, [(Var, Var)], Exp2)] -> Exp2)
-> [(String, [(Var, Var)], Exp2)] -> Exp2
forall a b. (a -> b) -> a -> b
$
                           ((String, [(Var, Var)], Exp2) -> (String, [(Var, Var)], Exp2))
-> [(String, [(Var, Var)], Exp2)] -> [(String, [(Var, Var)], Exp2)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
dcon,[(Var, Var)]
vs,Exp2
rhs) -> (String
dcon,[(Var, Var)]
vs,[Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
rhs)) [(String, [(Var, Var)], Exp2)]
ls
        DataConE Var
loc String
dcon [Exp2]
args -> Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
loc String
dcon ([Exp2] -> Exp2) -> [Exp2] -> Exp2
forall a b. (a -> b) -> a -> b
$ (Exp2 -> Exp2) -> [Exp2] -> [Exp2]
forall a b. (a -> b) -> [a] -> [b]
L.map ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending) [Exp2]
args
        TimeIt Exp2
arg Ty2
ty Bool
b -> Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt ([Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
arg) Ty2
ty Bool
b
        WithArenaE Var
a Exp2
e  -> Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
a (Exp2 -> Exp2) -> Exp2 -> Exp2
forall a b. (a -> b) -> a -> b
$ [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
e
        SpawnE Var
fn [Var]
locs [Exp2]
ls -> String -> Exp2
forall a. HasCallStack => String -> a
error String
"moveProjsAfterSync: unbound SpawnE"
        Exp2
SyncE   -> String -> Exp2
forall a. HasCallStack => String -> a
error String
"moveProjsAfterSync: unbound SyncE"
        Ext E2Ext Var Ty2
ext -> case E2Ext Var Ty2
ext of
                     LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
sz Maybe RegionType
ty (Exp2 -> E2Ext Var Ty2) -> Exp2 -> E2Ext Var Ty2
forall a b. (a -> b) -> a -> b
$ [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
bod
                     LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty (Exp2 -> E2Ext Var Ty2) -> Exp2 -> E2Ext Var Ty2
forall a b. (a -> b) -> a -> b
$ [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
bod
                     LetLocE Var
a PreLocExp Var
b Exp2
bod -> E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
a PreLocExp Var
b (Exp2 -> E2Ext Var Ty2) -> Exp2 -> E2Ext Var Ty2
forall a b. (a -> b) -> a -> b
$ [Binds Exp2] -> Set Var -> Exp2 -> Exp2
go [Binds Exp2]
acc1 Set Var
pending Exp2
bod
                     E2Ext Var Ty2
oth -> String -> Exp2
forall a. HasCallStack => String -> a
error (String -> Exp2) -> String -> Exp2
forall a b. (a -> b) -> a -> b
$ String
"moveProjsAfterSync: extension not handled." String -> ShowS
forall a. [a] -> [a] -> [a]
++ E2Ext Var Ty2 -> String
forall a. Out a => a -> String
sdoc E2Ext Var Ty2
oth
        MapE{}  -> String -> Exp2
forall a. HasCallStack => String -> a
error String
"moveProjsAfterSync: todo MapE"
        FoldE{} -> String -> Exp2
forall a. HasCallStack => String -> a
error String
"moveProjsAfterSync: todo FoldE"


-- | Checks that there are no constraints specifying a location
-- after the location passed in.
-- TODO: refactor to only take one list of constraints.
noAfterLoc :: LocVar -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc :: Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv [Constraint]
fcs (Constraint
c:[Constraint]
cs) =
    case Constraint
c of
      AfterVariableL Var
lv1 Var
v Var
lv2 ->
          do Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv2' then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv [Constraint]
fcs [Constraint]
cs
      AfterTagL Var
lv1 Var
lv2 ->
          do Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv2'
             then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                 -- do b1 <- noAfterLoc lv fcs cs
                 --    b2 <- noAfterLoc lv1 fcs fcs
                 --    return (b1 && b2)
             else Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv [Constraint]
fcs [Constraint]
cs
      AfterConstantL Var
lv1 Int
v Var
lv2 ->
          do Var
lv2' <- Var -> TiM Var
finalLocVar Var
lv2
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv2' then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv [Constraint]
fcs [Constraint]
cs
      Constraint
_ -> Var -> [Constraint] -> [Constraint] -> TiM Bool
noAfterLoc Var
lv [Constraint]
fcs [Constraint]
cs
noAfterLoc Var
_ [Constraint]
_ [] = Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

noBeforeLoc :: LocVar -> [Constraint] -> TiM Bool
noBeforeLoc :: Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv (Constraint
c:[Constraint]
cs) =
    case Constraint
c of
      AfterVariableL Var
lv1 Var
v Var
lv2 ->
          do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv1' then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv [Constraint]
cs
      AfterConstantL Var
lv1 Int
v Var
lv2 ->
          do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv1' then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv [Constraint]
cs
      AfterTagL Var
lv1 Var
lv2 ->
          do Var
lv1' <- Var -> TiM Var
finalLocVar Var
lv1
             Var
lv' <- Var -> TiM Var
finalLocVar Var
lv
             if Var
lv' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
lv1' then Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv [Constraint]
cs
      Constraint
_ -> Var -> [Constraint] -> TiM Bool
noBeforeLoc Var
lv [Constraint]
cs
noBeforeLoc Var
lv [] = Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

noRegionStart :: LocVar -> [Constraint] -> TiM Bool
noRegionStart :: Var -> [Constraint] -> TiM Bool
noRegionStart Var
lv (Constraint
c:[Constraint]
cs) =
    case Constraint
c of
      StartRegionL Var
lv2 Region
_r -> ((Var
lv Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
/= Var
lv2) Bool -> Bool -> Bool
&&) (Bool -> Bool) -> TiM Bool -> TiM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var -> [Constraint] -> TiM Bool
noRegionStart Var
lv [Constraint]
cs
      Constraint
_ -> Var -> [Constraint] -> TiM Bool
noRegionStart Var
lv [Constraint]
cs
noRegionStart Var
lv [] = Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Unify is a conditional form that takes a "success branch" and
-- "failure branch".  In the case of failure, it makes no change to
-- the store.  In the case of success, the new equalities are placed
-- in the store /before/ executing the success branch.
unify :: LocVar -> LocVar -> TiM a -> TiM a -> TiM a
unify :: forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
v1 Var
v2 TiM a
successA TiM a
failA = do
  UnifyLoc
ut1 <- Var -> TiM UnifyLoc
lookupUnifyLoc Var
v1
  UnifyLoc
ut2 <- Var -> TiM UnifyLoc
lookupUnifyLoc Var
v2
  case (UnifyLoc
ut1,UnifyLoc
ut2) of
    (FixedLoc Var
l1, FixedLoc Var
l2) ->
        if Var
l1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
l2 then TiM a
successA else TiM a
failA
    (FreshLoc Var
l1, FixedLoc Var
l2) ->
        do Var -> UnifyLoc -> ExceptT Failure (StateT InferState PassM) ()
assocLoc Var
l1 (Var -> UnifyLoc
FixedLoc Var
l2)
           TiM a
successA
    (FixedLoc Var
l2, FreshLoc Var
l1) ->
        do Var -> UnifyLoc -> ExceptT Failure (StateT InferState PassM) ()
assocLoc Var
l1 (Var -> UnifyLoc
FixedLoc Var
l2)
           TiM a
successA
    (FreshLoc Var
l1, FreshLoc Var
l2) ->
        do Var -> UnifyLoc -> ExceptT Failure (StateT InferState PassM) ()
assocLoc Var
l1 (Var -> UnifyLoc
FreshLoc Var
l2)
           TiM a
successA

unifyAll :: [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll :: forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll (Dest
d:[Dest]
ds) (Ty2
ty:[Ty2]
tys) TiM a
successA TiM a
failA =
    case (Dest
d,Ty2
ty) of
      (SingleDest Var
lv1, PackedTy String
_ Var
lv2) -> Var -> Var -> TiM a -> TiM a -> TiM a
forall a. Var -> Var -> TiM a -> TiM a -> TiM a
unify Var
lv1 Var
lv2 ([Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys TiM a
successA TiM a
failA) TiM a
failA
      (TupleDest [Dest]
ds', ProdTy [Ty2]
tys') -> [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds' [Ty2]
tys' ([Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys TiM a
successA TiM a
failA) TiM a
failA
      (Dest
NoDest, PackedTy String
_ Var
_) -> String -> TiM a
forall a. HasCallStack => String -> a
err(String -> TiM a) -> String -> TiM a
forall a b. (a -> b) -> a -> b
$ String
"Expected destination for packed type"
      (SingleDest Var
_, ProdTy [Ty2]
_ ) -> String -> TiM a
forall a. HasCallStack => String -> a
err(String -> TiM a) -> String -> TiM a
forall a b. (a -> b) -> a -> b
$ String
"Expected prod destination for prod type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Dest, Ty2) -> String
forall a. Show a => a -> String
show (Dest
d,Ty2
ty))
      (SingleDest Var
_, Ty2
_) -> [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys TiM a
successA TiM a
failA
      (TupleDest [Dest]
_, PackedTy String
_ Var
_) -> String -> TiM a
forall a. HasCallStack => String -> a
err(String -> TiM a) -> String -> TiM a
forall a b. (a -> b) -> a -> b
$ String
"Expected prod type for prod destination: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Dest, Ty2) -> String
forall a. Show a => a -> String
show (Dest
d,Ty2
ty))
      (TupleDest [Dest]
_, Ty2
_) -> [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys TiM a
successA TiM a
failA
      (Dest
NoDest, Ty2
_) -> [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
forall a. [Dest] -> [Ty2] -> TiM a -> TiM a -> TiM a
unifyAll [Dest]
ds [Ty2]
tys TiM a
successA TiM a
failA
unifyAll (Dest
_:[Dest]
_) [] TiM a
_ TiM a
_ = String -> TiM a
forall a. HasCallStack => String -> a
err(String -> TiM a) -> String -> TiM a
forall a b. (a -> b) -> a -> b
$ String
"Mismatched destination and product type arity"
unifyAll [] (Ty2
_:[Ty2]
_) TiM a
_ TiM a
_ = String -> TiM a
forall a. HasCallStack => String -> a
err(String -> TiM a) -> String -> TiM a
forall a b. (a -> b) -> a -> b
$ String
"Mismatched destination and product type arity"
unifyAll [] [] TiM a
successA TiM a
_ = TiM a
successA


isCpyCallExpr1 :: Exp1 -> Bool 
isCpyCallExpr1 :: Exp1 -> Bool
isCpyCallExpr1 (AppE Var
f [()]
_ [Exp1]
_ ) = Var -> Bool
isCpyVar Var
f
isCpyCallExpr1 Exp1
_ = Bool
False

isCpyVar :: Var -> Bool
isCpyVar :: Var -> Bool
isCpyVar Var
v = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf (String
"copy") (Var -> String
fromVar Var
v)

isCpyCall :: Exp2 -> Bool
isCpyCall :: Exp2 -> Bool
isCpyCall (AppE Var
f [Var]
_ [Exp2]
_) = Bool
True -- TODO: check if it's a real copy call, to be safe
isCpyCall Exp2
_ = Bool
False 

freshLocVar :: String -> PassM LocVar
freshLocVar :: String -> PassM Var
freshLocVar String
m = Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
m)

freshRegVar :: PassM Region
freshRegVar :: PassM Region
freshRegVar = do Var
rv <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"r")
                 Region -> PassM Region
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Region -> PassM Region) -> Region -> PassM Region
forall a b. (a -> b) -> a -> b
$ Var -> Region
VarR Var
rv

finalUnifyLoc :: LocVar -> TiM UnifyLoc
finalUnifyLoc :: Var -> TiM UnifyLoc
finalUnifyLoc Var
v = do
  InferState
m <- StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM InferState
 -> ExceptT Failure (StateT InferState PassM) InferState)
-> StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall a b. (a -> b) -> a -> b
$ StateT InferState PassM InferState
forall (m :: * -> *) s. Monad m => StateT s m s
St.get
  case Var -> InferState -> Maybe UnifyLoc
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v InferState
m of
    Maybe UnifyLoc
Nothing -> UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> UnifyLoc
FreshLoc Var
v)
    Just (FixedLoc Var
v') -> UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> UnifyLoc
FixedLoc Var
v')
    Just (FreshLoc Var
v') -> Var -> TiM UnifyLoc
finalUnifyLoc Var
v'

notFixedLoc :: LocVar -> TiM Bool
notFixedLoc :: Var -> TiM Bool
notFixedLoc Var
lv = do
  UnifyLoc
uv <- Var -> TiM UnifyLoc
finalUnifyLoc Var
lv
  case UnifyLoc
uv of
    FixedLoc Var
_ -> Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    UnifyLoc
_ -> Bool -> TiM Bool
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

finalLocVar :: LocVar -> TiM LocVar
finalLocVar :: Var -> TiM Var
finalLocVar Var
v = do
  UnifyLoc
u <- Var -> TiM UnifyLoc
finalUnifyLoc Var
v
  case UnifyLoc
u of
    FixedLoc Var
v' -> Var -> TiM Var
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
v'
    FreshLoc Var
v' -> Var -> TiM Var
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
v'

fresh :: TiM LocVar
fresh :: TiM Var
fresh = do
  StateT InferState PassM Var -> TiM Var
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM Var -> TiM Var)
-> StateT InferState PassM Var -> TiM Var
forall a b. (a -> b) -> a -> b
$ PassM Var -> StateT InferState PassM Var
forall (m :: * -> *) a. Monad m => m a -> StateT InferState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PassM Var -> StateT InferState PassM Var)
-> PassM Var -> StateT InferState PassM Var
forall a b. (a -> b) -> a -> b
$ String -> PassM Var
freshLocVar String
"loc"

freshUnifyLoc :: TiM UnifyLoc
freshUnifyLoc :: TiM UnifyLoc
freshUnifyLoc = do
  Var
lv <- TiM Var
fresh
  UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifyLoc -> TiM UnifyLoc) -> UnifyLoc -> TiM UnifyLoc
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc
FreshLoc Var
lv

lookupUnifyLoc :: LocVar -> TiM UnifyLoc
lookupUnifyLoc :: Var -> TiM UnifyLoc
lookupUnifyLoc Var
lv = do
  InferState
m <- StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM InferState
 -> ExceptT Failure (StateT InferState PassM) InferState)
-> StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall a b. (a -> b) -> a -> b
$ StateT InferState PassM InferState
forall (m :: * -> *) s. Monad m => StateT s m s
St.get
  case Var -> InferState -> Maybe UnifyLoc
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
lv InferState
m of
    Maybe UnifyLoc
Nothing -> do
      Var
l' <- TiM Var
fresh
      StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM ()
 -> ExceptT Failure (StateT InferState PassM) ())
-> StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall a b. (a -> b) -> a -> b
$ InferState -> StateT InferState PassM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
St.put (InferState -> StateT InferState PassM ())
-> InferState -> StateT InferState PassM ()
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc -> InferState -> InferState
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
lv (Var -> UnifyLoc
FreshLoc Var
l') InferState
m
      UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifyLoc -> TiM UnifyLoc) -> UnifyLoc -> TiM UnifyLoc
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc
FreshLoc Var
l'
    Just (FreshLoc Var
l') -> Var -> TiM UnifyLoc
finalUnifyLoc Var
l'
    Just (FixedLoc Var
l') -> UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifyLoc -> TiM UnifyLoc) -> UnifyLoc -> TiM UnifyLoc
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc
FixedLoc Var
l'

fixLoc :: LocVar -> TiM UnifyLoc
fixLoc :: Var -> TiM UnifyLoc
fixLoc Var
lv = do
  -- l' <- fresh
  InferState
m <- StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM InferState
 -> ExceptT Failure (StateT InferState PassM) InferState)
-> StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall a b. (a -> b) -> a -> b
$ StateT InferState PassM InferState
forall (m :: * -> *) s. Monad m => StateT s m s
St.get
  StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM ()
 -> ExceptT Failure (StateT InferState PassM) ())
-> StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall a b. (a -> b) -> a -> b
$ InferState -> StateT InferState PassM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
St.put (InferState -> StateT InferState PassM ())
-> InferState -> StateT InferState PassM ()
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc -> InferState -> InferState
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
lv (Var -> UnifyLoc
FixedLoc Var
lv) InferState
m
  UnifyLoc -> TiM UnifyLoc
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifyLoc -> TiM UnifyLoc) -> UnifyLoc -> TiM UnifyLoc
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc
FixedLoc Var
lv

assocLoc :: LocVar -> UnifyLoc -> TiM ()
assocLoc :: Var -> UnifyLoc -> ExceptT Failure (StateT InferState PassM) ()
assocLoc Var
lv UnifyLoc
ul = do
  InferState
m <- StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM InferState
 -> ExceptT Failure (StateT InferState PassM) InferState)
-> StateT InferState PassM InferState
-> ExceptT Failure (StateT InferState PassM) InferState
forall a b. (a -> b) -> a -> b
$ StateT InferState PassM InferState
forall (m :: * -> *) s. Monad m => StateT s m s
St.get
  StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT InferState PassM ()
 -> ExceptT Failure (StateT InferState PassM) ())
-> StateT InferState PassM ()
-> ExceptT Failure (StateT InferState PassM) ()
forall a b. (a -> b) -> a -> b
$ InferState -> StateT InferState PassM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
St.put (InferState -> StateT InferState PassM ())
-> InferState -> StateT InferState PassM ()
forall a b. (a -> b) -> a -> b
$ Var -> UnifyLoc -> InferState -> InferState
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
lv UnifyLoc
ul InferState
m

-- | The copy repair tactic:
copy :: Result -> LocVar -> TiM Result
-- CSK: If operating in Gibbon2 mode, can we add an IndirectionE here, and
-- get rid of RemoveCopies?
copy :: Result -> Var -> TiM Result
copy (Exp2
e,Ty2
ty,[Constraint]
cs) Var
lv1 =
    case Ty2
ty of
      PackedTy String
tc Var
lv2 -> do
          let copyName :: Var
copyName = String -> Var
mkCopyFunName String
tc -- assume a copy function with this name
              eapp :: Exp2
eapp = Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
copyName [Var
lv2,Var
lv1] [Exp2
e]
          Result -> TiM Result
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp2
eapp, String -> Var -> Ty2
forall loc. String -> loc -> UrTy loc
PackedTy String
tc Var
lv1, [Constraint]
cs)
      Ty2
_ -> String -> TiM Result
forall a. HasCallStack => String -> a
err (String -> TiM Result) -> String -> TiM Result
forall a b. (a -> b) -> a -> b
$ String
"Did not expect to need to copy non-packed type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ty2 -> String
forall a. Show a => a -> String
show Ty2
ty

unNestLet :: Result -> Result
unNestLet :: Result -> Result
unNestLet ((LetE (Var, [Var], Ty2, Exp2)
_ Exp2
e),Ty2
ty,[Constraint]
cs) = (Exp2
e,Ty2
ty,[Constraint]
cs)
unNestLet (Exp2
e,Ty2
ty,[Constraint]
cs) = (Exp2
e,Ty2
ty,[Constraint]
cs)

pullBnds :: Result -> Maybe (Var, [LocVar], Ty2, Exp2)
pullBnds :: Result -> Maybe (Var, [Var], Ty2, Exp2)
pullBnds ((LetE (Var, [Var], Ty2, Exp2)
bnd Exp2
_),Ty2
_ty,[Constraint]
_cs) = (Var, [Var], Ty2, Exp2) -> Maybe (Var, [Var], Ty2, Exp2)
forall a. a -> Maybe a
Just (Var, [Var], Ty2, Exp2)
bnd
pullBnds (Exp2
_e,Ty2
_ty,[Constraint]
_cs) = Maybe (Var, [Var], Ty2, Exp2)
forall a. Maybe a
Nothing

buildLets :: [(Var, [LocVar], Ty2, Exp2)] -> Exp2 -> Exp2
buildLets :: [(Var, [Var], Ty2, Exp2)] -> Exp2 -> Exp2
buildLets ((Var, [Var], Ty2, Exp2)
bnd:[(Var, [Var], Ty2, Exp2)]
bnds) Exp2
e =
    let e' :: Exp2
e' = [(Var, [Var], Ty2, Exp2)] -> Exp2 -> Exp2
buildLets [(Var, [Var], Ty2, Exp2)]
bnds Exp2
e
    in (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [Var], Ty2, Exp2)
bnd Exp2
e'
buildLets [] Exp2
e = Exp2
e

addCopyVarToEnv :: [((PreExp t2 t1 t), Ty2, t3)] -> FullEnv -> FullEnv
addCopyVarToEnv :: forall (t2 :: * -> * -> *) t1 t t3.
[(PreExp t2 t1 t, Ty2, t3)] -> FullEnv -> FullEnv
addCopyVarToEnv (((LetE (Var
v,[t1]
_,t
_,PreExp t2 t1 t
_) PreExp t2 t1 t
_),Ty2
ty,t3
_cs):[(PreExp t2 t1 t, Ty2, t3)]
ls) FullEnv
env =
    let env' :: FullEnv
env' = Var -> Ty2 -> FullEnv -> FullEnv
extendVEnv Var
v Ty2
ty FullEnv
env
    in [(PreExp t2 t1 t, Ty2, t3)] -> FullEnv -> FullEnv
forall (t2 :: * -> * -> *) t1 t t3.
[(PreExp t2 t1 t, Ty2, t3)] -> FullEnv -> FullEnv
addCopyVarToEnv [(PreExp t2 t1 t, Ty2, t3)]
ls FullEnv
env'
addCopyVarToEnv ((PreExp t2 t1 t, Ty2, t3)
r:[(PreExp t2 t1 t, Ty2, t3)]
ls) FullEnv
env = [(PreExp t2 t1 t, Ty2, t3)] -> FullEnv -> FullEnv
forall (t2 :: * -> * -> *) t1 t t3.
[(PreExp t2 t1 t, Ty2, t3)] -> FullEnv -> FullEnv
addCopyVarToEnv [(PreExp t2 t1 t, Ty2, t3)]
ls FullEnv
env
addCopyVarToEnv [] FullEnv
env = FullEnv
env

-- | For a packed type, get its location.
locOfTy :: Ty2 -> LocVar
locOfTy :: Ty2 -> Var
locOfTy (PackedTy String
_ Var
lv) = Var
lv
locOfTy Ty2
ty2 = String -> Var
forall a. HasCallStack => String -> a
err (String -> Var) -> String -> Var
forall a b. (a -> b) -> a -> b
$ String
"Expected packed type, got "String -> ShowS
forall a. [a] -> [a] -> [a]
++Ty2 -> String
forall a. Show a => a -> String
show Ty2
ty2

err :: HasCallStack => String -> a
err :: forall a. HasCallStack => String -> a
err String
m = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"InferLocations: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m

assumeEq :: (Eq a, Show a) => a -> a -> TiM ()
assumeEq :: forall a.
(Eq a, Show a) =>
a -> a -> ExceptT Failure (StateT InferState PassM) ()
assumeEq a
a1 a
a2 =
    if a
a1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a2
    then () -> ExceptT Failure (StateT InferState PassM) ()
forall a. a -> ExceptT Failure (StateT InferState PassM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else String -> ExceptT Failure (StateT InferState PassM) ()
forall a. HasCallStack => String -> a
err (String -> ExceptT Failure (StateT InferState PassM) ())
-> String -> ExceptT Failure (StateT InferState PassM) ()
forall a b. (a -> b) -> a -> b
$ String
"Expected these to be equal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
a1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
a2)

-- | Convert a prim from L1 to L2
prim :: Prim Ty1 -> PassM (Prim Ty2)
prim :: Prim Ty1 -> PassM (Prim Ty2)
prim Prim Ty1
p = case Prim Ty1
p of
           Prim Ty1
AddP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
AddP
           Prim Ty1
SubP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SubP
           Prim Ty1
MulP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
MulP
           Prim Ty1
DivP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
DivP
           Prim Ty1
ModP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
ModP
           Prim Ty1
ExpP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
ExpP
           Prim Ty1
FAddP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FAddP
           Prim Ty1
FSubP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FSubP
           Prim Ty1
FMulP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FMulP
           Prim Ty1
FDivP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FDivP
           Prim Ty1
FExpP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FExpP
           Prim Ty1
FSqrtP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FSqrtP
           Prim Ty1
FTanP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FTanP
           Prim Ty1
RandP-> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
RandP
           Prim Ty1
FRandP->Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FRandP
           Prim Ty1
FloatToIntP->Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FloatToIntP
           Prim Ty1
IntToFloatP->Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
IntToFloatP
           Prim Ty1
LtP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
LtP
           Prim Ty1
GtP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
GtP
           Prim Ty1
LtEqP-> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
LtEqP
           Prim Ty1
GtEqP-> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
GtEqP
           Prim Ty1
FLtP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FLtP
           Prim Ty1
FGtP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FGtP
           Prim Ty1
FLtEqP-> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FLtEqP
           Prim Ty1
FGtEqP-> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
FGtEqP
           Prim Ty1
OrP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
OrP
           Prim Ty1
AndP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
AndP
           Prim Ty1
EqSymP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
EqSymP
           EqBenchProgP String
str -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Prim Ty2
forall ty. String -> Prim ty
EqBenchProgP String
str)
           Prim Ty1
EqIntP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
EqIntP
           Prim Ty1
EqFloatP -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
EqFloatP
           Prim Ty1
EqCharP  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
EqCharP
           Prim Ty1
MkTrue -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
MkTrue
           Prim Ty1
MkFalse -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
MkFalse
           Prim Ty1
Gensym  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
Gensym
           Prim Ty1
SizeParam -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SizeParam
           Prim Ty1
IsBig    -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
IsBig
           Prim Ty1
PrintInt -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintInt
           Prim Ty1
PrintChar -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintChar
           Prim Ty1
PrintFloat -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintFloat
           Prim Ty1
PrintBool -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintBool
           Prim Ty1
PrintSym -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintSym
           Prim Ty1
ReadInt  -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
PrintInt
           Prim Ty1
RequestSizeOf -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
RequestSizeOf
           ErrorP String
sty Ty1
ty -> Ty1 -> PassM Ty2
convertTy Ty1
ty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
ty -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ty2 -> Prim Ty2
forall ty. String -> ty -> Prim ty
ErrorP String
sty Ty2
ty)
           DictEmptyP Ty1
dty  -> Ty1 -> PassM Ty2
convertTy Ty1
dty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictEmptyP
           DictInsertP Ty1
dty -> Ty1 -> PassM Ty2
convertTy Ty1
dty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictInsertP
           DictLookupP Ty1
dty -> Ty1 -> PassM Ty2
convertTy Ty1
dty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictLookupP
           DictHasKeyP Ty1
dty -> Ty1 -> PassM Ty2
convertTy Ty1
dty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
DictHasKeyP
           VAllocP Ty1
elty    -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VAllocP
           VFreeP Ty1
elty     -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VFreeP
           VFree2P Ty1
elty    -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VFree2P
           VLengthP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VLengthP
           VNthP Ty1
elty      -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VNthP
           VSliceP Ty1
elty    -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VSliceP
           InplaceVUpdateP Ty1
elty -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
InplaceVUpdateP
           VConcatP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VConcatP
           VSortP Ty1
elty     -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VSortP
           VMergeP Ty1
elty    -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
VMergeP
           PDictAllocP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictAllocP Ty2
k' Ty2
v')
           PDictInsertP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictInsertP Ty2
k' Ty2
v')
           PDictLookupP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictLookupP Ty2
k' Ty2
v')
           PDictHasKeyP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictHasKeyP Ty2
k' Ty2
v')
           PDictForkP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictForkP Ty2
k' Ty2
v')
           PDictJoinP Ty1
k Ty1
v -> Ty1 -> PassM Ty2
convertTy Ty1
k PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Ty2
k' -> Ty1 -> PassM Ty2
convertTy Ty1
v PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ty2
v' -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2)) -> Prim Ty2 -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ Ty2 -> Ty2 -> Prim Ty2
forall ty. ty -> ty -> Prim ty
PDictJoinP Ty2
k' Ty2
v')
           LLAllocP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLAllocP
           LLIsEmptyP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLIsEmptyP
           LLConsP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLConsP
           LLHeadP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLHeadP
           LLTailP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLTailP
           LLFreeP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLFreeP
           LLFree2P Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLFree2P
           LLCopyP Ty1
elty   -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
LLCopyP
           InplaceVSortP Ty1
elty -> Ty1 -> PassM Ty2
convertTy Ty1
elty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty2 -> Prim Ty2
forall ty. ty -> Prim ty
InplaceVSortP
           Prim Ty1
GetNumProcessors -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prim Ty2
forall ty. Prim ty
GetNumProcessors
           ReadPackedFile{} -> String -> PassM (Prim Ty2)
forall a. HasCallStack => String -> a
err (String -> PassM (Prim Ty2)) -> String -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ String
"Can't handle this primop yet in InferLocations:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++Prim Ty1 -> String
forall a. Show a => a -> String
show Prim Ty1
p
           ReadArrayFile{} -> String -> PassM (Prim Ty2)
forall a. HasCallStack => String -> a
err (String -> PassM (Prim Ty2)) -> String -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ String
"Can't handle this primop yet in InferLocations:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++Prim Ty1 -> String
forall a. Show a => a -> String
show Prim Ty1
p
           WritePackedFile String
fp Ty1
ty -> Ty1 -> PassM Ty2
convertTy Ty1
ty PassM Ty2 -> (Ty2 -> PassM (Prim Ty2)) -> PassM (Prim Ty2)
forall a b. PassM a -> (a -> PassM b) -> PassM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prim Ty2 -> PassM (Prim Ty2))
-> (Ty2 -> Prim Ty2) -> Ty2 -> PassM (Prim Ty2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Ty2 -> Prim Ty2
forall ty. String -> ty -> Prim ty
WritePackedFile String
fp)
           SymSetEmpty{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymSetEmpty
           SymSetInsert{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymSetInsert
           SymSetContains{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymSetContains
           SymHashEmpty{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymHashEmpty
           SymHashInsert{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymHashInsert
           SymHashLookup{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymHashLookup
           SymHashContains{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
SymHashContains
           IntHashEmpty{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
IntHashEmpty
           IntHashInsert{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
IntHashInsert
           IntHashLookup{} -> Prim Ty2 -> PassM (Prim Ty2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Prim Ty2
forall ty. Prim ty
IntHashLookup
           Write3dPpmFile{} -> String -> PassM (Prim Ty2)
forall a. HasCallStack => String -> a
err (String -> PassM (Prim Ty2)) -> String -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ String
"Write3dPpmFile not handled yet."
           RequestEndOf{} -> String -> PassM (Prim Ty2)
forall a. HasCallStack => String -> a
err (String -> PassM (Prim Ty2)) -> String -> PassM (Prim Ty2)
forall a b. (a -> b) -> a -> b
$ String
"RequestEndOf not handled yet."

emptyEnv :: FullEnv
emptyEnv :: FullEnv
emptyEnv = FullEnv { dataDefs :: DDefs Ty2
dataDefs = DDefs Ty2
forall a. DDefs a
emptyDD
                   , valEnv :: TyEnv Ty2
valEnv   = TyEnv Ty2
forall k a. Map k a
M.empty
                   , funEnv :: TyEnv (ArrowTy Ty2)
funEnv   = TyEnv (ArrowTy Ty2)
TyEnv (ArrowTy2 Ty2)
forall k a. Map k a
M.empty }


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

fixRANs :: Prog2 -> PassM Prog2
fixRANs :: Prog2 -> PassM Prog2
fixRANs prg :: Prog2
prg@(Prog DDefs (TyOf Exp2)
defs Map Var (FunDef Exp2)
funs Maybe (Exp2, TyOf Exp2)
main) = do
    Maybe (Exp2, Ty2)
main' <-
      case Maybe (Exp2, TyOf Exp2)
main of
        Maybe (Exp2, TyOf Exp2)
Nothing -> Maybe (Exp2, Ty2) -> PassM (Maybe (Exp2, Ty2))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp2, Ty2)
forall a. Maybe a
Nothing
        Just (Exp2
ex,TyOf Exp2
ty) -> do
          ([(String, [Exp2])]
_,Exp2
ex') <- DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs (TyOf Exp2)
DDefs Ty2
defs Env2 (TyOf Exp2)
Env2 Ty2
env20 Exp2
ex
          Maybe (Exp2, Ty2) -> PassM (Maybe (Exp2, Ty2))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Exp2, Ty2) -> PassM (Maybe (Exp2, Ty2)))
-> Maybe (Exp2, Ty2) -> PassM (Maybe (Exp2, Ty2))
forall a b. (a -> b) -> a -> b
$ (Exp2, Ty2) -> Maybe (Exp2, Ty2)
forall a. a -> Maybe a
Just (Exp2
ex', TyOf Exp2
Ty2
ty)
    Map Var (FunDef Exp2)
funs' <- Map Var (FunDef Exp2) -> PassM (Map Var (FunDef Exp2))
flattenFuns Map Var (FunDef Exp2)
funs
    Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog2 -> PassM Prog2) -> Prog2 -> PassM Prog2
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp2)
-> Map Var (FunDef Exp2) -> Maybe (Exp2, TyOf Exp2) -> Prog2
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp2)
defs Map Var (FunDef Exp2)
funs' Maybe (Exp2, TyOf Exp2)
Maybe (Exp2, Ty2)
main'
  where
    flattenFuns :: Map Var (FunDef Exp2) -> PassM (Map Var (FunDef Exp2))
flattenFuns = (FunDef Exp2 -> PassM (FunDef Exp2))
-> Map Var (FunDef Exp2) -> PassM (Map Var (FunDef Exp2))
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) -> Map Var a -> m (Map Var b)
mapM FunDef Exp2 -> PassM (FunDef Exp2)
flattenFun
    flattenFun :: FunDef Exp2 -> PassM (FunDef Exp2)
flattenFun (FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp2)
ty Exp2
bod FunMeta
meta) = do
      let env2 :: Env2 Ty2
env2 = TyEnv Ty2 -> TyEnv (ArrowTy Ty2) -> Env2 Ty2
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 ([(Var, Ty2)] -> TyEnv Ty2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty2)] -> TyEnv Ty2) -> [(Var, Ty2)] -> TyEnv Ty2
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty2] -> [(Var, Ty2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
narg (ArrowTy2 Ty2 -> [Ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
ty)) (Env2 Ty2 -> TyEnv (ArrowTy Ty2)
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf Exp2)
Env2 Ty2
env20)
      ([(String, [Exp2])]
_, Exp2
bod') <- DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs (TyOf Exp2)
DDefs Ty2
defs Env2 Ty2
env2 Exp2
bod
      FunDef Exp2 -> PassM (FunDef Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp2 -> PassM (FunDef Exp2))
-> FunDef Exp2 -> PassM (FunDef Exp2)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp2) -> Exp2 -> FunMeta -> FunDef Exp2
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp2)
ty Exp2
bod' FunMeta
meta

    env20 :: Env2 (TyOf Exp2)
env20 = Prog2 -> Env2 (TyOf Exp2)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog2
prg

    exp :: DDefs2 -> Env2 Ty2 -> Exp2 -> PassM ([(DataCon, [Exp2])], Exp2)
    exp :: DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs Ty2
ddfs Env2 Ty2
env2 Exp2
e0 =
      let go :: Exp2 -> PassM ([(DataCon, [Exp2])], Exp2)
          go :: Exp2 -> PassM ([(String, [Exp2])], Exp2)
go = DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs Ty2
ddfs Env2 Ty2
env2

          gols :: ([Exp2] -> b) -> [Exp2] -> PassM ([(String, [Exp2])], b)
gols [Exp2] -> b
f [Exp2]
ls = do ([[(String, [Exp2])]]
bndss,[Exp2]
ls') <- [([(String, [Exp2])], Exp2)] -> ([[(String, [Exp2])]], [Exp2])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(String, [Exp2])], Exp2)] -> ([[(String, [Exp2])]], [Exp2]))
-> PassM [([(String, [Exp2])], Exp2)]
-> PassM ([[(String, [Exp2])]], [Exp2])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp2 -> PassM ([(String, [Exp2])], Exp2))
-> [Exp2] -> PassM [([(String, [Exp2])], Exp2)]
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 Exp2 -> PassM ([(String, [Exp2])], Exp2)
go [Exp2]
ls
                         ([(String, [Exp2])], b) -> PassM ([(String, [Exp2])], b)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(String, [Exp2])]] -> [(String, [Exp2])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, [Exp2])]]
bndss, [Exp2] -> b
f [Exp2]
ls')

      in
      case Exp2
e0 of

        DataConE Var
loc String
k [Exp2]
ls -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2))
-> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a b. (a -> b) -> a -> b
$ ([(String
k, [Exp2]
ls)], Var -> String -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Var
loc String
k [Exp2]
ls)

        LetE (Var
v,[Var]
locs,Ty2
t,Ext (L2.StartOfPkdCursor Var
w)) Exp2
bod ->
          do ([(String, [Exp2])]
bnd2,Exp2
bod') <- DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs Ty2
ddfs (Var -> Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Var -> a -> Env2 a -> Env2 a
L1.extendVEnv Var
v Ty2
t Env2 Ty2
env2) Exp2
bod
             case ((String, [Exp2]) -> Bool)
-> [(String, [Exp2])] -> Maybe (String, [Exp2])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(String
dcon, [Exp2]
ls) -> Exp2 -> [Exp2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.elem (Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v) [Exp2]
ls) [(String, [Exp2])]
bnd2 of
               Maybe (String, [Exp2])
Nothing -> String -> PassM ([(String, [Exp2])], Exp2)
forall a. HasCallStack => String -> a
error (String -> PassM ([(String, [Exp2])], Exp2))
-> String -> PassM ([(String, [Exp2])], Exp2)
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. Show a => a -> String
show Var
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found in any datacon args, " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, [Exp2])] -> String
forall a. Show a => a -> String
show [(String, [Exp2])]
bnd2
               Just (String
dcon, [Exp2]
ls) -> do
                 let tys :: [Ty2]
tys = DDefs Ty2 -> String -> [Ty2]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs Ty2
ddfs String
dcon
                     n :: Int
n = [Ty2] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ Ty2
ty | Ty2
ty <- [Ty2]
tys, Ty2
ty Ty2 -> Ty2 -> Bool
forall a. Eq a => a -> a -> Bool
== Ty2
forall loc. UrTy loc
CursorTy ]
                     rans :: [Exp2]
rans = Int -> [Exp2] -> [Exp2]
forall a. Int -> [a] -> [a]
L.take Int
n [Exp2]
ls
                     needRANsExp :: [Exp2]
needRANsExp = [Exp2] -> [Exp2]
forall a. [a] -> [a]
L.reverse ([Exp2] -> [Exp2]) -> [Exp2] -> [Exp2]
forall a b. (a -> b) -> a -> b
$ Int -> [Exp2] -> [Exp2]
forall a. Int -> [a] -> [a]
L.take Int
n ([Exp2] -> [Exp2]
forall a. [a] -> [a]
reverse [Exp2]
ls)
                     ran_pairs :: Map Exp2 Exp2
ran_pairs = [(Exp2, Exp2)] -> Map Exp2 Exp2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Exp2, Exp2)] -> Map Exp2 Exp2)
-> [(Exp2, Exp2)] -> Map Exp2 Exp2
forall a b. (a -> b) -> a -> b
$ [Exp2] -> [Exp2] -> [(Exp2, Exp2)]
forall a b.
(Show a, Show b, HasCallStack) =>
[a] -> [b] -> [(a, b)]
fragileZip [Exp2]
rans [Exp2]
needRANsExp
                     VarE Var
w' = Map Exp2 Exp2
ran_pairs Map Exp2 Exp2 -> Exp2 -> Exp2
forall k a. Ord k => Map k a -> k -> a
M.! Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                 ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnd2, (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
locs,Ty2
t,E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> E2Ext Var Ty2
forall loc dec. Var -> E2Ext loc dec
L2.StartOfPkdCursor Var
w')) Exp2
bod')

        LetE (Var
v,[Var]
locs,Ty2
t,Exp2
rhs) Exp2
bod -> do ([(String, [Exp2])]
bnd1,Exp2
rhs') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
rhs
                                      ([(String, [Exp2])]
bnd2,Exp2
bod') <- DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs Ty2
ddfs (Var -> Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Var -> a -> Env2 a -> Env2 a
L1.extendVEnv Var
v Ty2
t Env2 Ty2
env2) Exp2
bod
                                      ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnd1[(String, [Exp2])] -> [(String, [Exp2])] -> [(String, [Exp2])]
forall a. [a] -> [a] -> [a]
++[(String, [Exp2])]
bnd2, (Var, [Var], Ty2, Exp2) -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[Var]
locs,Ty2
t,Exp2
rhs') Exp2
bod')

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

        Ext E2Ext Var Ty2
ext -> case E2Ext Var Ty2
ext of
                     LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod -> do
                       ([(String, [Exp2])]
bnds,Exp2
bod') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
bod
                       ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnds, E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod')

                     LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod -> do
                       ([(String, [Exp2])]
bnds,Exp2
bod') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
bod
                       ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnds, E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Region -> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var Ty2
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetParRegionE Region
r RegionSize
sz Maybe RegionType
ty Exp2
bod')

                     LetLocE Var
l PreLocExp Var
rhs Exp2
bod -> do
                       ([(String, [Exp2])]
bnds,Exp2
bod') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
bod
                       ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnds, E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ Var -> PreLocExp Var -> Exp2 -> E2Ext Var Ty2
forall loc dec. Var -> PreLocExp loc -> E2 loc dec -> E2Ext loc dec
LetLocE Var
l PreLocExp Var
rhs Exp2
bod')

                     LetAvail [Var]
vs Exp2
bod -> do
                       ([(String, [Exp2])]
bnds,Exp2
bod') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
bod
                       ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnds, E2Ext Var Ty2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E2Ext Var Ty2 -> Exp2) -> E2Ext Var Ty2 -> Exp2
forall a b. (a -> b) -> a -> b
$ [Var] -> Exp2 -> E2Ext Var Ty2
forall loc dec. [Var] -> E2 loc dec -> E2Ext loc dec
LetAvail [Var]
vs Exp2
bod')

                     RetE{}        -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     FromEndE{}    -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     L2.AddFixed{} -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     BoundsCheck{} -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     IndirectionE{}-> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     E2Ext Var Ty2
GetCilkWorkerNum-> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     L2.StartOfPkdCursor{}-> String -> PassM ([(String, [Exp2])], Exp2)
forall a. HasCallStack => String -> a
error (String -> PassM ([(String, [Exp2])], Exp2))
-> String -> PassM ([(String, [Exp2])], Exp2)
forall a b. (a -> b) -> a -> b
$ String
"uncaught RAN: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ E2Ext Var Ty2 -> String
forall a. Out a => a -> String
sdoc E2Ext Var Ty2
ext
                     L2.TagCursor{}        -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     AllocateTagHere{}     -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     AllocateScalarsHere{} -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     SSPush{}              -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
                     SSPop{}               -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)

        LitE{}    -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
        CharE{}   -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
        FloatE{}  -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
        VarE{}    -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)
        LitSymE{} -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp2
e0)

        AppE Var
f [Var]
lvs [Exp2]
ls     -> ([Exp2] -> Exp2) -> [Exp2] -> PassM ([(String, [Exp2])], Exp2)
forall {b}.
([Exp2] -> b) -> [Exp2] -> PassM ([(String, [Exp2])], b)
gols (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Var]
lvs)  [Exp2]
ls
        PrimAppE Prim Ty2
p [Exp2]
ls     -> ([Exp2] -> Exp2) -> [Exp2] -> PassM ([(String, [Exp2])], Exp2)
forall {b}.
([Exp2] -> b) -> [Exp2] -> PassM ([(String, [Exp2])], b)
gols (Prim Ty2 -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty2
p)  [Exp2]
ls
        MkProdE [Exp2]
ls        -> ([Exp2] -> Exp2) -> [Exp2] -> PassM ([(String, [Exp2])], Exp2)
forall {b}.
([Exp2] -> b) -> [Exp2] -> PassM ([(String, [Exp2])], b)
gols  [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE      [Exp2]
ls

        IfE Exp2
a Exp2
b Exp2
c -> do ([(String, [Exp2])]
b1,Exp2
a') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
a
                        ([(String, [Exp2])]
b2,Exp2
b') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
b
                        ([(String, [Exp2])]
b3,Exp2
c') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
c
                        ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
b1 [(String, [Exp2])] -> [(String, [Exp2])] -> [(String, [Exp2])]
forall a. [a] -> [a] -> [a]
++ [(String, [Exp2])]
b2 [(String, [Exp2])] -> [(String, [Exp2])] -> [(String, [Exp2])]
forall a. [a] -> [a] -> [a]
++ [(String, [Exp2])]
b3, Exp2 -> Exp2 -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp2
a' Exp2
b' Exp2
c')

        ProjE Int
ix Exp2
e -> do ([(String, [Exp2])]
b,Exp2
e') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
e
                         ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
b, Int -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix Exp2
e')

        CaseE Exp2
e [(String, [(Var, Var)], Exp2)]
ls -> do ([(String, [Exp2])]
b,Exp2
e') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
e
                         [([(String, [Exp2])], (String, [(Var, Var)], Exp2))]
ls' <- [(String, [(Var, Var)], Exp2)]
-> ((String, [(Var, Var)], Exp2)
    -> PassM ([(String, [Exp2])], (String, [(Var, Var)], Exp2)))
-> PassM [([(String, [Exp2])], (String, [(Var, Var)], Exp2))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, [(Var, Var)], Exp2)]
ls (((String, [(Var, Var)], Exp2)
  -> PassM ([(String, [Exp2])], (String, [(Var, Var)], Exp2)))
 -> PassM [([(String, [Exp2])], (String, [(Var, Var)], Exp2))])
-> ((String, [(Var, Var)], Exp2)
    -> PassM ([(String, [Exp2])], (String, [(Var, Var)], Exp2)))
-> PassM [([(String, [Exp2])], (String, [(Var, Var)], Exp2))]
forall a b. (a -> b) -> a -> b
$ \ (String
k,[(Var, Var)]
vrs,Exp2
rhs) -> do
                                  let tys :: [Ty2]
tys = DDefs Ty2 -> String -> [Ty2]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs Ty2
ddfs String
k
                                      vrs' :: [Var]
vrs' = ((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Var)]
vrs
                                      env2' :: Env2 Ty2
env2' = TyEnv Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Map Var a -> Env2 a -> Env2 a
L1.extendsVEnv ([(Var, Ty2)] -> TyEnv Ty2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty2] -> [(Var, Ty2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vrs' [Ty2]
tys)) Env2 Ty2
env2
                                  ([(String, [Exp2])]
b2,Exp2
rhs') <- DDefs Ty2 -> Env2 Ty2 -> Exp2 -> PassM ([(String, [Exp2])], Exp2)
exp DDefs Ty2
ddfs Env2 Ty2
env2' Exp2
rhs
                                  ([(String, [Exp2])], (String, [(Var, Var)], Exp2))
-> PassM ([(String, [Exp2])], (String, [(Var, Var)], Exp2))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
b2, (String
k,[(Var, Var)]
vrs,Exp2
rhs'))
                         let ([[(String, [Exp2])]]
bndss,[(String, [(Var, Var)], Exp2)]
ls'') = [([(String, [Exp2])], (String, [(Var, Var)], Exp2))]
-> ([[(String, [Exp2])]], [(String, [(Var, Var)], Exp2)])
forall a b. [(a, b)] -> ([a], [b])
unzip [([(String, [Exp2])], (String, [(Var, Var)], Exp2))]
ls'
                         ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
b [(String, [Exp2])] -> [(String, [Exp2])] -> [(String, [Exp2])]
forall a. [a] -> [a] -> [a]
++ [[(String, [Exp2])]] -> [(String, [Exp2])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, [Exp2])]]
bndss, Exp2 -> [(String, [(Var, Var)], Exp2)] -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp2
e' [(String, [(Var, Var)], Exp2)]
ls'')

        TimeIt Exp2
e Ty2
t Bool
b -> do
          ([(String, [Exp2])]
bnd,Exp2
e') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
e
          ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnd, Exp2 -> Ty2 -> Bool -> Exp2
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp2
e' Ty2
t Bool
b)

        SpawnE Var
f [Var]
lvs [Exp2]
ls -> ([Exp2] -> Exp2) -> [Exp2] -> PassM ([(String, [Exp2])], Exp2)
forall {b}.
([Exp2] -> b) -> [Exp2] -> PassM ([(String, [Exp2])], b)
gols (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [Var]
lvs)  [Exp2]
ls
        Exp2
SyncE -> ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp2
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)

        WithArenaE Var
v Exp2
e -> do
          ([(String, [Exp2])]
bnd, Exp2
e') <- Exp2 -> PassM ([(String, [Exp2])], Exp2)
go Exp2
e
          ([(String, [Exp2])], Exp2) -> PassM ([(String, [Exp2])], Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Exp2])]
bnd, Var -> Exp2 -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp2
e')

        MapE (Var, Ty2, Exp2)
_ Exp2
_      -> String -> PassM ([(String, [Exp2])], Exp2)
forall a. HasCallStack => String -> a
error String
"FINISHLISTS"
        FoldE (Var, Ty2, Exp2)
_ (Var, Ty2, Exp2)
_ Exp2
_   -> String -> PassM ([(String, [Exp2])], Exp2)
forall a. HasCallStack => String -> a
error String
"FINISHLISTS"


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

-- | Adds 'copyPacked' calls in certain places that inferLocs is not able to.
copyOutOfOrderPacked :: Prog1 -> PassM Prog1
copyOutOfOrderPacked :: Prog1 -> PassM Prog1
copyOutOfOrderPacked prg :: Prog1
prg@(Prog DDefs (TyOf Exp1)
ddfs FunDefs Exp1
fndefs Maybe (Exp1, TyOf Exp1)
mnExp) = do
    Maybe (Exp1, Ty1)
mnExp' <- case Maybe (Exp1, TyOf Exp1)
mnExp of
                   Maybe (Exp1, TyOf Exp1)
Nothing -> Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp1, Ty1)
forall a. Maybe a
Nothing
                   Just (Exp1
ex,TyOf Exp1
ty) -> do (Map Var [(Var, Var)]
_, Exp1
ex') <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 (TyOf Exp1)
Env2 Ty1
init_fun_env Map Var [(Var, Var)]
forall k a. Map k a
M.empty [] Exp1
ex
                                      Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1)))
-> Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a b. (a -> b) -> a -> b
$ (Exp1, Ty1) -> Maybe (Exp1, Ty1)
forall a. a -> Maybe a
Just (Exp1
ex', TyOf Exp1
Ty1
ty)
    FunDefs Exp1
fndefs' <- (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDefs Exp1 -> PassM (FunDefs Exp1)
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) -> Map Var a -> m (Map Var b)
mapM FunDef Exp1 -> PassM (FunDef Exp1)
fd FunDefs Exp1
fndefs
    let prg' :: Prog1
prg' = DDefs (TyOf Exp1)
-> FunDefs Exp1 -> Maybe (Exp1, TyOf Exp1) -> Prog1
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp1)
ddfs FunDefs Exp1
fndefs' Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, Ty1)
mnExp'
    Prog1
p0 <- Prog1 -> PassM Prog1
flattenL1 Prog1
prg'
    Prog1 -> PassM Prog1
forall (e :: * -> * -> *) l d.
HasSimplifiable e l d =>
Prog (PreExp e l d) -> PassM (Prog (PreExp e l d))
inlineTriv Prog1
p0
  where
    init_fun_env :: Env2 (TyOf Exp1)
init_fun_env = Prog1 -> Env2 (TyOf Exp1)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog1
prg

    fd :: FunDef1 -> PassM FunDef1
    fd :: FunDef Exp1 -> PassM (FunDef Exp1)
fd fn :: FunDef Exp1
fn@FunDef{[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,Exp1
funBody :: Exp1
funBody :: forall ex. FunDef ex -> ex
funBody,ArrowTy (TyOf Exp1)
funTy :: ArrowTy (TyOf Exp1)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy} = do
        let env2 :: Env2 Ty1
env2 = Map Var Ty1 -> Env2 Ty1 -> Env2 Ty1
forall a. Map Var a -> Env2 a -> Env2 a
L1.extendsVEnv ([(Var, Ty1)] -> Map Var Ty1
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty1)] -> Map Var Ty1) -> [(Var, Ty1)] -> Map Var Ty1
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty1] -> [(Var, Ty1)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst ([Ty1], Ty1)
ArrowTy (TyOf Exp1)
funTy)) Env2 (TyOf Exp1)
Env2 Ty1
init_fun_env
        (Map Var [(Var, Var)]
_, Exp1
funBody') <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
forall k a. Map k a
M.empty [Var]
funArgs Exp1
funBody
        FunDef Exp1 -> PassM (FunDef Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDef Exp1 -> PassM (FunDef Exp1)
forall a b. (a -> b) -> a -> b
$ FunDef Exp1
fn { funBody :: Exp1
funBody = Exp1
funBody' }

    go :: Env2 Ty1 -> M.Map Var [(Var,Var)] -> [Var] -> Exp1
       -> PassM (M.Map Var [(Var,Var)], Exp1)
    go :: Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
ex =
      case Exp1
ex of

        DataConE ()
loc String
dcon [Exp1]
args -> do
          -- assumption: program is in ANF
          let idxs :: [(Var, Int, Int)]
idxs = [ (Var
v, Int
want, Int
have)
                     | (VarE Var
v, Int
want) <- [Exp1] -> [Int] -> [(Exp1, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp1]
args ([Int
0..] :: [Int])
                     , let ty :: Ty1
ty = Var -> Env2 Ty1 -> Ty1
forall a. Out a => Var -> Env2 a -> a
L1.lookupVEnv Var
v Env2 Ty1
env2
                     , let have :: Int
have = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Var -> Bool) -> [Var] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v) [Var]
order
                     , Ty1 -> Bool
forall a. UrTy a -> Bool
L1.isPackedTy Ty1
ty
                     ]
          case [(Var, Int, Int)]
idxs of
            [] -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env, () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dcon [Exp1]
args)
            ((Var
hv,Int
_hw,Int
hh):[(Var, Int, Int)]
rst_idxs) -> do
              -- let (vars,want,have) = unzip3 idxs
              let (Var
hv,Int
_hw,Int
hh) = [(Var, Int, Int)] -> (Var, Int, Int)
forall a. HasCallStack => [a] -> a
head [(Var, Int, Int)]
idxs
              let copies :: [[(Int, Var)]]
copies =
                        ((Int, Var) -> (Int, Var) -> Bool)
-> [(Int, Var)] -> [[(Int, Var)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(Int, Var)
x (Int, Var)
y -> (Int, Var) -> Int
forall a b. (a, b) -> a
fst (Int, Var)
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Var) -> Int
forall a b. (a, b) -> a
fst (Int, Var)
y) ([(Int, Var)] -> [[(Int, Var)]]) -> [(Int, Var)] -> [[(Int, Var)]]
forall a b. (a -> b) -> a -> b
$
                        (Int, [(Int, Var)]) -> [(Int, Var)]
forall a b. (a, b) -> b
snd ((Int, [(Int, Var)]) -> [(Int, Var)])
-> (Int, [(Int, Var)]) -> [(Int, Var)]
forall a b. (a -> b) -> a -> b
$
                        ((Int, [(Int, Var)]) -> (Var, Int, Int) -> (Int, [(Int, Var)]))
-> (Int, [(Int, Var)]) -> [(Var, Int, Int)] -> (Int, [(Int, Var)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\(Int
prev, [(Int, Var)]
acc) (Var
v,Int
_w,Int
h) ->
                                     if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
prev
                                     then (Int
h, [(Int, Var)]
acc [(Int, Var)] -> [(Int, Var)] -> [(Int, Var)]
forall a. [a] -> [a] -> [a]
++ [(Int
h,Var
v)])
                                     else (Int
prev, [(Int, Var)]
acc [(Int, Var)] -> [(Int, Var)] -> [(Int, Var)]
forall a. [a] -> [a] -> [a]
++ [(Int
prev,Var
v)]))
                               (Int
hh, [(Int
hh, Var
hv)])
                               [(Var, Int, Int)]
rst_idxs
              ([Var]
args1, Map Var [(Var, Var)]
cpy_env1) <- ([(Int, Var)]
 -> ([Var], Map Var [(Var, Var)])
 -> PassM ([Var], Map Var [(Var, Var)]))
-> ([Var], Map Var [(Var, Var)])
-> [[(Int, Var)]]
-> PassM ([Var], Map Var [(Var, Var)])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                       (\[(Int, Var)]
groups ([Var]
acc1, Map Var [(Var, Var)]
acc2) ->
                           case [(Int, Var)]
groups of
                             [] -> String -> PassM ([Var], Map Var [(Var, Var)])
forall a. HasCallStack => String -> a
error String
"copyOutOfOrderPacked: empty groups"
                             [(Int
_,Var
one)] -> ([Var], Map Var [(Var, Var)])
-> PassM ([Var], Map Var [(Var, Var)])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
oneVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
acc1, Map Var [(Var, Var)]
acc2)
                             ((Int
_,Var
x):[(Int, Var)]
xs) -> do
                               let vars :: [Var]
vars = ((Int, Var) -> Var) -> [(Int, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Var) -> Var
forall a b. (a, b) -> b
snd [(Int, Var)]
xs
                               [Var]
vars' <- (Var -> PassM Var) -> [Var] -> PassM [Var]
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 Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym [Var]
vars
                               ([Var], Map Var [(Var, Var)])
-> PassM ([Var], Map Var [(Var, Var)])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Var], Map Var [(Var, Var)])
 -> PassM ([Var], Map Var [(Var, Var)]))
-> ([Var], Map Var [(Var, Var)])
-> PassM ([Var], Map Var [(Var, Var)])
forall a b. (a -> b) -> a -> b
$ ([Var
x] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
vars' [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
acc1, Var -> [(Var, Var)] -> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
x ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars [Var]
vars') Map Var [(Var, Var)]
acc2))
                       ([], Map Var [(Var, Var)]
forall k a. Map k a
M.empty)
                       [[(Int, Var)]]
copies
              let args2 :: [Exp1]
args2 = ([Var], [Exp1]) -> [Exp1]
forall a b. (a, b) -> b
snd (([Var], [Exp1]) -> [Exp1]) -> ([Var], [Exp1]) -> [Exp1]
forall a b. (a -> b) -> a -> b
$ (([Var], [Exp1]) -> Exp1 -> ([Var], [Exp1]))
-> ([Var], [Exp1]) -> [Exp1] -> ([Var], [Exp1])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                            (\([Var]
args1', [Exp1]
acc) Exp1
x ->
                               case Exp1
x of
                                 VarE Var
v | Ty1 -> Bool
forall a. UrTy a -> Bool
isPackedTy (Var -> Env2 Ty1 -> Ty1
forall a. Out a => Var -> Env2 a -> a
L1.lookupVEnv Var
v Env2 Ty1
env2) ->
                                      ([Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
tail [Var]
args1', [Exp1]
acc [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
++ [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE ([Var] -> Var
forall a. HasCallStack => [a] -> a
head [Var]
args1')])
                                 Exp1
_ -> ([Var]
args1', [Exp1]
acc [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
++ [Exp1
x]))
                            ([Var]
args1, [])
                            [Exp1]
args
              (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1 Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
cpy_env, () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dcon [Exp1]
args2)

        LetE (Var
v,[()]
locs,Ty1
ty,Exp1
rhs) Exp1
bod -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
rhs1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
rhs
          (Map Var [(Var, Var)]
cpy_env2, Exp1
bod1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go (Var -> Ty1 -> Env2 Ty1 -> Env2 Ty1
forall a. Var -> a -> Env2 a -> Env2 a
L1.extendVEnv Var
v Ty1
ty Env2 Ty1
env2) Map Var [(Var, Var)]
cpy_env1 ([Var]
order [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var
v]) Exp1
bod
          case Var -> Map Var [(Var, Var)] -> Maybe [(Var, Var)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v Map Var [(Var, Var)]
cpy_env2 of
            Just [(Var, Var)]
ls -> do let binds :: [(Var, [()], Ty1, Exp1)]
binds = ((Var, Var) -> (Var, [()], Ty1, Exp1))
-> [(Var, Var)] -> [(Var, [()], Ty1, Exp1)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
old,Var
new) -> let PackedTy String
tycon ()
_ = Var -> Env2 Ty1 -> Ty1
forall a. Out a => Var -> Env2 a -> a
L1.lookupVEnv Var
old Env2 Ty1
env2
                                                             f :: Var
f = String -> Var
mkCopyFunName String
tycon
                                                         in (Var
new,[],String -> () -> Ty1
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon (),Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
old]))
                                          [(Var, Var)]
ls
                              binds1 :: [(Var, [()], Ty1, Exp1)]
binds1 = (Var
v,[()]
locs,Ty1
ty,Exp1
rhs1) (Var, [()], Ty1, Exp1)
-> [(Var, [()], Ty1, Exp1)] -> [(Var, [()], Ty1, Exp1)]
forall a. a -> [a] -> [a]
: [(Var, [()], Ty1, Exp1)]
binds
                          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env2, [(Var, [()], Ty1, Exp1)] -> Exp1 -> Exp1
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [()], Ty1, Exp1)]
binds1 Exp1
bod1)
            Maybe [(Var, Var)]
Nothing -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env2, (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[()]
locs,Ty1
ty,Exp1
rhs1) Exp1
bod1)

        CaseE Exp1
scrt [(String, [(Var, ())], Exp1)]
ls -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
scrt1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
scrt
          let doPat :: (String, [(Var, ())], Exp1)
-> (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
-> PassM (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
doPat (String
dcon,[(Var, ())]
vs,Exp1
rhs) (Map Var [(Var, Var)]
acc1, [(String, [(Var, ())], Exp1)]
acc2) = do
                let vars :: [Var]
vars = ((Var, ()) -> Var) -> [(Var, ())] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, ()) -> Var
forall a b. (a, b) -> a
fst [(Var, ())]
vs
                let tys :: [Ty1]
tys = DDefs Ty1 -> String -> [Ty1]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs (TyOf Exp1)
DDefs Ty1
ddfs String
dcon
                let env2' :: Env2 Ty1
env2' = Map Var Ty1 -> Env2 Ty1 -> Env2 Ty1
forall a. Map Var a -> Env2 a -> Env2 a
L1.extendsVEnv ([(Var, Ty1)] -> Map Var Ty1
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty1] -> [(Var, Ty1)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars [Ty1]
tys)) Env2 Ty1
env2
                (Map Var [(Var, Var)]
acc1', Exp1
rhs1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2' Map Var [(Var, Var)]
acc1 ([Var]
order [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
vars) Exp1
rhs
                -- FIXME check
                let rhs2 :: Exp1
rhs2 = (Var -> Exp1 -> Exp1) -> Exp1 -> [Var] -> Exp1
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Var
x Exp1
acc3 -> case Var -> Map Var [(Var, Var)] -> Maybe [(Var, Var)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
x Map Var [(Var, Var)]
acc1' of
                                               Maybe [(Var, Var)]
Nothing -> Exp1
acc3
                                               Just [(Var, Var)]
ls ->
                                                 let binds :: [(Var, [()], Ty1, Exp1)]
binds = ((Var, Var) -> (Var, [()], Ty1, Exp1))
-> [(Var, Var)] -> [(Var, [()], Ty1, Exp1)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
old,Var
new) ->
                                                                    let PackedTy String
tycon ()
_ = Var -> Env2 Ty1 -> Ty1
forall a. Out a => Var -> Env2 a -> a
L1.lookupVEnv Var
old Env2 Ty1
env2'
                                                                        f :: Var
f = String -> Var
mkCopyFunName String
tycon
                                                                    in (Var
new,[],String -> () -> Ty1
forall loc. String -> loc -> UrTy loc
PackedTy String
tycon (),Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [] [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
old]))
                                                             [(Var, Var)]
ls
                                                 in [(Var, [()], Ty1, Exp1)] -> Exp1 -> Exp1
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [()], Ty1, Exp1)]
binds Exp1
rhs1)
                                 Exp1
rhs1 [Var]
vars
                (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
-> PassM (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
acc1' Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
cpy_env1, (String
dcon,[(Var, ())]
vs,Exp1
rhs2) (String, [(Var, ())], Exp1)
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a. a -> [a] -> [a]
: [(String, [(Var, ())], Exp1)]
acc2)
          (Map Var [(Var, Var)]
cpy_env2, [(String, [(Var, ())], Exp1)]
ls1) <- ((String, [(Var, ())], Exp1)
 -> (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
 -> PassM (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)]))
-> (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
-> [(String, [(Var, ())], Exp1)]
-> PassM (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM (String, [(Var, ())], Exp1)
-> (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
-> PassM (Map Var [(Var, Var)], [(String, [(Var, ())], Exp1)])
doPat (Map Var [(Var, Var)]
cpy_env1, []) [(String, [(Var, ())], Exp1)]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env2, Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
scrt1 [(String, [(Var, ())], Exp1)]
ls1)


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

        VarE{}    -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        LitE{}    -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        CharE{}   -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        FloatE{}  -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        LitSymE{} -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        AppE Var
v [()]
locs [Exp1]
ls -> do
          (Map Var [(Var, Var)]
cpy_env1, [Exp1]
ls1) <- (Exp1
 -> (Map Var [(Var, Var)], [Exp1])
 -> PassM (Map Var [(Var, Var)], [Exp1]))
-> (Map Var [(Var, Var)], [Exp1])
-> [Exp1]
-> PassM (Map Var [(Var, Var)], [Exp1])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                               (\Exp1
e (Map Var [(Var, Var)]
acc1,[Exp1]
acc2) -> do
                                  (Map Var [(Var, Var)]
a,Exp1
b) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
acc1 [Var]
order Exp1
e
                                  (Map Var [(Var, Var)], [Exp1])
-> PassM (Map Var [(Var, Var)], [Exp1])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
a Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
acc1, Exp1
b Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
: [Exp1]
acc2))
                               (Map Var [(Var, Var)]
cpy_env, [])
                               [Exp1]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [()]
locs [Exp1]
ls1)
        PrimAppE Prim Ty1
pr [Exp1]
ls -> do
          (Map Var [(Var, Var)]
cpy_env1, [Exp1]
ls1) <- (Exp1
 -> (Map Var [(Var, Var)], [Exp1])
 -> PassM (Map Var [(Var, Var)], [Exp1]))
-> (Map Var [(Var, Var)], [Exp1])
-> [Exp1]
-> PassM (Map Var [(Var, Var)], [Exp1])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                               (\Exp1
e (Map Var [(Var, Var)]
acc1,[Exp1]
acc2) -> do
                                  (Map Var [(Var, Var)]
a,Exp1
b) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
acc1 [Var]
order Exp1
e
                                  (Map Var [(Var, Var)], [Exp1])
-> PassM (Map Var [(Var, Var)], [Exp1])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
a Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
acc1, Exp1
b Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
: [Exp1]
acc2))
                               (Map Var [(Var, Var)]
cpy_env, [])
                               [Exp1]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
pr [Exp1]
ls1)
        IfE Exp1
a Exp1
b Exp1
c  -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
a1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
a
          -- Here each branch should be given its the same env since we are assuming that the branchches unify with the destination and not with each other. 
          -- TODO : Confirm 
          (Map Var [(Var, Var)]
cpy_env2, Exp1
b1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env1 [Var]
order Exp1
b
          (Map Var [(Var, Var)]
cpy_env3, Exp1
c1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env1 [Var]
order Exp1
c
          let list_env2 :: [(Var, [(Var, Var)])]
list_env2 = Map Var [(Var, Var)] -> [(Var, [(Var, Var)])]
forall k a. Map k a -> [(k, a)]
M.toList Map Var [(Var, Var)]
cpy_env2
          let list_env3 :: [(Var, [(Var, Var)])]
list_env3 = Map Var [(Var, Var)] -> [(Var, [(Var, Var)])]
forall k a. Map k a -> [(k, a)]
M.toList Map Var [(Var, Var)]
cpy_env3
          let new_env :: [(Var, [(Var, Var)])]
new_env   = [(Var, [(Var, Var)])]
list_env2 [(Var, [(Var, Var)])]
-> [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
forall a. [a] -> [a] -> [a]
++ [(Var, [(Var, Var)])]
list_env3
          let map_new_env :: Map Var [(Var, Var)]
map_new_env = [(Var, [(Var, Var)])] -> Map Var [(Var, Var)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, [(Var, Var)])] -> Map Var [(Var, Var)])
-> [(Var, [(Var, Var)])] -> Map Var [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
updateCpyEnv [(Var, [(Var, Var)])]
new_env
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
map_new_env, Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp1
a1 Exp1
b1 Exp1
c1)
        MkProdE [Exp1]
ls -> do
          (Map Var [(Var, Var)]
cpy_env1, [Exp1]
ls1) <- (Exp1
 -> (Map Var [(Var, Var)], [Exp1])
 -> PassM (Map Var [(Var, Var)], [Exp1]))
-> (Map Var [(Var, Var)], [Exp1])
-> [Exp1]
-> PassM (Map Var [(Var, Var)], [Exp1])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                               (\Exp1
e (Map Var [(Var, Var)]
acc1,[Exp1]
acc2) -> do
                                  (Map Var [(Var, Var)]
a,Exp1
b) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
acc1 [Var]
order Exp1
e
                                  (Map Var [(Var, Var)], [Exp1])
-> PassM (Map Var [(Var, Var)], [Exp1])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
a Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
acc1, Exp1
b Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
: [Exp1]
acc2))
                               (Map Var [(Var, Var)]
cpy_env, [])
                               [Exp1]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp1]
ls1)
        ProjE Int
i Exp1
arg -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
arg1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
arg
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env1, Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
arg1)
        TimeIt Exp1
arg Ty1
ty Bool
b -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
arg1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
arg
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp1
arg1 Ty1
ty Bool
b)
        WithArenaE Var
a Exp1
e -> do
          (Map Var [(Var, Var)]
cpy_env1, Exp1
e1) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
cpy_env [Var]
order Exp1
e
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, Var -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
a Exp1
e1)
        SpawnE Var
v [()]
locs [Exp1]
ls -> do
          (Map Var [(Var, Var)]
cpy_env1, [Exp1]
ls1) <- (Exp1
 -> (Map Var [(Var, Var)], [Exp1])
 -> PassM (Map Var [(Var, Var)], [Exp1]))
-> (Map Var [(Var, Var)], [Exp1])
-> [Exp1]
-> PassM (Map Var [(Var, Var)], [Exp1])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                               (\Exp1
e (Map Var [(Var, Var)]
acc1,[Exp1]
acc2) -> do
                                  (Map Var [(Var, Var)]
a,Exp1
b) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
acc1 [Var]
order Exp1
e
                                  (Map Var [(Var, Var)], [Exp1])
-> PassM (Map Var [(Var, Var)], [Exp1])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
a Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
acc1, Exp1
b Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
: [Exp1]
acc2))
                               (Map Var [(Var, Var)]
cpy_env, [])
                               [Exp1]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [()]
locs [Exp1]
ls1)
        Exp1
SyncE -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)
        Ext (BenchE Var
fn [()]
locs [Exp1]
ls Bool
b) -> do
          (Map Var [(Var, Var)]
cpy_env1, [Exp1]
ls1) <- (Exp1
 -> (Map Var [(Var, Var)], [Exp1])
 -> PassM (Map Var [(Var, Var)], [Exp1]))
-> (Map Var [(Var, Var)], [Exp1])
-> [Exp1]
-> PassM (Map Var [(Var, Var)], [Exp1])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM
                               (\Exp1
e (Map Var [(Var, Var)]
acc1,[Exp1]
acc2) -> do
                                  (Map Var [(Var, Var)]
a,Exp1
b) <- Env2 Ty1
-> Map Var [(Var, Var)]
-> [Var]
-> Exp1
-> PassM (Map Var [(Var, Var)], Exp1)
go Env2 Ty1
env2 Map Var [(Var, Var)]
acc1 [Var]
order Exp1
e
                                  (Map Var [(Var, Var)], [Exp1])
-> PassM (Map Var [(Var, Var)], [Exp1])
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
a Map Var [(Var, Var)]
-> Map Var [(Var, Var)] -> Map Var [(Var, Var)]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Var [(Var, Var)]
acc1, Exp1
b Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
: [Exp1]
acc2))
                               (Map Var [(Var, Var)]
cpy_env, [])
                               [Exp1]
ls
          (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map Var [(Var, Var)], Exp1)
 -> PassM (Map Var [(Var, Var)], Exp1))
-> (Map Var [(Var, Var)], Exp1)
-> PassM (Map Var [(Var, Var)], Exp1)
forall a b. (a -> b) -> a -> b
$ (Map Var [(Var, Var)]
cpy_env1, E1Ext () Ty1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> [()] -> [Exp1] -> Bool -> E1Ext () Ty1
forall loc dec.
Var -> [loc] -> [PreExp E1Ext loc dec] -> Bool -> E1Ext loc dec
BenchE Var
fn [()]
locs [Exp1]
ls1 Bool
b))
        Ext (L1.AddFixed{}) -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        Ext (L1.StartOfPkdCursor{}) -> (Map Var [(Var, Var)], Exp1) -> PassM (Map Var [(Var, Var)], Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Var [(Var, Var)]
cpy_env, Exp1
ex)
        MapE{}  -> String -> PassM (Map Var [(Var, Var)], Exp1)
forall a. HasCallStack => String -> a
error String
"copyOutOfOrderPacked: todo MapE"
        FoldE{} -> String -> PassM (Map Var [(Var, Var)], Exp1)
forall a. HasCallStack => String -> a
error String
"copyOutOfOrderPacked: todo FoldE"

-- Updating environment correctly for some branches. 
updateCpyEnv :: [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
updateCpyEnv :: [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
updateCpyEnv [(Var, [(Var, Var)])]
env = case [(Var, [(Var, Var)])]
env of 
      [] -> [] 
      (Var, [(Var, Var)])
x:[(Var, [(Var, Var)])]
xs -> let (Var
key, [(Var, Var)]
val) = (Var, [(Var, Var)])
x 
                  commonKeys :: [(Var, [(Var, Var)])]
commonKeys = [[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
P.concat ([[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])])
-> [[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])]
forall a b. (a -> b) -> a -> b
$ ((Var, [(Var, Var)]) -> [(Var, [(Var, Var)])])
-> [(Var, [(Var, Var)])] -> [[(Var, [(Var, Var)])]]
forall a b. (a -> b) -> [a] -> [b]
P.map (\(Var
a, [(Var, Var)]
b) -> if (Var -> String
fromVar Var
a) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Var -> String
fromVar Var
key) then [(Var
a, [(Var, Var)]
b)]
                                                            else [] ) [(Var, [(Var, Var)])]
xs
                  commonVals :: [(Var, Var)]
commonVals = [[(Var, Var)]] -> [(Var, Var)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
P.concat ([[(Var, Var)]] -> [(Var, Var)]) -> [[(Var, Var)]] -> [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ ((Var, [(Var, Var)]) -> [(Var, Var)])
-> [(Var, [(Var, Var)])] -> [[(Var, Var)]]
forall a b. (a -> b) -> [a] -> [b]
P.map (\(Var
a, [(Var, Var)]
b) -> [(Var, Var)]
b) [(Var, [(Var, Var)])]
commonKeys
                  commonValNew :: [(Var, Var)]
commonValNew = [(Var, Var)]
commonVals [(Var, Var)] -> [(Var, Var)] -> [(Var, Var)]
forall a. [a] -> [a] -> [a]
++ [(Var, Var)]
val
                  removedKeys :: [(Var, [(Var, Var)])]
removedKeys = [[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
P.concat ([[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])])
-> [[(Var, [(Var, Var)])]] -> [(Var, [(Var, Var)])]
forall a b. (a -> b) -> a -> b
$ ((Var, [(Var, Var)]) -> [(Var, [(Var, Var)])])
-> [(Var, [(Var, Var)])] -> [[(Var, [(Var, Var)])]]
forall a b. (a -> b) -> [a] -> [b]
P.map (\(Var
a, [(Var, Var)]
b) -> if (Var -> String
fromVar Var
a) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Var -> String
fromVar Var
key) then []
                                                             else [(Var
a, [(Var, Var)]
b)] ) [(Var, [(Var, Var)])]
xs
                in [(Var
key, [(Var, Var)]
commonValNew)] [(Var, [(Var, Var)])]
-> [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
forall a. [a] -> [a] -> [a]
++ ([(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])]
updateCpyEnv [(Var, [(Var, Var)])]
removedKeys)
          

-- Alias analysis for copyPacked Calls 
-- Data type for storing variables Expressions and aliases. 

type AliasEnv = M.Map Exp1 (Var, S.Set Var)

removeAliasesForCopyCalls :: Prog1 -> PassM Prog1
removeAliasesForCopyCalls :: Prog1 -> PassM Prog1
removeAliasesForCopyCalls prg :: Prog1
prg@(Prog DDefs (TyOf Exp1)
ddfs FunDefs Exp1
fndefs Maybe (Exp1, TyOf Exp1)
mnExp) = do
    Maybe (Exp1, Ty1)
mnExp' <- case Maybe (Exp1, TyOf Exp1)
mnExp of
                   Maybe (Exp1, TyOf Exp1)
Nothing -> Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Exp1, Ty1)
forall a. Maybe a
Nothing
                   Just (Exp1
ex,TyOf Exp1
ty) -> do 
                                      Exp1
ex' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
ex (AliasEnv
forall k a. Map k a
M.empty)
                                      Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1)))
-> Maybe (Exp1, Ty1) -> PassM (Maybe (Exp1, Ty1))
forall a b. (a -> b) -> a -> b
$ (Exp1, Ty1) -> Maybe (Exp1, Ty1)
forall a. a -> Maybe a
Just (Exp1
ex', TyOf Exp1
Ty1
ty)
    FunDefs Exp1
fndefs' <- (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDefs Exp1 -> PassM (FunDefs Exp1)
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) -> Map Var a -> m (Map Var b)
mapM FunDef Exp1 -> PassM (FunDef Exp1)
fd FunDefs Exp1
fndefs
    let prg' :: Prog1
prg' = DDefs (TyOf Exp1)
-> FunDefs Exp1 -> Maybe (Exp1, TyOf Exp1) -> Prog1
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp1)
ddfs FunDefs Exp1
fndefs' Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, Ty1)
mnExp'
    Prog1
p0 <- Prog1 -> PassM Prog1
flattenL1 Prog1
prg'
    Prog1 -> PassM Prog1
forall (e :: * -> * -> *) l d.
HasSimplifiable e l d =>
Prog (PreExp e l d) -> PassM (Prog (PreExp e l d))
inlineTriv Prog1
p0
  where

      fd :: FunDef1 -> PassM FunDef1
      fd :: FunDef Exp1 -> PassM (FunDef Exp1)
fd fn :: FunDef Exp1
fn@FunDef{[Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs,Exp1
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp1
funBody,ArrowTy (TyOf Exp1)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf Exp1)
funTy} = do
          Exp1
funBody' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
funBody (AliasEnv
forall k a. Map k a
M.empty)  
          FunDef Exp1 -> PassM (FunDef Exp1)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDef Exp1 -> PassM (FunDef Exp1)
forall a b. (a -> b) -> a -> b
$ FunDef Exp1
fn { funBody :: Exp1
funBody = Exp1
funBody' }

      _unifyEnvs :: [AliasEnv] -> AliasEnv
      _unifyEnvs :: [AliasEnv] -> AliasEnv
_unifyEnvs [AliasEnv]
envList = ((Var, Set Var) -> (Var, Set Var) -> (Var, Set Var))
-> [AliasEnv] -> AliasEnv
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (Var, Set Var) -> (Var, Set Var) -> (Var, Set Var)
_unifyVals [AliasEnv]
envList

      _unifyVals :: (Var, S.Set Var) -> (Var, S.Set Var) -> (Var, S.Set Var)
      _unifyVals :: (Var, Set Var) -> (Var, Set Var) -> (Var, Set Var)
_unifyVals (Var
v, Set Var
vs) (Var
v', Set Var
vs') = if Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v' then (Var
v, Set Var
vs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Var
vs')
                                     else String -> (Var, Set Var)
forall a. HasCallStack => String -> a
error String
"unifyVals: Variable should be same if key is same!"

      _myLookup :: Exp1 -> [((Exp1, Var), b)] -> Maybe b
      _myLookup :: forall b. Exp1 -> [((Exp1, Var), b)] -> Maybe b
_myLookup Exp1
_ [] = Maybe b
forall a. Maybe a
Nothing
      _myLookup Exp1
key (((Exp1, Var)
thiskey,b
thisval):[((Exp1, Var), b)]
rest) =
        let (Exp1
rhs, Var
_v) = (Exp1, Var)
thiskey
         in if Exp1
rhs Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp1
key
            then b -> Maybe b
forall a. a -> Maybe a
Just b
thisval
            else Exp1 -> [((Exp1, Var), b)] -> Maybe b
forall b. Exp1 -> [((Exp1, Var), b)] -> Maybe b
_myLookup Exp1
key [((Exp1, Var), b)]
rest
                                      
      removeAliases :: Exp1 -> AliasEnv -> PassM Exp1
      removeAliases :: Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
exp AliasEnv
env = case Exp1
exp of 
        DataConE ()
loc String
dcon [Exp1]
args -> do
                                  [Exp1]
args' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [Exp1]
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 (\Exp1
expr -> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
expr AliasEnv
env) [Exp1]
args
                                  Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dcon [Exp1]
args'
        VarE Var
v -> do
                  let vals :: [(Var, Set Var)]
vals = AliasEnv -> [(Var, Set Var)]
forall k a. Map k a -> [a]
M.elems AliasEnv
env
                  let newVar :: [Var]
newVar = ((Var, Set Var) -> Var) -> [(Var, Set Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
P.map (\(Var
a, Set Var
b) -> if (Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
b) then Var
a
                                                 else Var
v ) [(Var, Set Var)]
vals
                  case ([Var] -> [Var]
forall a. Eq a => [a] -> [a]
removeDuplicates [Var]
newVar) of 
                    []   -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                    [Var
v'] -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v'
                    [Var]
_    -> String -> PassM Exp1
forall a. HasCallStack => String -> a
error String
"removeAliases: Did not expect more than one variable!"
        LitE{} -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        CharE{} -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        FloatE{} -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        LitSymE{} -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        AppE Var
f [()]
locs [Exp1]
args -> do
                            [Exp1]
args' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [Exp1]
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 (\Exp1
expr -> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
expr AliasEnv
env) [Exp1]
args
                            Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [()]
locs [Exp1]
args'
        PrimAppE Prim Ty1
f [Exp1]
args -> do 
                           [Exp1]
args' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [Exp1]
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 (\Exp1
expr -> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
expr AliasEnv
env) [Exp1]
args
                           Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
f [Exp1]
args'
        LetE (Var
v, [()]
loc, Ty1
ty, Exp1
rhs) Exp1
bod -> do
                                      let isCpy :: Bool
isCpy = Exp1 -> Bool
isCpyCallExpr1 Exp1
rhs 
                                      Exp1
rhs'  <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
rhs AliasEnv
env
                                      if (Bool
isCpy) then do
                                          let val' :: Maybe (Var, Set Var)
val' = Exp1 -> AliasEnv -> Maybe (Var, Set Var)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Exp1
rhs AliasEnv
env
                                          case Maybe (Var, Set Var)
val' of 
                                            Maybe (Var, Set Var)
Nothing -> do 
                                                       let newEnv :: AliasEnv
newEnv = (Exp1 -> (Var, Set Var) -> AliasEnv -> AliasEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Exp1
rhs (Var
v, Set Var
forall a. Set a
S.empty) AliasEnv
env) 
                                                       (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
loc, Ty1
ty, Exp1
rhs') (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
bod AliasEnv
newEnv
                                            Just (Var
v', Set Var
e') -> do
                                             let e'' :: Set Var
e'' = Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
v Set Var
e' 
                                             let newEnv :: AliasEnv
newEnv = (Exp1 -> (Var, Set Var) -> AliasEnv -> AliasEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Exp1
rhs (Var
v', Set Var
e'') AliasEnv
env)
                                             if Var
v' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v then (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
loc, Ty1
ty, Exp1
rhs') (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
bod AliasEnv
newEnv
                                             else Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
bod AliasEnv
newEnv
                                      else (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
loc, Ty1
ty, Exp1
rhs') (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
bod AliasEnv
env
        CaseE Exp1
scrt [(String, [(Var, ())], Exp1)]
mp -> do 
          [(String, [(Var, ())], Exp1)]
mp' <- ((String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)]
-> PassM [(String, [(Var, ())], Exp1)]
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 (\(String
a, [(Var, ())]
b, Exp1
c) -> do 
                                    Exp1
c' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
c AliasEnv
env
                                    (String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
a, [(Var, ())]
b, Exp1
c')
                                   ) [(String, [(Var, ())], Exp1)]
mp
          Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
scrt [(String, [(Var, ())], Exp1)]
mp'                 
        IfE Exp1
a Exp1
b Exp1
c -> do
          Exp1
a' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
a AliasEnv
env
          Exp1
b' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
b AliasEnv
env
          Exp1
c' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
c AliasEnv
env
          if Exp1
b' Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp1
c' then Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
b'
          else Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp1
a' Exp1
b' Exp1
c' 
        MkProdE [Exp1]
xs -> do 
                      [Exp1]
xs' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [Exp1]
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 (\Exp1
expr -> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
expr AliasEnv
env) [Exp1]
xs
                      Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp1]
xs'
        ProjE Int
i Exp1
e -> do 
                     Exp1
e' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
e AliasEnv
env
                     Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i Exp1
e'
        TimeIt Exp1
e Ty1
ty Bool
b -> do 
                         Exp1
e' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
e AliasEnv
env
                         Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp1
e' Ty1
ty Bool
b
        WithArenaE Var
v Exp1
e -> do 
                          Exp1
e' <- Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
e AliasEnv
env
                          Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Var -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v Exp1
e'
        SpawnE Var
f [()]
locs [Exp1]
args -> do
                              [Exp1]
args' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [Exp1]
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 (\Exp1
expr -> Exp1 -> AliasEnv -> PassM Exp1
removeAliases Exp1
expr AliasEnv
env) [Exp1]
args
                              Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [()]
locs [Exp1]
args'
        Exp1
SyncE -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        Ext E1Ext () Ty1
_ -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
exp
        MapE{} ->  String -> PassM Exp1
forall a. HasCallStack => String -> a
error String
"removeAliasesForCopyCalls: todo MapE"
        FoldE{} -> String -> PassM Exp1
forall a. HasCallStack => String -> a
error String
"removeAliasesForCopyCalls: todo FoldE"



  

{--

t0 :: ArrowTy Ty2
t0 = fst$ runPassM 0 $
     convertFunTy (snd (L1.funArg fd), L1.funRetTy fd)
   where fd = L1.fundefs L1.add1Prog M.! "add1"

tester1 :: L L1.Exp1 -> Exp2
tester1 e = case fst $ fst $ runPassM 0 $ St.runStateT (runExceptT (inferExp emptyEnv e NoDest)) M.empty of
              Right a -> (\(a,_,_)->a) a
              Left a -> err $ show a

t1 :: Exp2
t1 = tester1 (LitE 3)

--  id  :: Tree -> Tree
--  id' :: forall l1 in r1, l2 in r2 . Tree l1 -> Tree l2

t2 :: Exp2
t2 = tester1 $
     LetE ("x",[],IntTy,LitE 1) $
     LetE ("y",[],IntTy,LitE 2) $
     LetE ("z",[],IntTy,PrimAppE L1.AddP [VarE "x", VarE "y"]) $
     VarE "z"

ddtree :: DDefs Ty2
ddtree = fromListDD [DDef (toVar "Tree")
                      [ ("Leaf",[(False,IntTy)])
                      , ("Node",[ (False,PackedTy "Tree" "l")
                                , (False,PackedTy "Tree" "l")])
                      ]]

treeEnv :: FullEnv
treeEnv = FullEnv { dataDefs = ddtree
                  , valEnv   = M.empty
                  , funEnv   = M.empty }


tester2 :: L L1.Exp1 -> Exp2
tester2 e = case fst $ fst $ runPassM 0 $ St.runStateT (runExceptT (inferExp' treeEnv e NoDest)) M.empty of
              Right a -> fst a
              Left a -> err $ show a

t3 :: Exp2
t3 = tester2 $
     LetE ("x",[],IntTy,LitE 1) $
     LetE ("y",[],IntTy,LitE 2) $
     LetE ("z",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x", VarE "y"]) $
     LitE 0

t4 :: Exp2
t4 = tester2 $
     LetE ("x1",[],IntTy,LitE 1) $
     LetE ("y1",[],IntTy,LitE 2) $
     LetE ("z1",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x1", VarE "y1"]) $
     LetE ("x2",[],IntTy,LitE 3) $
     LetE ("y2",[],IntTy,LitE 4) $
     LetE ("z2",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x2", VarE "y2"]) $
     LitE 0

t5 :: Exp2
t5 = tester2 $
     LetE ("x1",[],IntTy,LitE 1) $
     LetE ("y1",[],IntTy,LitE 2) $
     LetE ("z1",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x1", VarE "y1"]) $
     LetE ("x2",[],IntTy,LitE 3) $
     LetE ("y2",[],IntTy,LitE 4) $
     LetE ("z2",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x2", VarE "y2"]) $
     LetE ("z3",[],PackedTy "Tree" (), DataConE () "Node" [VarE "z1", VarE "z2"]) $
     LitE 0

t6 :: Exp2
t6 = tester2 $
     LetE ("x1",[],IntTy,LitE 1) $
     LetE ("y1",[],IntTy,LitE 2) $
     LetE ("z1",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x1", VarE "y1"]) $
     LetE ("x2",[],IntTy,LitE 3) $
     LetE ("y2",[],IntTy,LitE 4) $
     LetE ("z2",[],PackedTy "Tree" (), DataConE () "Leaf" [VarE "x2", VarE "y2"]) $
     LetE ("z3",[],PackedTy "Tree" (), DataConE () "Node" [VarE "z1", VarE "z2"]) $
     CaseE (VarE "z3") [("Leaf", [("x",())], VarE "x"),
                              ("Node", [("x",()),("y",())], LitE 1)]


exadd1Bod :: L L1.Exp1
exadd1Bod = l$
    CaseE (VarE "tr") $
      [ ("Leaf", [("n",())],
         LetE ("leaf1",[],L1.Packed "Tree", PrimAppE L1.AddP [VarE "n", LitE 1])
           (DataConE () "Leaf"
             [VarE "leaf1"]))
      , ("Node", [("x",()),("y",())],
         LetE ("node1",[],L1.Packed "Tree", (AppE "add1" [] (VarE "x")))
          (LetE ("node2",[],L1.Packed "Tree", (AppE "add1" [] (VarE "y")))
           (DataConE () "Node"
                [ VarE "node1"
                , VarE "node2"])))
      ]

treeTy :: Ty1
treeTy = L1.Packed "Tree"

treeDD :: DDefs (UrTy ())
treeDD = (fromListDD [L1.DDef "Tree"
                      [ ("Leaf",[(False,IntTy)])
                      , ("Node",[(False,L1.Packed "Tree")
                                ,(False,L1.Packed "Tree")])]])

mkAdd1Prog :: L L1.Exp1 -> Maybe (L L1.Exp1) -> L1.Prog
mkAdd1Prog bod mainExp = L1.Prog treeDD
                                 (M.fromList [("add1",mkAdd1Fun bod)])
                                 mainExp

mkAdd1Fun :: ex -> L1.FunDef Ty1 ex
mkAdd1Fun bod = L1.FunDef "add1" ("tr",treeTy) treeTy bod

exadd1 :: L1.Prog
exadd1 = mkAdd1Prog exadd1Bod Nothing

mkIdProg :: Maybe (L L1.Exp1) -> L1.Prog
mkIdProg mainExp = L1.Prog treeDD
                           (M.fromList [("id",idFun)])
                           mainExp

idFun :: L1.FunDef Ty1 (L L1.Exp1)
idFun = L1.FunDef "id" ("tr",treeTy) treeTy (VarE "tr")

--}

removeDuplicates :: Eq a => [a] -> [a]
removeDuplicates :: forall a. Eq a => [a] -> [a]
removeDuplicates [a]
list = case [a]
list of 
                                []   -> []
                                a
a:[a]
as -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a]
forall a. Eq a => [a] -> [a]
removeDuplicates ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
a) [a]
as)

-- https://www.reddit.com/r/haskell/comments/u841av/trying_to_remove_all_the_elements_that_occur_in/                                
deleteOne :: Eq a => a -> [a] -> [a]
deleteOne :: forall a. Eq a => a -> [a] -> [a]
deleteOne a
_ [] = [] -- Nothing to delete
deleteOne a
x (a
y:[a]
ys) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a]
ys -- Drop exactly one matching item
deleteOne a
x (a
y:[a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
deleteOne a
x [a]
ys -- Drop one, but not this one (doesn't match).
                                
deleteMany :: Eq a => [a] -> [a] -> [a]
deleteMany :: forall a. Eq a => [a] -> [a] -> [a]
deleteMany [] = [a] -> [a]
forall a. a -> a
id -- Nothing to delete
deleteMany (a
x:[a]
xs) = [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
deleteMany [a]
xs ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
deleteOne a
x -- Delete one, then the rest.

orderOfVarsOutputDataConE :: Exp1 -> [Var]
orderOfVarsOutputDataConE :: Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
exp = case Exp1
exp of
  VarE Var
v    -> []
  LitE Int
_    -> []
  CharE Char
_   -> []
  FloatE{}  -> []
  LitSymE Var
_ -> []
  ProjE Int
_ Exp1
e -> Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
e
  IfE Exp1
a Exp1
b Exp1
c -> (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
a) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
b) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
c)
  AppE Var
v [()]
_ [Exp1]
ls         -> ([[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ ((Exp1 -> [Var]) -> [Exp1] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> [Var]
orderOfVarsOutputDataConE [Exp1]
ls))
  PrimAppE Prim Ty1
_ [Exp1]
ls        -> [[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ ((Exp1 -> [Var]) -> [Exp1] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> [Var]
orderOfVarsOutputDataConE [Exp1]
ls)
  LetE (Var
v,[()]
_,Ty1
_,Exp1
rhs) Exp1
bod -> (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
rhs) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Var -> [Var] -> [Var]
forall a. Eq a => a -> [a] -> [a]
deleteOne Var
v (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
bod))
  CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls -> (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
e) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ ([[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$
                (((String, [(Var, ())], Exp1) -> [Var])
-> [(String, [(Var, ())], Exp1)] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
_, [(Var, ())]
vlocs, Exp1
ee) ->
                                       let ([Var]
vars,[()]
_) = [(Var, ())] -> ([Var], [()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, ())]
vlocs
                                       in [Var] -> [Var] -> [Var]
forall a. Eq a => [a] -> [a] -> [a]
deleteMany (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
ee) [Var]
vars) [(String, [(Var, ())], Exp1)]
ls) )
  MkProdE [Exp1]
ls          -> [[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ (Exp1 -> [Var]) -> [Exp1] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> [Var]
orderOfVarsOutputDataConE [Exp1]
ls
  DataConE ()
_ String
_ [Exp1]
ls     -> (Exp1 -> [Var]) -> [Exp1] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap (\Exp1
exp -> case Exp1
exp of 
                                               VarE Var
v -> [Var
v]
                                               LitSymE Var
v ->  [Var
v]
                                               Exp1
_ -> []          ) [Exp1]
ls
  TimeIt Exp1
e Ty1
_ Bool
_        -> Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
e 
  MapE (Var
v,Ty1
_t,Exp1
rhs) Exp1
bod -> (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
rhs) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Var -> [Var] -> [Var]
forall a. Eq a => a -> [a] -> [a]
deleteOne Var
v (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
bod))
  FoldE (Var
v1,Ty1
_t1,Exp1
r1) (Var
v2,Ty1
_t2,Exp1
r2) Exp1
bod ->
      (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
r1) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
r2) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ (Var -> [Var] -> [Var]
forall a. Eq a => a -> [a] -> [a]
deleteOne Var
v1 ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ Var -> [Var] -> [Var]
forall a. Eq a => a -> [a] -> [a]
deleteOne Var
v2 ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
bod)

  WithArenaE Var
v Exp1
e -> Var -> [Var] -> [Var]
forall a. Eq a => a -> [a] -> [a]
deleteOne Var
v ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ Exp1 -> [Var]
orderOfVarsOutputDataConE Exp1
e

  SpawnE Var
v [()]
_ [Exp1]
ls -> ([[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ (Exp1 -> [Var]) -> [Exp1] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> [Var]
orderOfVarsOutputDataConE [Exp1]
ls)
  Exp1
SyncE -> []
  Ext E1Ext () Ty1
ext ->
    case E1Ext () Ty1
ext of
      L1.AddFixed Var
v Int
i -> []
      L1.StartOfPkdCursor Var
v -> []
      L1.BenchE Var
_f [()]
_locs [Exp1]
args Bool
_b -> ([[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Var]] -> [Var]) -> [[Var]] -> [Var]
forall a b. (a -> b) -> a -> b
$ ((Exp1 -> [Var]) -> [Exp1] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> [Var]
orderOfVarsOutputDataConE [Exp1]
args))