{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Gibbon.Passes.AddRAN
  (addRAN, numRANsDataCon, needsRAN) where

import           Control.Monad ( when, forM )
import           Data.Foldable
import qualified Data.List as L
import qualified Data.Map as M
import           Data.Maybe ( fromJust )
import qualified Data.Set as S
import           Text.PrettyPrint.GenericPretty

import           Gibbon.Common
import           Gibbon.DynFlags
import           Gibbon.Passes.AddTraversals ( needsTraversalCase )
import           Gibbon.L1.Syntax as L1
import           Gibbon.L2.Syntax as L2

{-

Adding random access nodes
~~~~~~~~~~~~~~~~~~~~~~~~~~

We cannot add RAN's to an L2 program, as it would distort the locations
inferred by the previous analysis. Instead, (1) we use the old L1 program and
add RAN's to that, (2) then run location inference again.

Adding RAN's requires 3 steps:

(1) Convert DDefs to `WithRAN DDefs` (we don't have a separate type for those yet).

For example,

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

becomes,

    ddtree :: DDefs Ty1
    ddtree = fromListDD [DDef (toVar "Tree")
                         [ ("Leaf"   ,[(False,IntTy)])
                         , ("Node",  [ (False,PackedTy "Tree" ())
                                     , (False,PackedTy "Tree" ())])
                         , ("Node^", [ (False, CursorTy) -- random access node
                                     , (False,PackedTy "Tree" ())
                                     , (False,PackedTy "Tree" ())])
                         ]]

(2) Update all data constructors that now need to write additional random access nodes
    (before all other arguments so that they're written immediately after the tag).

(3) Case expressions are modified to work with these updated data constructors.
    Pattern matches for these constructors now bind the additional
    random access nodes too.


When does a type 'needsRAN'
~~~~~~~~~~~~~~~~~~~~~~~~~~~

If any pattern 'needsTraversalCase' to be able to unpack it, we mark the type of
scrutinee as something that needs RAN's. Also, types of all packed values flowing
into a SpawnE that live in the same region would need random access.


Keeping old case clauses around
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Consider this example datatype.

    data Foo = A Foo Foo | B

Suppose that we want to add random access nodes to Foo. Before [2019.09.15],
step (3) above was a destructive operation. Specifically, addRAN would update
a pattern match on 'A' in place.

    case foo of
      A x y -> ...

would become

    case foo of
      A^ ran x y -> ...


As described in this [Evernote], we'd like to amortize the cost of adding
random access nodes to a datatype i.e below a certain threshold, we'd rather
perform dummy traversals. It's clear that if we want to support this, we
cannot get rid of the old case clause. After [2019.09.15], that's what
addRAN does. And we run addTraversals later in the pipeline so that the
case clause is compilable.

Evernote: https://www.evernote.com/l/AF-jUPTw2lZDS440RgWbgj9RMNkttTaKd3Y

-}

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

-- | Operates on an L1 program, and updates it to have random access nodes.
--
-- Previous analysis determines which data types require it (needsLRAN).
addRAN :: S.Set TyCon -> Prog1 -> PassM Prog1
addRAN :: Set TyCon -> Prog1 -> PassM Prog1
addRAN Set TyCon
needRANsTyCons prg :: Prog1
prg@Prog{DDefs (TyOf Exp1)
ddefs :: DDefs (TyOf Exp1)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs,FunDefs Exp1
fundefs :: FunDefs Exp1
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs,Maybe (Exp1, TyOf Exp1)
mainExp :: Maybe (Exp1, TyOf Exp1)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} = do
  Bool
dump_op <- DebugFlag -> DynFlags -> Bool
dopt DebugFlag
Opt_D_Dump_Repair (DynFlags -> Bool) -> PassM DynFlags -> PassM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassM DynFlags
forall (m :: * -> *). MonadReader Config m => m DynFlags
getDynFlags
  Bool -> PassM () -> PassM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dump_op (PassM () -> PassM ()) -> PassM () -> PassM ()
forall a b. (a -> b) -> a -> b
$
    Int -> TyCon -> PassM () -> PassM ()
forall a. Int -> TyCon -> a -> a
dbgTrace Int
2 (TyCon
"Adding random access nodes: " TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ [TyCon] -> TyCon
forall a. Out a => a -> TyCon
sdoc (Set TyCon -> [TyCon]
forall a. Set a -> [a]
S.toList Set TyCon
needRANsTyCons)) (() -> PassM ()
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  let iddefs :: DDefs (UrTy ())
iddefs = Set TyCon -> DDefs (UrTy ()) -> DDefs (UrTy ())
forall a. Out a => Set TyCon -> DDefs (UrTy a) -> DDefs (UrTy a)
withRANDDefs Set TyCon
needRANsTyCons DDefs (TyOf Exp1)
DDefs (UrTy ())
ddefs
  [(Var, FunDef1)]
funs <- ((Var, FunDef1) -> PassM (Var, FunDef1))
-> [(Var, FunDef1)] -> PassM [(Var, FunDef1)]
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
nm,FunDef1
f) -> (Var
nm,) (FunDef1 -> (Var, FunDef1))
-> PassM FunDef1 -> PassM (Var, FunDef1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set TyCon -> DDefs (UrTy ()) -> FunDef1 -> PassM FunDef1
addRANFun Set TyCon
needRANsTyCons DDefs (UrTy ())
iddefs FunDef1
f) (FunDefs Exp1 -> [(Var, FunDef1)]
forall k a. Map k a -> [(k, a)]
M.toList FunDefs Exp1
fundefs)
  -- new_fns <- mapM (genRelOffsetsFunNameFn needRANsTyCons ddefs) (M.elems ddefs)
  let funs' :: FunDefs Exp1
funs' = ([(Var, FunDef1)] -> FunDefs Exp1
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, FunDef1)]
funs)
              -- `M.union` (M.fromList $ L.map (\f -> (funName f, f)) new_fns)
  Maybe (Exp1, UrTy ())
mainExp' <-
    case Maybe (Exp1, TyOf Exp1)
mainExp of
      Just (Exp1
ex,TyOf Exp1
ty) -> (Exp1, UrTy ()) -> Maybe (Exp1, UrTy ())
forall a. a -> Maybe a
Just ((Exp1, UrTy ()) -> Maybe (Exp1, UrTy ()))
-> (Exp1 -> (Exp1, UrTy ())) -> Exp1 -> Maybe (Exp1, UrTy ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,TyOf Exp1
UrTy ()
ty) (Exp1 -> Maybe (Exp1, UrTy ()))
-> PassM Exp1 -> PassM (Maybe (Exp1, UrTy ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
False Set TyCon
needRANsTyCons DDefs (UrTy ())
iddefs Exp1
ex
      Maybe (Exp1, TyOf Exp1)
Nothing -> Maybe (Exp1, UrTy ()) -> PassM (Maybe (Exp1, UrTy ()))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp1, UrTy ())
forall a. Maybe a
Nothing
  let l1 :: Prog1
l1 = Prog1
prg { ddefs :: DDefs (TyOf Exp1)
ddefs = DDefs (TyOf Exp1)
DDefs (UrTy ())
iddefs
               , fundefs :: FunDefs Exp1
fundefs = FunDefs Exp1
funs'
               , mainExp :: Maybe (Exp1, TyOf Exp1)
mainExp = Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, UrTy ())
mainExp'
               }
  Prog1 -> PassM Prog1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prog1
l1

addRANFun :: S.Set TyCon -> DDefs Ty1 -> FunDef1 -> PassM FunDef1
addRANFun :: Set TyCon -> DDefs (UrTy ()) -> FunDef1 -> PassM FunDef1
addRANFun Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs fd :: FunDef1
fd@FunDef{Var
funName :: Var
funName :: forall ex. FunDef ex -> Var
funName,Exp1
funBody :: Exp1
funBody :: forall ex. FunDef ex -> ex
funBody} = do
  let dont_change_datacons :: Bool
dont_change_datacons = Var -> Bool
isCopySansPtrsFunName Var
funName
  Exp1
bod <- Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs Exp1
funBody
  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef1 -> PassM FunDef1) -> FunDef1 -> PassM FunDef1
forall a b. (a -> b) -> a -> b
$ FunDef1
fd{funBody :: Exp1
funBody = Exp1
bod}

addRANExp :: Bool -> S.Set TyCon -> DDefs Ty1 -> Exp1 -> PassM Exp1
addRANExp :: Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs Exp1
ex =
  case Exp1
ex of
    -- Update a data constructor to produce values with random access nodes.
    -- N.B. It always uses absolute pointers for random access nodes. We
    -- may not always want this. If we know that a region is BigInf, we should
    -- use relative offsets as pointers. But that's not being done right now.
    DataConE ()
loc TyCon
dcon [Exp1]
args
      | Bool
dont_change_datacons ->
        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
      | Bool
otherwise ->
      case DDefs (UrTy ()) -> TyCon -> Int
forall a. Out a => DDefs (UrTy a) -> TyCon -> Int
numRANsDataCon DDefs (UrTy ())
ddfs TyCon
dcon of
        Int
0 -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
        Int
n ->
          let tycon :: TyCon
tycon = DDefs (UrTy ()) -> TyCon -> TyCon
forall a. Out a => DDefs a -> TyCon -> TyCon
getTyOfDataCon DDefs (UrTy ())
ddfs TyCon
dcon
          -- Only add random access nodes to the data types that need it.
          in if Bool -> Bool
not (TyCon
tycon TyCon -> Set TyCon -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TyCon
needRANsTyCons)
             then Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
             else do
          let -- n elements after the first packed one require RAN's.
              needRANsExp :: [Exp1]
needRANsExp = Int -> [Exp1] -> [Exp1]
forall a. Int -> [a] -> [a]
L.drop ([Exp1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp1]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [Exp1]
args

          [(Var, [()], UrTy (), Exp1)]
rans <- [Exp1] -> PassM [(Var, [()], UrTy (), Exp1)]
mkRANs [Exp1]
needRANsExp
          let ranArgs :: [Exp1]
ranArgs = ((Var, [()], UrTy (), Exp1) -> Exp1)
-> [(Var, [()], UrTy (), Exp1)] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Var
v,[()]
_,UrTy ()
_,Exp1
_) -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v) [(Var, [()], UrTy (), Exp1)]
rans
          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, [()], UrTy (), Exp1)] -> Exp1 -> Exp1
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [()], UrTy (), Exp1)]
rans (() -> TyCon -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> TyCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc (TyCon -> TyCon
toAbsRANDataCon TyCon
dcon) ([Exp1]
ranArgs [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
++ [Exp1]
args))

    -- standard recursion here
    VarE{}    -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    LitE{}    -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    CharE{}   -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    FloatE{}  -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    LitSymE{} -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    AppE Var
f [()]
locs [Exp1]
args -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [()]
locs ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> PassM Exp1
go [Exp1]
args
    PrimAppE Prim (UrTy ())
f [Exp1]
args  -> Prim (UrTy ()) -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim (UrTy ())
f ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> PassM Exp1
go [Exp1]
args
    LetE (Var
v,[()]
loc,UrTy ()
ty,Exp1
rhs) Exp1
bod -> do
      (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE ((Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1)
-> (Exp1 -> (Var, [()], UrTy (), Exp1)) -> Exp1 -> Exp1 -> Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var
v,[()]
loc,UrTy ()
ty,) (Exp1 -> Exp1 -> Exp1) -> PassM Exp1 -> PassM (Exp1 -> Exp1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> PassM Exp1
go Exp1
rhs PassM (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp1 -> PassM Exp1
go Exp1
bod
    IfE Exp1
a Exp1
b Exp1
c  -> 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 -> Exp1 -> Exp1 -> Exp1)
-> PassM Exp1 -> PassM (Exp1 -> Exp1 -> Exp1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> PassM Exp1
go Exp1
a PassM (Exp1 -> Exp1 -> Exp1) -> PassM Exp1 -> PassM (Exp1 -> Exp1)
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp1 -> PassM Exp1
go Exp1
b PassM (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp1 -> PassM Exp1
go Exp1
c
    MkProdE [Exp1]
xs -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> PassM Exp1
go [Exp1]
xs
    ProjE Int
i Exp1
e  -> Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> PassM Exp1
go Exp1
e
    CaseE Exp1
scrt [(TyCon, [(Var, ())], Exp1)]
mp -> Exp1 -> [(TyCon, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(TyCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
scrt ([(TyCon, [(Var, ())], Exp1)] -> Exp1)
-> ([[(TyCon, [(Var, ())], Exp1)]] -> [(TyCon, [(Var, ())], Exp1)])
-> [[(TyCon, [(Var, ())], Exp1)]]
-> Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(TyCon, [(Var, ())], Exp1)]] -> [(TyCon, [(Var, ())], Exp1)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(TyCon, [(Var, ())], Exp1)]] -> Exp1)
-> PassM [[(TyCon, [(Var, ())], Exp1)]] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TyCon, [(Var, ())], Exp1) -> PassM [(TyCon, [(Var, ())], Exp1)])
-> [(TyCon, [(Var, ())], Exp1)]
-> PassM [[(TyCon, [(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 (TyCon, [(Var, ())], Exp1) -> PassM [(TyCon, [(Var, ())], Exp1)]
doalt [(TyCon, [(Var, ())], Exp1)]
mp
    TimeIt Exp1
e UrTy ()
ty Bool
b -> do
      Exp1
e' <- Exp1 -> PassM Exp1
go Exp1
e
      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 -> UrTy () -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp1
e' UrTy ()
ty Bool
b
    WithArenaE Var
v Exp1
e -> do
      Exp1
e' <- Exp1 -> PassM Exp1
go Exp1
e
      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 -> 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 -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [()]
locs ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> PassM Exp1
go [Exp1]
args
    Exp1
SyncE   -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp1
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
    Ext E1Ext () (UrTy ())
_   -> Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex
    MapE{}  -> TyCon -> PassM Exp1
forall a. HasCallStack => TyCon -> a
error TyCon
"addRANExp: TODO MapE"
    FoldE{} -> TyCon -> PassM Exp1
forall a. HasCallStack => TyCon -> a
error TyCon
"addRANExp: TODO FoldE"

  where
    go :: Exp1 -> PassM Exp1
go = Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs

    changeSpawnToApp :: Exp1 -> Exp1
    changeSpawnToApp :: Exp1 -> Exp1
changeSpawnToApp Exp1
ex1 =
      case Exp1
ex1 of
        VarE{}    -> Exp1
ex1
        LitE{}    -> Exp1
ex1
        CharE{}   -> Exp1
ex1
        FloatE{}  -> Exp1
ex1
        LitSymE{} -> Exp1
ex1
        AppE Var
f [()]
locs [Exp1]
args -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [()]
locs ([Exp1] -> Exp1) -> [Exp1] -> Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp1 -> Exp1
changeSpawnToApp [Exp1]
args
        PrimAppE Prim (UrTy ())
f [Exp1]
args  -> Prim (UrTy ()) -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim (UrTy ())
f ([Exp1] -> Exp1) -> [Exp1] -> Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp1 -> Exp1
changeSpawnToApp [Exp1]
args
        LetE (Var
_,[()]
_,UrTy ()
_,Exp1
SyncE) Exp1
bod -> Exp1 -> Exp1
changeSpawnToApp Exp1
bod
        LetE (Var
v,[()]
loc,UrTy ()
ty,Exp1
rhs) Exp1
bod -> do
          (Var, [()], UrTy (), 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,UrTy ()
ty, Exp1 -> Exp1
changeSpawnToApp Exp1
rhs) (Exp1 -> Exp1
changeSpawnToApp Exp1
bod)
        IfE Exp1
a Exp1
b Exp1
c  -> 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 -> Exp1
changeSpawnToApp Exp1
a) (Exp1 -> Exp1
changeSpawnToApp Exp1
b) (Exp1 -> Exp1
changeSpawnToApp Exp1
c)
        MkProdE [Exp1]
xs -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp1] -> Exp1) -> [Exp1] -> Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp1 -> Exp1
changeSpawnToApp [Exp1]
xs
        ProjE Int
i Exp1
e  -> Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Exp1
changeSpawnToApp Exp1
e
        DataConE ()
loc TyCon
dcon [Exp1]
args -> () -> TyCon -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> TyCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc TyCon
dcon ([Exp1] -> Exp1) -> [Exp1] -> Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp1 -> Exp1
changeSpawnToApp [Exp1]
args
        CaseE Exp1
scrt [(TyCon, [(Var, ())], Exp1)]
mp ->
          Exp1 -> [(TyCon, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(TyCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp1 -> Exp1
changeSpawnToApp Exp1
scrt) ([(TyCon, [(Var, ())], Exp1)] -> Exp1)
-> [(TyCon, [(Var, ())], Exp1)] -> Exp1
forall a b. (a -> b) -> a -> b
$ ((TyCon, [(Var, ())], Exp1) -> (TyCon, [(Var, ())], Exp1))
-> [(TyCon, [(Var, ())], Exp1)] -> [(TyCon, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TyCon
a,[(Var, ())]
b,Exp1
c) -> (TyCon
a,[(Var, ())]
b, Exp1 -> Exp1
changeSpawnToApp Exp1
c)) [(TyCon, [(Var, ())], Exp1)]
mp
        TimeIt Exp1
e UrTy ()
ty Bool
b  -> Exp1 -> UrTy () -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (Exp1 -> Exp1
changeSpawnToApp Exp1
e) UrTy ()
ty Bool
b
        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
changeSpawnToApp Exp1
e)
        SpawnE Var
f [()]
locs [Exp1]
args -> Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [()]
locs ([Exp1] -> Exp1) -> [Exp1] -> Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Exp1 -> Exp1
changeSpawnToApp [Exp1]
args
        Exp1
SyncE   -> Exp1
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
        Ext{}   -> Exp1
ex1
        MapE{}  -> TyCon -> Exp1
forall a. HasCallStack => TyCon -> a
error TyCon
"addRANExp: TODO MapE"
        FoldE{} -> TyCon -> Exp1
forall a. HasCallStack => TyCon -> a
error TyCon
"addRANExp: TODO FoldE"

    doalt :: (DataCon, [(Var,())], Exp1) -> PassM [(DataCon, [(Var,())], Exp1)]
    doalt :: (TyCon, [(Var, ())], Exp1) -> PassM [(TyCon, [(Var, ())], Exp1)]
doalt (TyCon
dcon,[(Var, ())]
vs,Exp1
bod) = do
      -- Always process the body, because it might have another case expression.
      Exp1
bod0 <- Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs (Exp1 -> Exp1
changeSpawnToApp Exp1
bod)
      let old_pat :: (TyCon, [(Var, ())], Exp1)
old_pat = (TyCon
dcon,[(Var, ())]
vs,Exp1
bod0)
      case DDefs (UrTy ()) -> TyCon -> Int
forall a. Out a => DDefs (UrTy a) -> TyCon -> Int
numRANsDataCon DDefs (UrTy ())
ddfs TyCon
dcon of
        Int
0 -> [(TyCon, [(Var, ())], Exp1)] -> PassM [(TyCon, [(Var, ())], Exp1)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TyCon, [(Var, ())], Exp1)
old_pat]
        Int
n -> do
          let tycon :: TyCon
tycon = DDefs (UrTy ()) -> TyCon -> TyCon
forall a. Out a => DDefs a -> TyCon -> TyCon
getTyOfDataCon DDefs (UrTy ())
ddfs TyCon
dcon
          -- Not all types have random access nodes.
          if Bool -> Bool
not (TyCon
tycon TyCon -> Set TyCon -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TyCon
needRANsTyCons)
          then [(TyCon, [(Var, ())], Exp1)] -> PassM [(TyCon, [(Var, ())], Exp1)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TyCon, [(Var, ())], Exp1)
old_pat]
          else do
            [Var]
absRanVars <- (Int -> PassM Var) -> [Int] -> 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 (\Int
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"absran") [Int
1..Int
n]
            Var
sizeVar <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"size"
            [Var]
relRanVars <- (Int -> PassM Var) -> [Int] -> 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 (\Int
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"relran") [Int
1..Int
n]
            let relRanVars' :: [Var]
relRanVars' = Var
sizeVar Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
relRanVars
            Exp1
bod' <- Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs Exp1
bod
            Exp1
bod'' <- Bool -> Set TyCon -> DDefs (UrTy ()) -> Exp1 -> PassM Exp1
addRANExp Bool
dont_change_datacons Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs Exp1
bod
            let abs_ran_clause :: (TyCon, [(Var, ())], Exp1)
abs_ran_clause = (TyCon -> TyCon
toAbsRANDataCon TyCon
dcon, ((Var -> (Var, ())) -> [Var] -> [(Var, ())]
forall a b. (a -> b) -> [a] -> [b]
L.map (,()) [Var]
absRanVars) [(Var, ())] -> [(Var, ())] -> [(Var, ())]
forall a. [a] -> [a] -> [a]
++ [(Var, ())]
vs, Exp1
bod')
            let _rel_ran_clause :: (TyCon, [(Var, ())], Exp1)
_rel_ran_clause = (TyCon -> TyCon
toRelRANDataCon TyCon
dcon, ((Var -> (Var, ())) -> [Var] -> [(Var, ())]
forall a b. (a -> b) -> [a] -> [b]
L.map (,()) [Var]
relRanVars') [(Var, ())] -> [(Var, ())] -> [(Var, ())]
forall a. [a] -> [a] -> [a]
++ [(Var, ())]
vs, Exp1
bod'')
            {- dflags <- getDynFlags
            if gopt Opt_RelativeOffsets dflags
              then pure [abs_ran_clause,rel_ran_clause]
              else pure [abs_ran_clause] -}
            [(TyCon, [(Var, ())], Exp1)] -> PassM [(TyCon, [(Var, ())], Exp1)]
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TyCon, [(Var, ())], Exp1)
abs_ran_clause]

-- | Update data type definitions to include random access nodes.
withRANDDefs :: Out a => S.Set TyCon -> DDefs (UrTy a) -> DDefs (UrTy a)
withRANDDefs :: forall a. Out a => Set TyCon -> DDefs (UrTy a) -> DDefs (UrTy a)
withRANDDefs Set TyCon
needRANsTyCons DDefs (UrTy a)
ddfs = (DDef (UrTy a) -> DDef (UrTy a))
-> DDefs (UrTy a) -> DDefs (UrTy a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map DDef (UrTy a) -> DDef (UrTy a)
go DDefs (UrTy a)
ddfs
  where
    -- go :: DDef a -> DDef b
    go :: DDef (UrTy a) -> DDef (UrTy a)
go dd :: DDef (UrTy a)
dd@DDef{[(TyCon, [(Bool, UrTy a)])]
dataCons :: [(TyCon, [(Bool, UrTy a)])]
dataCons :: forall a. DDef a -> [(TyCon, [(Bool, a)])]
dataCons} =
      let dcons' :: [(TyCon, [(Bool, UrTy a)])]
dcons' = ((TyCon, [(Bool, UrTy a)])
 -> [(TyCon, [(Bool, UrTy a)])] -> [(TyCon, [(Bool, UrTy a)])])
-> [(TyCon, [(Bool, UrTy a)])]
-> [(TyCon, [(Bool, UrTy a)])]
-> [(TyCon, [(Bool, UrTy a)])]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (\(TyCon
dcon,[(Bool, UrTy a)]
tys) [(TyCon, [(Bool, UrTy a)])]
acc ->
                              case DDefs (UrTy a) -> TyCon -> Int
forall a. Out a => DDefs (UrTy a) -> TyCon -> Int
numRANsDataCon DDefs (UrTy a)
ddfs TyCon
dcon of
                                Int
0 -> [(TyCon, [(Bool, UrTy a)])]
acc
                                Int
n -> -- Not all types have random access nodes.
                                     if Bool -> Bool
not (DDefs (UrTy a) -> TyCon -> TyCon
forall a. Out a => DDefs a -> TyCon -> TyCon
getTyOfDataCon DDefs (UrTy a)
ddfs TyCon
dcon TyCon -> Set TyCon -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TyCon
needRANsTyCons)
                                     then [(TyCon, [(Bool, UrTy a)])]
acc
                                     else
                                       let tys' :: [(Bool, UrTy a)]
tys'   = [(Bool
False,UrTy a
forall loc. UrTy loc
CursorTy) | Int
_ <- [Int
1..Int
n]] [(Bool, UrTy a)] -> [(Bool, UrTy a)] -> [(Bool, UrTy a)]
forall a. [a] -> [a] -> [a]
++ [(Bool, UrTy a)]
tys
                                           dcon' :: TyCon
dcon'  = TyCon -> TyCon
toAbsRANDataCon TyCon
dcon

                                           _tys'' :: [(Bool, UrTy a)]
_tys''  = (Bool
False,UrTy a
forall loc. UrTy loc
IntTy) (Bool, UrTy a) -> [(Bool, UrTy a)] -> [(Bool, UrTy a)]
forall a. a -> [a] -> [a]
: [(Bool
False,UrTy a
forall loc. UrTy loc
IntTy) | Int
_ <- [Int
1..Int
n]] [(Bool, UrTy a)] -> [(Bool, UrTy a)] -> [(Bool, UrTy a)]
forall a. [a] -> [a] -> [a]
++ [(Bool, UrTy a)]
tys
                                           -- dcon'' = toRelRANDataCon dcon
                                       -- in [(dcon',tys'),(dcon'',tys'')] ++ acc)
                                       in [(TyCon
dcon',[(Bool, UrTy a)]
tys')] [(TyCon, [(Bool, UrTy a)])]
-> [(TyCon, [(Bool, UrTy a)])] -> [(TyCon, [(Bool, UrTy a)])]
forall a. [a] -> [a] -> [a]
++ [(TyCon, [(Bool, UrTy a)])]
acc)
                   [] [(TyCon, [(Bool, UrTy a)])]
dataCons
      -- Add the new constructors after all the existing constructors.
      -- The order of constructors matters when these become numeric tags after codegen.
      -- Adding new ones after all the old ones ensures that files that were
      -- serialized using a datatype before continue to work even after this datatype
      -- is updated to have random access capabilities.
      in DDef (UrTy a)
dd {dataCons :: [(TyCon, [(Bool, UrTy a)])]
dataCons = [(TyCon, [(Bool, UrTy a)])]
dataCons [(TyCon, [(Bool, UrTy a)])]
-> [(TyCon, [(Bool, UrTy a)])] -> [(TyCon, [(Bool, UrTy a)])]
forall a. [a] -> [a] -> [a]
++ [(TyCon, [(Bool, UrTy a)])]
dcons'}


-- | The number of nodes needed by a 'DataCon' for full random access
-- (which is equal the number of arguments occurring after the first packed type).
--
numRANsDataCon :: Out a => DDefs (UrTy a) -> DataCon -> Int
numRANsDataCon :: forall a. Out a => DDefs (UrTy a) -> TyCon -> Int
numRANsDataCon DDefs (UrTy a)
ddfs TyCon
dcon
  | TyCon -> Bool
isAbsRANDataCon TyCon
dcon Bool -> Bool -> Bool
|| TyCon -> Bool
isRelRANDataCon TyCon
dcon = Int
0
  | Bool
otherwise =
    case (UrTy a -> Bool) -> [UrTy a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex UrTy a -> Bool
forall a. UrTy a -> Bool
isPackedTy [UrTy a]
tys of
      Maybe Int
Nothing -> Int
0
      Just Int
firstPacked -> ([UrTy a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UrTy a]
tys) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstPacked Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    where tys :: [UrTy a]
tys = DDefs (UrTy a) -> TyCon -> [UrTy a]
forall a. Out a => DDefs a -> TyCon -> [a]
lookupDataCon DDefs (UrTy a)
ddfs TyCon
dcon

{-

Given a list of expressions, generate random access nodes for them.
Consider this constructor:

    (B (x : Foo) (y : Int) (z : Foo) ...)

We need two random access nodes here, for y and z.
The RAN for y is the start cursor of y, so we use StartOf as a
placeholder here and have Cursorize replace it with the appropriate cursor.
The RAN for z is (starting address of y + 8). Or, (ran_y + 8). We use
AddFixed for this purpose.

'mb_most_recent_ran' in the fold below tracks most recent random access nodes.

-}
mkRANs :: [Exp1] -> PassM [(Var, [()], Ty1, Exp1)]
mkRANs :: [Exp1] -> PassM [(Var, [()], UrTy (), Exp1)]
mkRANs [Exp1]
needRANsExp =
  (Maybe Var, [(Var, [()], UrTy (), Exp1)])
-> [(Var, [()], UrTy (), Exp1)]
forall a b. (a, b) -> b
snd ((Maybe Var, [(Var, [()], UrTy (), Exp1)])
 -> [(Var, [()], UrTy (), Exp1)])
-> PassM (Maybe Var, [(Var, [()], UrTy (), Exp1)])
-> PassM [(Var, [()], UrTy (), Exp1)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe Var, [(Var, [()], UrTy (), Exp1)])
 -> Exp1 -> PassM (Maybe Var, [(Var, [()], UrTy (), Exp1)]))
-> (Maybe Var, [(Var, [()], UrTy (), Exp1)])
-> [Exp1]
-> PassM (Maybe Var, [(Var, [()], UrTy (), Exp1)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\(Maybe Var
mb_most_recent_ran, [(Var, [()], UrTy (), Exp1)]
acc) Exp1
arg -> do
          Var
i <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"ran"
          -- See Note [Reusing RAN's in case expressions]
          let rhs :: Exp1
rhs = case Exp1
arg of
                      VarE Var
v -> E1Ext () (UrTy ()) -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> E1Ext () (UrTy ())
forall loc dec. Var -> E1Ext loc dec
L1.StartOfPkdCursor Var
v)
                      -- It's safe to use 'fromJust' here b/c we would only
                      -- request a RAN for a literal iff it occurs after a
                      -- packed datatype. So there has to be random access
                      -- node that's generated before this.
                      LitE{}    -> E1Ext () (UrTy ()) -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Int -> E1Ext () (UrTy ())
forall loc dec. Var -> Int -> E1Ext loc dec
L1.AddFixed (Maybe Var -> Var
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Var
mb_most_recent_ran) (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
IntTy)))
                      FloatE{}  -> E1Ext () (UrTy ()) -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Int -> E1Ext () (UrTy ())
forall loc dec. Var -> Int -> E1Ext loc dec
L1.AddFixed (Maybe Var -> Var
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Var
mb_most_recent_ran) (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
FloatTy)))
                      LitSymE{} -> E1Ext () (UrTy ()) -> Exp1
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Var -> Int -> E1Ext () (UrTy ())
forall loc dec. Var -> Int -> E1Ext loc dec
L1.AddFixed (Maybe Var -> Var
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Var
mb_most_recent_ran) (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
SymTy)))
                      Exp1
oth -> TyCon -> Exp1
forall a. HasCallStack => TyCon -> a
error (TyCon -> Exp1) -> TyCon -> Exp1
forall a b. (a -> b) -> a -> b
$ TyCon
"addRANExp: Expected trivial expression, got: " TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ Exp1 -> TyCon
forall a. Out a => a -> TyCon
sdoc Exp1
oth
          (Maybe Var, [(Var, [()], UrTy (), Exp1)])
-> PassM (Maybe Var, [(Var, [()], UrTy (), Exp1)])
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
i, [(Var, [()], UrTy (), Exp1)]
acc [(Var, [()], UrTy (), Exp1)]
-> [(Var, [()], UrTy (), Exp1)] -> [(Var, [()], UrTy (), Exp1)]
forall a. [a] -> [a] -> [a]
++ [(Var
i,[],UrTy ()
forall loc. UrTy loc
CursorTy, Exp1
rhs)]))
  (Maybe Var
forall a. Maybe a
Nothing, []) [Exp1]
needRANsExp

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

-- See Note [When does a type needsLRAN]
-- | Collect all types that need random access nodes to be compiled.
needsRAN :: Prog2 -> S.Set TyCon
needsRAN :: Prog2 -> Set TyCon
needsRAN Prog{DDefs (TyOf Exp2)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs :: DDefs (TyOf Exp2)
ddefs,FunDefs Exp2
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs :: FunDefs Exp2
fundefs,Maybe (Exp2, TyOf Exp2)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp :: Maybe (Exp2, TyOf Exp2)
mainExp} =
  let funenv :: TyEnv (ArrowTy (TyOf Exp2))
funenv = FunDefs Exp2 -> TyEnv (ArrowTy (TyOf Exp2))
forall a. FunDefs a -> TyEnv (ArrowTy (TyOf a))
initFunEnv FunDefs Exp2
fundefs

      dofun :: FunDef Exp2 -> Set TyCon
dofun FunDef{[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,ArrowTy (TyOf Exp2)
funTy :: ArrowTy (TyOf Exp2)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy,Exp2
funBody :: forall ex. FunDef ex -> ex
funBody :: Exp2
funBody} =
        let inlocs :: [Var]
inlocs = ArrowTy2 Ty2 -> [Var]
forall ty2. ArrowTy2 ty2 -> [Var]
inLocVars ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
funTy
            eff :: Set Effect
eff = ArrowTy2 Ty2 -> Set Effect
forall ty2. ArrowTy2 ty2 -> Set Effect
arrEffs ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
funTy
        in if Set Var -> Bool
forall a. Set a -> Bool
S.null (([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
inlocs) Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ((Effect -> Var) -> Set Effect -> Set Var
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (\(Traverse Var
v) -> Var
v) Set Effect
eff)) Bool -> Bool -> Bool
&& Bool -> Bool
not (ArrowTy2 Ty2 -> Bool
forall ty2. ArrowTy2 ty2 -> Bool
hasParallelism ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
funTy)
             then Set TyCon
forall a. Set a
S.empty
             else let tyenv :: Map Var Ty2
tyenv = [(Var, Ty2)] -> Map Var Ty2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty2)] -> Map Var Ty2) -> [(Var, Ty2)] -> Map Var Ty2
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty2] -> [(Var, Ty2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy Ty2 -> [Ty2]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf Exp2)
ArrowTy Ty2
funTy)
                      env2 :: Env2 Ty2
env2 = Map Var Ty2 -> TyEnv (ArrowTy Ty2) -> Env2 Ty2
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 Map Var Ty2
tyenv TyEnv (ArrowTy (TyOf Exp2))
TyEnv (ArrowTy Ty2)
funenv
                      renv :: Map Var Var
renv = [(Var, Var)] -> Map Var Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Var)] -> Map Var Var) -> [(Var, Var)] -> Map Var Var
forall a b. (a -> b) -> a -> b
$ (LRM -> (Var, Var)) -> [LRM] -> [(Var, Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\LRM
lrm -> (LRM -> Var
lrmLoc LRM
lrm, Region -> Var
regionToVar (LRM -> Region
lrmReg LRM
lrm))) (ArrowTy2 Ty2 -> [LRM]
forall ty2. ArrowTy2 ty2 -> [LRM]
locVars ArrowTy (TyOf Exp2)
ArrowTy2 Ty2
funTy)
                  in DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs (TyOf Exp2)
DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 Map Var Var
renv TyConEnv
forall k a. Map k a
M.empty [] Exp2
funBody

      funs :: Set TyCon
funs = (FunDef Exp2 -> Set TyCon -> Set TyCon)
-> Set TyCon -> FunDefs Exp2 -> Set TyCon
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr (\FunDef Exp2
f Set TyCon
acc -> Set TyCon
acc Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
`S.union` FunDef Exp2 -> Set TyCon
dofun FunDef Exp2
f) Set TyCon
forall a. Set a
S.empty FunDefs Exp2
fundefs

      mn :: Set TyCon
mn   = case Maybe (Exp2, TyOf Exp2)
mainExp of
               Maybe (Exp2, TyOf Exp2)
Nothing -> Set TyCon
forall a. Set a
S.empty
               Just (Exp2
e,TyOf Exp2
_ty) -> let env2 :: Env2 Ty2
env2 = Map Var Ty2 -> TyEnv (ArrowTy Ty2) -> Env2 Ty2
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 Map Var Ty2
forall k a. Map k a
M.empty TyEnv (ArrowTy (TyOf Exp2))
TyEnv (ArrowTy Ty2)
funenv
                               in DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs (TyOf Exp2)
DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 Map Var Var
forall k a. Map k a
M.empty TyConEnv
forall k a. Map k a
M.empty [] Exp2
e
  in Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
S.union Set TyCon
funs Set TyCon
mn

-- Maps a location to a region
type RegEnv = M.Map LocVar Var
type TyConEnv = M.Map LocVar TyCon

needsRANExp :: DDefs Ty2 -> FunDefs2 -> Env2 Ty2 -> RegEnv -> TyConEnv -> [[LocVar]] -> Exp2 -> S.Set TyCon
needsRANExp :: DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 Map Var Var
renv TyConEnv
tcenv [[Var]]
parlocss Exp2
ex =
  case Exp2
ex of
    CaseE (VarE Var
scrt) [(TyCon, [(Var, Var)], Exp2)]
brs -> let PackedTy TyCon
tycon Var
tyloc = Var -> Env2 Ty2 -> Ty2
forall a. Out a => Var -> Env2 a -> a
lookupVEnv Var
scrt Env2 Ty2
env2
                                 reg :: Var
reg = Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
tyloc
                             in [Set TyCon] -> Set TyCon
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set TyCon] -> Set TyCon) -> [Set TyCon] -> Set TyCon
forall a b. (a -> b) -> a -> b
$ ((TyCon, [(Var, Var)], Exp2) -> Set TyCon)
-> [(TyCon, [(Var, Var)], Exp2)] -> [Set TyCon]
forall a b. (a -> b) -> [a] -> [b]
L.map (TyCon
-> Var
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> (TyCon, [(Var, Var)], Exp2)
-> Set TyCon
doalt TyCon
tycon Var
reg Env2 Ty2
env2 Map Var Var
renv TyConEnv
tcenv [[Var]]
parlocss) [(TyCon, [(Var, Var)], Exp2)]
brs

    CaseE Exp2
scrt [(TyCon, [(Var, Var)], Exp2)]
_ -> TyCon -> Set TyCon
forall a. HasCallStack => TyCon -> a
error (TyCon -> Set TyCon) -> TyCon -> Set TyCon
forall a b. (a -> b) -> a -> b
$ TyCon
"needsRANExp: Scrutinee is not flat " TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ Exp2 -> TyCon
forall a. Out a => a -> TyCon
sdoc Exp2
scrt

    -- Standard recursion here (ASSUMPTION: everything is flat)
    VarE{}     -> Set TyCon
forall a. Set a
S.empty
    LitE{}     -> Set TyCon
forall a. Set a
S.empty
    CharE{}    -> Set TyCon
forall a. Set a
S.empty
    FloatE{}   -> Set TyCon
forall a. Set a
S.empty
    LitSymE{}  -> Set TyCon
forall a. Set a
S.empty
    -- We do not process the function body here, assuming that the main analysis does it.
    AppE{}     -> Set TyCon
forall a. Set a
S.empty
    PrimAppE{} -> Set TyCon
forall a. Set a
S.empty

{-

If we have an expression:

    case blah of
      C x y z ->
        a = spawn (foo x)
        b = spawn (foo y)
        c = spawn (foo z)
        sync
        ...

we need to be able to access x, y and z in parallel, and thus need random access
for the type 'blah'. To spot these cases, we look at the regions in which
x, y and z live. In this case expression, they would all be in 1 single region.
So we say that if there are any region that is shared among the things in 'par',
we need random access for that type.

-}
    LetE (Var
v,[Var]
_,Ty2
ty,rhs :: Exp2
rhs@(SpawnE{})) Exp2
bod ->
      let mp :: TyConEnv
mp   = Env2 Ty2 -> Exp2 -> TyConEnv
parAppLoc Env2 Ty2
env2 Exp2
rhs
          locs :: [Var]
locs = TyConEnv -> [Var]
forall k a. Map k a -> [k]
M.keys TyConEnv
mp
          parlocss' :: [[Var]]
parlocss' = [Var]
locs [Var] -> [[Var]] -> [[Var]]
forall a. a -> [a] -> [a]
: [[Var]]
parlocss
      in DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs (Var -> Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty2
ty Env2 Ty2
env2) Map Var Var
renv (TyConEnv
mp TyConEnv -> TyConEnv -> TyConEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` TyConEnv
tcenv) [[Var]]
parlocss' Exp2
bod

    LetE (Var
v,[Var]
_,Ty2
ty,Exp2
SyncE) Exp2
bod ->
      let s_bod :: Set TyCon
s_bod = DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs (Var -> Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty2
ty Env2 Ty2
env2) Map Var Var
renv TyConEnv
tcenv [] Exp2
bod
          regss :: [[Var]]
regss = ([Var] -> [Var]) -> [[Var]] -> [[Var]]
forall a b. (a -> b) -> [a] -> [b]
map ((Var -> Var) -> [Var] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
#)) [[Var]]
parlocss
          deleteAt :: Int -> [a] -> [a]
deleteAt Int
idx [a]
xs = let ([a]
lft, (a
_:[a]
rgt)) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [a]
xs
                            in [a]
lft [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rgt
          common_regs :: Set Var
common_regs = [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Var] -> Set Var) -> [Set Var] -> Set Var
forall a b. (a -> b) -> a -> b
$ ((Int, [Var]) -> Set Var) -> [(Int, [Var])] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
map
                          (\(Int
i,[Var]
rs) -> let all_other_regs :: [Var]
all_other_regs = [[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [[Var]] -> [[Var]]
forall a. Int -> [a] -> [a]
deleteAt Int
i [[Var]]
regss)
                                      in Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.intersection ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
rs) ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [Var]
all_other_regs))
                          ([Int] -> [[Var]] -> [(Int, [Var])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [[Var]]
regss)
      in if Set Var -> Bool
forall a. Set a -> Bool
S.null Set Var
common_regs
         then Set TyCon
forall a. Set a
S.empty
         else let want_ran_locs :: [Var]
want_ran_locs = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\Var
lc -> (Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
lc) Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Var
common_regs) ([[Var]] -> [Var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Var]]
parlocss)
              in Set TyCon
s_bod Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
`S.union` ([TyCon] -> Set TyCon
forall a. Ord a => [a] -> Set a
S.fromList ([TyCon] -> Set TyCon) -> [TyCon] -> Set TyCon
forall a b. (a -> b) -> a -> b
$ (Var -> TyCon) -> [Var] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (TyConEnv
tcenv TyConEnv -> Var -> TyCon
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
#) [Var]
want_ran_locs)

    SpawnE{} -> TyCon -> Set TyCon
forall a. HasCallStack => TyCon -> a
error TyCon
"needsRANExp: Unbound SpawnE"
    Exp2
SyncE    -> TyCon -> Set TyCon
forall a. HasCallStack => TyCon -> a
error TyCon
"needsRANExp: Unbound SyncE"

    LetE(Var
v,[Var]
_,Ty2
ty,Exp2
rhs) Exp2
bod -> Exp2 -> Set TyCon
go Exp2
rhs Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
`S.union`
                            DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs (Var -> Ty2 -> Env2 Ty2 -> Env2 Ty2
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty2
ty Env2 Ty2
env2) Map Var Var
renv TyConEnv
tcenv [[Var]]
parlocss Exp2
bod
    IfE Exp2
_a Exp2
b Exp2
c -> Exp2 -> Set TyCon
go Exp2
b Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp2 -> Set TyCon
go Exp2
c
    MkProdE{}  -> Set TyCon
forall a. Set a
S.empty
    ProjE{}    -> Set TyCon
forall a. Set a
S.empty
    DataConE{} -> Set TyCon
forall a. Set a
S.empty
    TimeIt{}   -> Set TyCon
forall a. Set a
S.empty
    WithArenaE{} -> Set TyCon
forall a. Set a
S.empty

    Ext E2Ext Var Ty2
ext ->
      case E2Ext Var Ty2
ext of
        LetRegionE Region
_ RegionSize
_ Maybe RegionType
_ Exp2
bod -> Exp2 -> Set TyCon
go Exp2
bod
        LetParRegionE Region
_ RegionSize
_ Maybe RegionType
_ Exp2
bod -> Exp2 -> Set TyCon
go Exp2
bod
        L2.StartOfPkdCursor{} -> Set TyCon
forall a. Set a
S.empty
        LetLocE Var
_loc PreLocExp Var
FreeLE Exp2
bod -> Exp2 -> Set TyCon
go Exp2
bod
        LetLocE Var
loc PreLocExp Var
rhs Exp2
bod  ->
            let reg :: Var
reg = case PreLocExp Var
rhs of
                        StartOfRegionLE Region
r  -> Region -> Var
regionToVar Region
r
                        InRegionLE Region
r -> Region -> Var
regionToVar Region
r
                        AfterConstantLE Int
_ Var
lc   -> Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
lc
                        AfterVariableLE Var
_ Var
lc Bool
_ -> Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
lc
                        FromEndLE Var
lc           -> Map Var Var
renv Map Var Var -> Var -> Var
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
lc -- TODO: This needs to be fixed
            in DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 (Var -> Var -> Map Var Var -> Map Var Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc Var
reg Map Var Var
renv) TyConEnv
tcenv [[Var]]
parlocss Exp2
bod
        E2Ext Var Ty2
_ -> Set TyCon
forall a. Set a
S.empty
    MapE{}     -> Set TyCon
forall a. Set a
S.empty
    FoldE{}    -> Set TyCon
forall a. Set a
S.empty
  where
    go :: Exp2 -> Set TyCon
go = DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 Map Var Var
renv TyConEnv
tcenv [[Var]]
parlocss

    -- Collect all the 'Tycon's which might random access nodes
    doalt :: TyCon
-> Var
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> (TyCon, [(Var, Var)], Exp2)
-> Set TyCon
doalt TyCon
tycon Var
reg Env2 Ty2
env21 Map Var Var
renv1 TyConEnv
tcenv1 [[Var]]
parlocss1 br :: (TyCon, [(Var, Var)], Exp2)
br@(TyCon
dcon,[(Var, Var)]
vlocs,Exp2
bod) =
      let ([Var]
vars,[Var]
locs) = [(Var, Var)] -> ([Var], [Var])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Var)]
vlocs
          renv' :: Map Var Var
renv' = (Var -> Map Var Var -> Map Var Var)
-> Map Var Var -> [Var] -> Map Var Var
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
lc Map Var Var
acc -> Var -> Var -> Map Var Var -> Map Var Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
lc Var
reg Map Var Var
acc) Map Var Var
renv1 [Var]
locs
          env21' :: Env2 Ty2
env21' = HasCallStack =>
TyCon -> DDefs Ty2 -> [Var] -> [Var] -> Env2 Ty2 -> Env2 Ty2
TyCon -> DDefs Ty2 -> [Var] -> [Var] -> Env2 Ty2 -> Env2 Ty2
extendPatternMatchEnv TyCon
dcon DDefs Ty2
ddefs [Var]
vars [Var]
locs Env2 Ty2
env21
          ran_for_scrt :: Set TyCon
ran_for_scrt = case (DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> (TyCon, [(Var, Var)], Exp2)
-> Maybe [(Var, Var)]
needsTraversalCase DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env2 (TyCon, [(Var, Var)], Exp2)
br) of
                           Maybe [(Var, Var)]
Nothing -> Set TyCon
forall a. Set a
S.empty
                           Just{}  -> TyCon -> Set TyCon
forall a. a -> Set a
S.singleton TyCon
tycon
      in Set TyCon
ran_for_scrt Set TyCon -> Set TyCon -> Set TyCon
forall a. Ord a => Set a -> Set a -> Set a
`S.union` DDefs Ty2
-> FunDefs Exp2
-> Env2 Ty2
-> Map Var Var
-> TyConEnv
-> [[Var]]
-> Exp2
-> Set TyCon
needsRANExp DDefs Ty2
ddefs FunDefs Exp2
fundefs Env2 Ty2
env21' Map Var Var
renv' TyConEnv
tcenv1 [[Var]]
parlocss1 Exp2
bod

    -- Return the location and tycon of an argument to a function call.
    parAppLoc :: Env2 Ty2 -> Exp2 -> M.Map LocVar TyCon
    parAppLoc :: Env2 Ty2 -> Exp2 -> TyConEnv
parAppLoc Env2 Ty2
env21 (SpawnE Var
_ [Var]
_ [Exp2]
args) =
      let fn :: UrTy a -> [(a, TyCon)]
fn (PackedTy TyCon
dcon a
loc) = [(a
loc, TyCon
dcon)]
          fn (ProdTy [UrTy a]
tys1) = (UrTy a -> [(a, TyCon)]) -> [UrTy a] -> [(a, TyCon)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap UrTy a -> [(a, TyCon)]
fn [UrTy a]
tys1
          fn UrTy a
_ = []

          tys :: [Ty2]
tys = (Exp2 -> Ty2) -> [Exp2] -> [Ty2]
forall a b. (a -> b) -> [a] -> [b]
map (DDefs (TyOf Exp2) -> Env2 (TyOf Exp2) -> Exp2 -> TyOf Exp2
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf Exp2)
DDefs Ty2
ddefs Env2 (TyOf Exp2)
Env2 Ty2
env21) [Exp2]
args
      in [(Var, TyCon)] -> TyConEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Ty2 -> [(Var, TyCon)]) -> [Ty2] -> [(Var, TyCon)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty2 -> [(Var, TyCon)]
forall {a}. UrTy a -> [(a, TyCon)]
fn [Ty2]
tys)
    parAppLoc Env2 Ty2
_ Exp2
oth = TyCon -> TyConEnv
forall a. HasCallStack => TyCon -> a
error (TyCon -> TyConEnv) -> TyCon -> TyConEnv
forall a b. (a -> b) -> a -> b
$ TyCon
"parAppLoc: Cannot handle "  TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ Exp2 -> TyCon
forall a. Out a => a -> TyCon
sdoc Exp2
oth

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

{-| Given a datatype, generate a copy-like function. But instead of just copying
the input value, it udpates constructors to have size information, and also
relative offsets. Assumes that this function will always be called on a value
written to a contiguous region. Chunked regions are not supported.

For example, for the Tree datatype it'll generate a function like this:

data Tree = Leaf Int | Node Tree Tree | Node* Int Int Tree Tree

_add_size_and_rel_offsets_Tree :: Tree -> Tree
_add_size_and_rel_offsets_Tree tr =
  case tr of
    Leaf i          -> Leaf i
    Node left right ->
      let left'  = _add_size_and_rel_offsets_Tree left
          right' = _add_size_and_rel_offsets_Tree right
          size   = sizeof(left') + sizeof(right') + 1 + 8 + 8
          offset_right = sizeof(left')
      in Node* size offset_right left' right'

For a different datatype;

data Foo = K1 | K2 Foo Foo Foo | K2* Int Int Int Tree Tree Tree

_add_size_and_rel_offsets_Foo :: Foo -> Foo
_add_size_and_rel_offsets_Foo foo =
  case foo of
    K1 -> K1
    K2 a b c ->
      let a' = _add_size_and_rel_offsets_Foo a
          b' = _add_size_and_rel_offsets_Foo b
          c' = _add_size_and_rel_offsets_Foo c
          size = 1 + 8 + 8 + 8 + sizeof(a') + sizeof(b') + sizeof(c')
          offset_b = 8 + sizeof(a')
          offset_c = sizeof(a') + sizeof(b')
      in K2* size offset_b offset_c a' b' c'

-}
genRelOffsetsFunNameFn :: S.Set TyCon -> DDefs Ty1 -> DDef Ty1 -> PassM FunDef1
genRelOffsetsFunNameFn :: Set TyCon -> DDefs (UrTy ()) -> DDef (UrTy ()) -> PassM FunDef1
genRelOffsetsFunNameFn Set TyCon
needRANsTyCons DDefs (UrTy ())
ddfs DDef{Var
tyName :: Var
tyName :: forall a. DDef a -> Var
tyName, [(TyCon, [(Bool, UrTy ())])]
dataCons :: forall a. DDef a -> [(TyCon, [(Bool, a)])]
dataCons :: [(TyCon, [(Bool, UrTy ())])]
dataCons} = do
  Var
arg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ Var
"arg"
  [(TyCon, [(Var, ())], Exp1)]
casebod <- [(TyCon, [(Bool, UrTy ())])]
-> ((TyCon, [(Bool, UrTy ())]) -> PassM (TyCon, [(Var, ())], Exp1))
-> PassM [(TyCon, [(Var, ())], Exp1)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TyCon, [(Bool, UrTy ())])]
dataCons (((TyCon, [(Bool, UrTy ())]) -> PassM (TyCon, [(Var, ())], Exp1))
 -> PassM [(TyCon, [(Var, ())], Exp1)])
-> ((TyCon, [(Bool, UrTy ())]) -> PassM (TyCon, [(Var, ())], Exp1))
-> PassM [(TyCon, [(Var, ())], Exp1)]
forall a b. (a -> b) -> a -> b
$ \(TyCon
dcon, [(Bool, UrTy ())]
dtys) ->
             do let tys :: [UrTy ()]
tys = ((Bool, UrTy ()) -> UrTy ()) -> [(Bool, UrTy ())] -> [UrTy ()]
forall a b. (a -> b) -> [a] -> [b]
L.map (Bool, UrTy ()) -> UrTy ()
forall a b. (a, b) -> b
snd [(Bool, UrTy ())]
dtys
                [Var]
xs <- (UrTy () -> PassM Var) -> [UrTy ()] -> 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 (\UrTy ()
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"x") [UrTy ()]
tys
                [Var]
ys <- (UrTy () -> PassM Var) -> [UrTy ()] -> 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 (\UrTy ()
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"y") [UrTy ()]
tys
                let num_offsets :: Int
num_offsets = DDefs (UrTy ()) -> TyCon -> Int
forall a. Out a => DDefs (UrTy a) -> TyCon -> Int
numRANsDataCon DDefs (UrTy ())
ddfs TyCon
dcon
                Exp1
bod <- do
                       let bod0 :: Exp1 -> Exp1
bod0 Exp1
acc = ((UrTy (), Var, Var) -> Exp1 -> Exp1)
-> Exp1 -> [(UrTy (), Var, 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 (\(UrTy ()
ty,Var
x,Var
y) Exp1
acc ->
                                               if UrTy () -> Bool
forall a. UrTy a -> Bool
isPackedTy UrTy ()
ty
                                               then (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], UrTy ()
ty, Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE (TyCon -> Var
mkRelOffsetsFunName (UrTy () -> TyCon
forall a. Show a => UrTy a -> TyCon
tyToDataCon UrTy ()
ty)) [] [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x]) Exp1
acc
                                               else (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
y, [], UrTy ()
ty, Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x) Exp1
acc)
                                            Exp1
acc
                                            ([UrTy ()] -> [Var] -> [Var] -> [(UrTy (), Var, Var)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
L.zip3 [UrTy ()]
tys [Var]
xs [Var]
ys)
                       if Bool -> Bool
not (TyCon -> Set TyCon -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Var -> TyCon
fromVar Var
tyName) Set TyCon
needRANsTyCons) then 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
bod0 (() -> TyCon -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> TyCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () TyCon
dcon ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys))
                       else if Int
num_offsets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                       -- Nothing much to do. Just recursively process all the packed arguments.
                       then 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
bod0 (() -> TyCon -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> TyCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () TyCon
dcon ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
ys))
                       -- We have to add a size field, and offsets in addition to recursively processing
                       -- the packed arguments.
                       else do
                         [Var]
size_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
y -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ TyCon -> Var
toVar (TyCon -> Var) -> TyCon -> Var
forall a b. (a -> b) -> a -> b
$ TyCon
"sizeof_" TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ Var -> TyCon
fromVar Var
y TyCon -> TyCon -> TyCon
forall a. [a] -> [a] -> [a]
++ TyCon
"_") [Var]
ys
                         let size_binds :: Exp1 -> Exp1
size_binds Exp1
acc = ((Var, Var, UrTy ()) -> Exp1 -> Exp1)
-> Exp1 -> [(Var, Var, UrTy ())] -> 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
sz,Var
y,UrTy ()
ty) Exp1
acc ->
                                                     if UrTy () -> Bool
forall a. UrTy a -> Bool
isPackedTy UrTy ()
ty
                                                     then (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
sz,[],UrTy ()
forall loc. UrTy loc
IntTy,Prim (UrTy ()) -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim (UrTy ())
forall ty. Prim ty
RequestSizeOf [Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
y]) Exp1
acc
                                                     else (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
sz,[],UrTy ()
forall loc. UrTy loc
IntTy,Int -> Exp1
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy () -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy ()
ty)) Exp1
acc)
                                                Exp1
acc ([Var] -> [Var] -> [UrTy ()] -> [(Var, Var, UrTy ())]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
L.zip3 [Var]
size_vars [Var]
ys [UrTy ()]
tys)
                         [Var]
offset_vars <- (Int -> PassM Var) -> [Int] -> 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 (\Int
_ -> Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"offset_") [Int
0..(Int
num_offsetsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]
                         let need_offsets :: [Var]
need_offsets = [Var] -> [Var]
forall a. [a] -> [a]
reverse ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ Int -> [Var] -> [Var]
forall a. Int -> [a] -> [a]
L.take Int
num_offsets ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
xs)
                         let addp :: [Var] -> PreExp ext loc dec
addp [Var]
ls = case [Var]
ls of
                                         []       -> Int -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
0
                                         (Var
x:Var
y:[]) -> Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim dec
forall ty. Prim ty
AddP [Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x, Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
y]
                                         (Var
x:[Var]
rst)  -> Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim dec
forall ty. Prim ty
AddP [Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
x, [Var] -> PreExp ext loc dec
addp [Var]
rst]
                         let offset_binds :: Exp1 -> Exp1
offset_binds Exp1
acc = ((Var, Var) -> Exp1 -> Exp1) -> Exp1 -> [(Var, 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
ov, Var
x) Exp1
acc ->
                                                     let idx_of_x :: Int
idx_of_x    = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Var -> [Var] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Var
x [Var]
xs
                                                         idx_of_ov :: Int
idx_of_ov   = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Var -> [Var] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Var
ov [Var]
offset_vars
                                                         offsets_infront :: Int
offsets_infront = [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> [Var] -> [Var]
forall a. Int -> [a] -> [a]
L.drop Int
idx_of_ov [Var]
offset_vars) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                                         have_to_add :: [Var]
have_to_add = Int -> [Var] -> [Var]
forall a. Int -> [a] -> [a]
L.take Int
idx_of_x [Var]
size_vars
                                                         rhs :: Exp1
rhs = Prim (UrTy ()) -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim (UrTy ())
forall ty. Prim ty
AddP [Int -> Exp1
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE (Int -> Exp1) -> Int -> Exp1
forall a b. (a -> b) -> a -> b
$ (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
IntTy)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
offsets_infront,
                                                                              [Var] -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
[Var] -> PreExp ext loc dec
addp [Var]
have_to_add]
                                                     in (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
ov,[],UrTy ()
forall loc. UrTy loc
IntTy,Exp1
rhs) Exp1
acc)
                                                  Exp1
acc ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
offset_vars [Var]
need_offsets)
                         Var
dcon_size <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"size_dcon"
                         let size_offsets :: Exp1
size_offsets = Int -> Exp1
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE (Int -> Exp1) -> Int -> Exp1
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (UrTy Any -> Maybe Int
forall a. UrTy a -> Maybe Int
sizeOfTy UrTy Any
forall loc. UrTy loc
IntTy)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
offset_vars
                             dcon_size_bind :: Exp1 -> Exp1
dcon_size_bind Exp1
acc = (Var, [()], UrTy (), Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
dcon_size,[],UrTy ()
forall loc. UrTy loc
IntTy, Prim (UrTy ()) -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim (UrTy ())
forall ty. Prim ty
AddP [Exp1
size_offsets, [Var] -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
[Var] -> PreExp ext loc dec
addp [Var]
size_vars] ) Exp1
acc
                             dcon_args :: [Var]
dcon_args = [Var
dcon_size] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
offset_vars [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++  [Var]
ys
                             dcon' :: TyCon
dcon' = TyCon -> TyCon
toRelRANDataCon TyCon
dcon
                         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
bod0 (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Exp1
size_binds (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Exp1
offset_binds (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Exp1
dcon_size_bind (Exp1 -> Exp1) -> Exp1 -> Exp1
forall a b. (a -> b) -> a -> b
$ () -> TyCon -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> TyCon -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE () TyCon
dcon' ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE [Var]
dcon_args)
                (TyCon, [(Var, ())], Exp1) -> PassM (TyCon, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
dcon, (Var -> (Var, ())) -> [Var] -> [(Var, ())]
forall a b. (a -> b) -> [a] -> [b]
L.map (\Var
x -> (Var
x,())) [Var]
xs, Exp1
bod)

  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef1 -> PassM FunDef1) -> FunDef1 -> PassM FunDef1
forall a b. (a -> b) -> a -> b
$ FunDef { funName :: Var
funName = TyCon -> Var
mkRelOffsetsFunName (Var -> TyCon
fromVar Var
tyName)
                  , funArgs :: [Var]
funArgs = [Var
arg]
                  , funTy :: ArrowTy (TyOf Exp1)
funTy   = ( [TyCon -> () -> UrTy ()
forall loc. TyCon -> loc -> UrTy loc
PackedTy (Var -> TyCon
fromVar Var
tyName) ()], TyCon -> () -> UrTy ()
forall loc. TyCon -> loc -> UrTy loc
PackedTy (Var -> TyCon
fromVar Var
tyName) () )
                  , funBody :: Exp1
funBody = Exp1 -> [(TyCon, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(TyCon, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
arg) [(TyCon, [(Var, ())], Exp1)]
casebod
                  , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
Rec
                                      , funInline :: FunInline
funInline = FunInline
NoInline
                                      , funCanTriggerGC :: Bool
funCanTriggerGC = Bool
False
                                      }
                  }