{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

-- | Interpreter reducing L2 programs to values.
module Gibbon.L2.Interp -- ( interpProg, interp )
where

import           Control.DeepSeq
import           Control.Monad.Writer
import           Control.Monad.State
import           Control.Monad
import           Data.ByteString.Builder (Builder, toLazyByteString, string8)
import           Data.Foldable (foldlM)
import           System.Clock
import           Text.PrettyPrint.GenericPretty
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Sequence as S
import           Data.Sequence (Seq, ViewL(..))
import           Data.Word (Word8)
import           Data.Char ( ord )
import           Data.Foldable as F
import           Data.Maybe ( fromJust )

import           Gibbon.Common
import           Gibbon.Passes.Lower ( getTagOfDataCon )
import qualified Gibbon.L1.Interp as L1
import           Gibbon.L2.Syntax as L2

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

instance Interp Store Exp2 where
  gInterpExp :: RunConfig
-> ValEnv Exp2
-> DDefs (TyOf Exp2)
-> FunDefs Exp2
-> Exp2
-> InterpM Store Exp2 (Value Exp2)
gInterpExp RunConfig
rc ValEnv Exp2
valenv DDefs (TyOf Exp2)
ddefs FunDefs Exp2
fenv Exp2
ext = (Value Exp2, Size) -> Value Exp2
forall a b. (a, b) -> a
fst ((Value Exp2, Size) -> Value Exp2)
-> InterpM Store Exp2 (Value Exp2, Size)
-> InterpM Store Exp2 (Value Exp2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
interp SizeEnv
forall k a. Map k a
M.empty RunConfig
rc ValEnv Exp2
valenv DDefs (TyOf Exp2)
DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv Exp2
ext

instance InterpExt Store Exp2 (E2Ext LocVar Ty2) where
  gInterpExt :: RunConfig
-> ValEnv Exp2
-> DDefs (TyOf Exp2)
-> FunDefs Exp2
-> E2Ext Var (UrTy Var)
-> InterpM Store Exp2 (Value Exp2)
gInterpExt RunConfig
rc ValEnv Exp2
valenv DDefs (TyOf Exp2)
ddefs FunDefs Exp2
fenv E2Ext Var (UrTy Var)
ext = (Value Exp2, Size) -> Value Exp2
forall a b. (a, b) -> a
fst ((Value Exp2, Size) -> Value Exp2)
-> InterpM Store Exp2 (Value Exp2, Size)
-> InterpM Store Exp2 (Value Exp2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> E2Ext Var (UrTy Var)
-> InterpM Store Exp2 (Value Exp2, Size)
interpExt SizeEnv
forall k a. Map k a
M.empty RunConfig
rc ValEnv Exp2
valenv DDefs (TyOf Exp2)
DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv E2Ext Var (UrTy Var)
ext

instance InterpProg Store Exp2 where
  gInterpProg :: Store
-> RunConfig -> Prog Exp2 -> IO (Store, Value Exp2, ByteString)
gInterpProg Store
store RunConfig
rc Prog{DDefs (TyOf Exp2)
ddefs :: DDefs (TyOf Exp2)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs,FunDefs Exp2
fundefs :: FunDefs Exp2
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs,Maybe (Exp2, TyOf Exp2)
mainExp :: Maybe (Exp2, TyOf Exp2)
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} =
      case Maybe (Exp2, TyOf Exp2)
mainExp of
        -- Print nothing, return "void"
        Maybe (Exp2, TyOf Exp2)
Nothing -> (Store, Value Exp2, ByteString)
-> IO (Store, Value Exp2, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Store
store, [Value Exp2] -> Value Exp2
forall e. [Value e] -> Value e
VProd [], ByteString
B.empty)
        Just (Exp2
e,TyOf Exp2
_) -> do
          let fenv :: FunDefs Exp2
fenv = [(Var, FunDef Exp2)] -> FunDefs Exp2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (FunDef Exp2 -> Var
forall ex. FunDef ex -> Var
funName FunDef Exp2
f , FunDef Exp2
f) | FunDef Exp2
f <- FunDefs Exp2 -> [FunDef Exp2]
forall k a. Map k a -> [a]
M.elems FunDefs Exp2
fundefs]
          ((Value Exp2
v, Size
_size),InterpLog
logs,Store
store1) <- InterpM Store Exp2 (Value Exp2, Size)
-> Store -> IO ((Value Exp2, Size), InterpLog, Store)
forall s e a. InterpM s e a -> s -> IO (a, InterpLog, s)
runInterpM (SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
interp SizeEnv
forall k a. Map k a
M.empty RunConfig
rc ValEnv Exp2
forall k a. Map k a
M.empty DDefs (TyOf Exp2)
DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv Exp2
e) Store
store
          -- Policy: don't return locations
          let res :: Value Exp2
res = case Value Exp2
v of
                        (VLoc Var
reg Int
off) ->
                            let buf :: Buffer
buf = Maybe Buffer -> Buffer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Buffer -> Buffer) -> Maybe Buffer -> Buffer
forall a b. (a -> b) -> a -> b
$ Var -> Store -> Maybe Buffer
lookupInStore' Var
reg Store
store1
                            in DDefs (UrTy Var) -> Store -> Buffer -> Value Exp2
forall ty. Out ty => DDefs ty -> Store -> Buffer -> Value Exp2
deserialize DDefs (TyOf Exp2)
DDefs (UrTy Var)
ddefs Store
store1 (Int -> Buffer -> Buffer
dropInBuffer Int
off Buffer
buf)
                        Value Exp2
oth -> Value Exp2
oth
          (Store, Value Exp2, ByteString)
-> IO (Store, Value Exp2, ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Store
store1, Value Exp2
res, InterpLog -> ByteString
toLazyByteString InterpLog
logs)


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

interp :: SizeEnv -> RunConfig -> ValEnv Exp2 -> DDefs Ty2 -> M.Map Var (FunDef Exp2)
       -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
interp :: SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
interp SizeEnv
szenv RunConfig
rc ValEnv Exp2
valenv DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv Exp2
e = ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
valenv SizeEnv
szenv Exp2
e
  where
    {-# NOINLINE goWrapper #-}
    goWrapper :: Word64
-> ValEnv Exp2
-> SizeEnv
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
goWrapper !Word64
_ix ValEnv Exp2
env SizeEnv
sizeEnv Exp2
ex = ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
ex

    go :: ValEnv Exp2 -> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
    go :: ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
ex =
      case Exp2
ex of
        -- We interpret a function application by substituting the operand (at
        -- the call-site) for the function argument in the environment. Since
        -- this is a L2 program, we have real locations (and regions) and we
        -- have to make sure that those get passed in as well. We do that
        -- by extending the environment with the location at the call-site.
        --
        -- TODO: After ThreadRegions, even regions are passed in the locs
        -- field. Need to extend the environment with some kind of region
        -- value as well. Also, since we're storing regions in the value
        -- environment anyways, we probably don't need an additional store.
        --
        AppE Var
f [Var]
locs [Exp2]
args ->
          case Var -> FunDefs Exp2 -> Maybe (FunDef Exp2)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
f FunDefs Exp2
fenv of
            Maybe (FunDef Exp2)
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: unbound function: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
ex
            Just FunDef{[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,Exp2
funBody :: Exp2
funBody :: forall ex. FunDef ex -> ex
funBody,ArrowTy (TyOf Exp2)
funTy :: ArrowTy (TyOf Exp2)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy} -> do
              ([Value Exp2]
rands,[Size]
szs) <- [(Value Exp2, Size)] -> ([Value Exp2], [Size])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Value Exp2, Size)] -> ([Value Exp2], [Size]))
-> InterpM Store Exp2 [(Value Exp2, Size)]
-> InterpM Store Exp2 ([Value Exp2], [Size])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp2 -> InterpM Store Exp2 (Value Exp2, Size))
-> [Exp2] -> InterpM Store Exp2 [(Value Exp2, Size)]
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 (ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv) [Exp2]
args
              let inLocs :: [Var]
inLocs  = ArrowTy2 (UrTy Var) -> [Var]
forall ty2. ArrowTy2 ty2 -> [Var]
inLocVars ArrowTy (TyOf Exp2)
ArrowTy2 (UrTy Var)
funTy
                  outLocs :: [Var]
outLocs = ArrowTy2 (UrTy Var) -> [Var]
forall ty2. ArrowTy2 ty2 -> [Var]
outLocVars ArrowTy (TyOf Exp2)
ArrowTy2 (UrTy Var)
funTy
                  -- ASSUMPTION: Ordering is important in `locs`, and we assume
                  -- that the input locations appear before output locations.
                  env' :: ValEnv Exp2
env' = ((Var, Var) -> ValEnv Exp2 -> ValEnv Exp2)
-> ValEnv Exp2 -> [(Var, Var)] -> ValEnv Exp2
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                           (\(Var
fnLoc, Var
callSiteLoc) ValEnv Exp2
acc ->
                              Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
fnLoc (ValEnv Exp2
acc ValEnv Exp2 -> Var -> Value Exp2
forall k a. Ord k => Map k a -> k -> a
M.! Var
callSiteLoc)  ValEnv Exp2
acc)
                           ValEnv Exp2
env
                           ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Var]
inLocs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
outLocs) [Var]
locs)
              ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go (ValEnv Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ([(Var, Value Exp2)] -> ValEnv Exp2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Value Exp2)] -> ValEnv Exp2)
-> [(Var, Value Exp2)] -> ValEnv Exp2
forall a b. (a -> b) -> a -> b
$ [Var] -> [Value Exp2] -> [(Var, Value Exp2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs [Value Exp2]
rands) ValEnv Exp2
env')
                 (SizeEnv -> SizeEnv -> SizeEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ([(Var, Size)] -> SizeEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Size)] -> SizeEnv) -> [(Var, Size)] -> SizeEnv
forall a b. (a -> b) -> a -> b
$ [Var] -> [Size] -> [(Var, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs [Size]
szs) SizeEnv
sizeEnv)
                 Exp2
funBody

        CaseE Exp2
_ [] -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Empty case"
        CaseE Exp2
x1 [(String, [(Var, Var)], Exp2)]
alts -> do
          (Value Exp2
scrt, Size
_sizescrt) <- ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
x1
          String -> InterpM Store Exp2 () -> InterpM Store Exp2 ()
forall a. String -> a -> a
dbgTraceIt ((Exp2, Value Exp2, ValEnv Exp2, SizeEnv) -> String
forall a. Out a => a -> String
sdoc (Exp2
x1,Value Exp2
scrt,ValEnv Exp2
env,SizeEnv
sizeEnv)) (() -> InterpM Store Exp2 ()
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          case Value Exp2
scrt of
            VLoc Var
idx Int
off ->
               do (Store Map Var Buffer
store) <- InterpM Store Exp2 Store
forall s (m :: * -> *). MonadState s m => m s
get
                  let Buffer Seq SerializedVal
seq1 = Map Var Buffer
store Map Var Buffer -> Var -> Buffer
forall k a. Ord k => Map k a -> k -> a
M.! Var
idx
                  case Seq SerializedVal -> ViewL SerializedVal
forall a. Seq a -> ViewL a
S.viewl (Int -> Seq SerializedVal -> Seq SerializedVal
forall a. Int -> Seq a -> Seq a
S.drop Int
off Seq SerializedVal
seq1) of
                    ViewL SerializedVal
S.EmptyL -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error String
"L1.Interp: case scrutinize on empty/out-of-bounds location."
                    SerTag Word8
_tg String
datacon :< Seq SerializedVal
_rst -> do
                      let -- tycon = getTyOfDataCon ddefs datacon
                          (String
_dcon,[(Var, Var)]
vlocs,Exp2
rhs) = String
-> [(String, [(Var, Var)], Exp2)] -> (String, [(Var, Var)], Exp2)
forall k a b.
(Eq k, Show k, Show a, Show b) =>
k -> [(k, a, b)] -> (k, a, b)
lookup3 (Int -> String -> String -> String
forall a. Int -> String -> a -> a
dbgTrace Int
3 (String -> String
forall a. Show a => a -> String
show String
datacon String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, [(Var, Var)], Exp2)] -> String
forall a. Show a => a -> String
show [(String, [(Var, Var)], Exp2)]
alts) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
datacon) [(String, [(Var, Var)], Exp2)]
alts
                          tys :: [UrTy Var]
tys = DDefs (UrTy Var) -> String -> [UrTy Var]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs (UrTy Var)
ddefs String
datacon
                      (ValEnv Exp2
env', SizeEnv
sizeEnv', Int
_off') <- ((ValEnv Exp2, SizeEnv, Int)
 -> ((Var, Var), UrTy Var)
 -> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int))
-> (ValEnv Exp2, SizeEnv, Int)
-> [((Var, Var), UrTy Var)]
-> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
                                (\(ValEnv Exp2
aenv, SizeEnv
asizeEnv, Int
prev_off) ((Var
v,Var
loc), UrTy Var
ty) -> do
                                    case UrTy Var
ty of
                                      -- Just skip past random access nodes.
                                      UrTy Var
CursorTy -> do
                                          let sizeloc :: Int
sizeloc = 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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
CursorTy
                                              aenv' :: ValEnv Exp2
aenv' = Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
idx Int
prev_off) ValEnv Exp2
aenv
                                              asizeEnv' :: SizeEnv
asizeEnv' = Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Int -> Size
SOne Int
sizeloc) SizeEnv
asizeEnv
                                          (ValEnv Exp2, SizeEnv, Int)
-> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValEnv Exp2
aenv', SizeEnv
asizeEnv', Int
prev_off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeloc)
                                      -- Traverse this value to find it's end-witness and use
                                      -- it to bind the value after this one.
                                      PackedTy String
pkd_tycon Var
_ -> do
                                          let current_val :: Value Exp2
current_val = Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
idx Int
prev_off
                                              aenv' :: ValEnv Exp2
aenv' = Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Value Exp2
current_val (ValEnv Exp2 -> ValEnv Exp2) -> ValEnv Exp2 -> ValEnv Exp2
forall a b. (a -> b) -> a -> b
$
                                                      Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc Value Exp2
current_val (ValEnv Exp2 -> ValEnv Exp2) -> ValEnv Exp2 -> ValEnv Exp2
forall a b. (a -> b) -> a -> b
$
                                                      ValEnv Exp2
aenv
                                          let trav_fn :: Var
trav_fn = String -> Var
mkTravFunName String
pkd_tycon
                                          -- Bind v to (SOne -1) in sizeEnv temporarily, just long enough
                                          -- to evaluate the call to trav_fn.
                                          (Value Exp2
_, Size
sizev) <- ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
aenv' (Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v (Int -> Size
SOne (-Int
1)) SizeEnv
sizeEnv) (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
trav_fn [Var
loc] [Var -> Exp2
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v])
                                          let sizeloc :: Int
sizeloc = 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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
CursorTy
                                              asizeEnv' :: SizeEnv
asizeEnv' = Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Size
sizev (SizeEnv -> SizeEnv) -> SizeEnv -> SizeEnv
forall a b. (a -> b) -> a -> b
$
                                                          Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Int -> Size
SOne Int
sizeloc) (SizeEnv -> SizeEnv) -> SizeEnv -> SizeEnv
forall a b. (a -> b) -> a -> b
$
                                                          SizeEnv
asizeEnv
                                          String -> InterpM Store Exp2 () -> InterpM Store Exp2 ()
forall a. String -> a -> a
dbgTraceIt ((Var, Int, Size, Int) -> String
forall a. Out a => a -> String
sdoc (Var
v, Int
prev_off, Size
sizev, Int
prev_off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Size -> Int
sizeToInt Size
sizev))) (() -> InterpM Store Exp2 ()
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                                          (ValEnv Exp2, SizeEnv, Int)
-> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValEnv Exp2
aenv', SizeEnv
asizeEnv', Int
prev_off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Size -> Int
sizeToInt Size
sizev))
                                      UrTy Var
scalarty | UrTy Var -> Bool
forall a. UrTy a -> Bool
isScalarTy UrTy Var
scalarty -> do
                                        s :: Store
s@(Store Map Var Buffer
store1) <- InterpM Store Exp2 Store
forall s (m :: * -> *). MonadState s m => m s
get
                                        let buf :: Buffer
buf = Map Var Buffer
store1 Map Var Buffer -> Var -> Buffer
forall k a. Ord k => Map k a -> k -> a
M.! Var
idx
                                            val :: Value Exp2
val  = DDefs (UrTy Var) -> Store -> Buffer -> Value Exp2
forall ty. Out ty => DDefs ty -> Store -> Buffer -> Value Exp2
deserialize DDefs (UrTy Var)
ddefs Store
s (Int -> Buffer -> Buffer
dropInBuffer Int
prev_off Buffer
buf)
                                            aenv' :: ValEnv Exp2
aenv' = Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Value Exp2
val (ValEnv Exp2 -> ValEnv Exp2) -> ValEnv Exp2 -> ValEnv Exp2
forall a b. (a -> b) -> a -> b
$
                                                    Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
idx Int
prev_off) (ValEnv Exp2 -> ValEnv Exp2) -> ValEnv Exp2 -> ValEnv Exp2
forall a b. (a -> b) -> a -> b
$
                                                    ValEnv Exp2
aenv
                                            size :: Int
size = (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ UrTy Var -> Maybe Int
forall d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Var
scalarty)
                                            asizeEnv' :: SizeEnv
asizeEnv' = Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v (Int -> Size
SOne Int
size) SizeEnv
asizeEnv
                                        (ValEnv Exp2, SizeEnv, Int)
-> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValEnv Exp2
aenv', SizeEnv
asizeEnv', Int
prev_off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
                                      UrTy Var
_ -> String -> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int))
-> String -> InterpM Store Exp2 (ValEnv Exp2, SizeEnv, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UrTy Var -> String
forall a. Out a => a -> String
sdoc UrTy Var
ty)
                                (ValEnv Exp2
env, SizeEnv
sizeEnv, Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                                ([(Var, Var)] -> [UrTy Var] -> [((Var, Var), UrTy Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Var, Var)]
vlocs [UrTy Var]
tys)
                      ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env' SizeEnv
sizeEnv' Exp2
rhs
                    SerializedVal
oth :< Seq SerializedVal
_ -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: expected to read tag from scrutinee cursor, found: "String -> String -> String
forall a. [a] -> [a] -> [a]
++SerializedVal -> String
forall a. Show a => a -> String
show SerializedVal
othString -> String -> String
forall a. [a] -> [a] -> [a]
++
                                        String
".\nRead " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
scrt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in buffer: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seq SerializedVal -> String
forall a. Out a => a -> String
sdoc Seq SerializedVal
seq1
            Value Exp2
_ -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: expected scrutinee to be a packed value. Got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
scrt

        -- This operation constructs a packed value by writing things to the
        -- buffer. The packed value is represented by a 1 byte tag,
        -- followed by other arguments.
        DataConE Var
loc String
dcon [Exp2]
args ->
          case Var -> ValEnv Exp2 -> Maybe (Value Exp2)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
loc ValEnv Exp2
env of
            Maybe (Value Exp2)
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unbound location: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc
            Just (VLoc Var
reg Int
offset) -> do
              Maybe Buffer
buf_maybe <- Var -> InterpM Store Exp2 (Maybe Buffer)
lookupInStore Var
reg
              case Maybe Buffer
buf_maybe of
                Maybe Buffer
Nothing  -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unbound region " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
reg
                Just Buffer
buf -> do
                  [(Value Exp2, Size)]
vals <- (Exp2 -> InterpM Store Exp2 (Value Exp2, Size))
-> [Exp2] -> InterpM Store Exp2 [(Value Exp2, Size)]
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 (ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv) [Exp2]
args
                  let tys :: [UrTy Var]
tys = DDefs (UrTy Var) -> String -> [UrTy Var]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs (UrTy Var)
ddefs String
dcon
                      tag :: Word8
tag = DDefs (UrTy Var) -> String -> Word8
forall a. Out a => DDefs a -> String -> Word8
getTagOfDataCon DDefs (UrTy Var)
ddefs String
dcon
                      bufWithTag :: Buffer
bufWithTag = Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer Int
offset (Word8 -> String -> SerializedVal
SerTag Word8
tag String
dcon) Buffer
buf
                      (Buffer
bufWithVals, Int
new_off) =
                        ((Buffer, Int) -> ((Value Exp2, Size), UrTy Var) -> (Buffer, Int))
-> (Buffer, Int)
-> [((Value Exp2, Size), UrTy Var)]
-> (Buffer, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                          (\(Buffer
acc, Int
off) ((Value Exp2
v, Size
sz), UrTy Var
_ty) ->
                               let new_off1 :: Int
new_off1 = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Size -> Int
sizeToInt Size
sz
                                   f :: Value Exp2 -> (Buffer, Int)
f Value Exp2
v2 =
                                     case Value Exp2
v2 of
                                       VInt Int
i -> ( Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer Int
off (Int -> SerializedVal
SerInt Int
i) Buffer
acc , Int
new_off1 )
                                       VChar Char
i -> ( Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer Int
off (Char -> SerializedVal
SerChar Char
i) Buffer
acc , Int
new_off1 )
                                       VFloat{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VSym{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VBool{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       -- This is a packed value, and it must already
                                       -- be written to the buffer (by the thing that
                                       -- returned this). So we just update the offset
                                       -- to point to the end of this value.
                                       VLoc{} -> ( Buffer
acc , Int
new_off1 )
                                       VPtr Var
buf_id Int
off1 -> ( Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer Int
off (Var -> Int -> SerializedVal
SerPtr Var
buf_id Int
off1) Buffer
acc, Int
new_off1)
                                       VDict{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VProd{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VList{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VPacked{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VCursor{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VLam{} -> String -> (Buffer, Int)
forall a. HasCallStack => String -> a
error (String -> (Buffer, Int)) -> String -> (Buffer, Int)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: DataConE todo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
v2
                                       VWrapId Int
_id2 Value Exp2
v3 -> Value Exp2 -> (Buffer, Int)
f Value Exp2
v3
                               in Value Exp2 -> (Buffer, Int)
f Value Exp2
v
                          )
                          (Buffer
bufWithTag, Int
offsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                          ([(Value Exp2, Size)]
-> [UrTy Var] -> [((Value Exp2, Size), UrTy Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Value Exp2, Size)]
vals [UrTy Var]
tys)
                  Var -> Buffer -> InterpM Store Exp2 ()
insertIntoStore Var
reg Buffer
bufWithVals
                  (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
reg Int
offset, Int -> Size
SOne (Int
new_off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset))
            Just Value Exp2
val -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unexpected value for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
val

        -- Ignoring end-witnesses atm.
        LetE (Var
v,[Var]
_locs,UrTy Var
_ty,Exp2
rhs) Exp2
bod -> do
          (Value Exp2
rhs', Size
sz) <- ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
rhs
          ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go (Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Value Exp2
rhs' ValEnv Exp2
env) (Var -> Size -> SizeEnv -> SizeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Size
sz SizeEnv
sizeEnv) Exp2
bod
        -- Straightforward recursion (same as the L1 interpreter)
        Ext E2Ext Var (UrTy Var)
ext -> SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> E2Ext Var (UrTy Var)
-> InterpM Store Exp2 (Value Exp2, Size)
interpExt SizeEnv
sizeEnv RunConfig
rc ValEnv Exp2
env DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv E2Ext Var (UrTy Var)
ext
        LitE Int
n    -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value Exp2
forall e. Int -> Value e
VInt Int
n, Int -> Size
SOne (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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
IntTy))
        CharE Char
n   -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Value Exp2
forall e. Char -> Value e
VChar Char
n, Int -> Size
SOne (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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
CharTy))
        FloatE Double
n  -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value Exp2
forall e. Double -> Value e
VFloat Double
n, Int -> Size
SOne (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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
FloatTy))
        LitSymE Var
s -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value Exp2
forall e. Int -> Value e
VInt (String -> Int
strToInt (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Var -> String
fromVar Var
s),
                             Int -> Size
SOne (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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
SymTy))
        VarE Var
v    -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValEnv Exp2
env ValEnv Exp2 -> Var -> Value Exp2
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v, SizeEnv
sizeEnv SizeEnv -> Var -> Size
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v)

        PrimAppE Prim (UrTy Var)
p [Exp2]
args -> do
            ([Value Exp2]
args',[Size]
_) <- [(Value Exp2, Size)] -> ([Value Exp2], [Size])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Value Exp2, Size)] -> ([Value Exp2], [Size]))
-> InterpM Store Exp2 [(Value Exp2, Size)]
-> InterpM Store Exp2 ([Value Exp2], [Size])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp2 -> InterpM Store Exp2 (Value Exp2, Size))
-> [Exp2] -> InterpM Store Exp2 [(Value Exp2, Size)]
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 (ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv) [Exp2]
args
            case UrTy Var -> Maybe Int
forall d. UrTy d -> Maybe Int
byteSizeOfTy (Prim (UrTy Var) -> UrTy Var
forall a. Prim (UrTy a) -> UrTy a
primRetTy Prim (UrTy Var)
p) of
              Just Int
sz -> do
                  Value Exp2
val <- RunConfig
-> Prim (UrTy Var)
-> [Value Exp2]
-> InterpM Store Exp2 (Value Exp2)
forall ty l d (e :: * -> * -> *) s.
(Show ty, Ord l, Out l, Show l, Show d, Out d, Ord d, Ord (e l d),
 Out (e l d), Show (e l d)) =>
RunConfig
-> Prim ty
-> [Value (PreExp e l d)]
-> InterpM s (PreExp e l d) (Value (PreExp e l d))
L1.applyPrim RunConfig
rc Prim (UrTy Var)
p [Value Exp2]
args'
                  (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Exp2
val, Int -> Size
SOne Int
sz)
              Maybe Int
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Couldn't guess the size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
ex

        IfE Exp2
a Exp2
b Exp2
c -> do (Value Exp2
v,Size
_) <- ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
a
                        case Value Exp2
v of
                         VBool Bool
flg -> if Bool
flg
                                      then ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
b
                                      else ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
c
                         Value Exp2
oth -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error(String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"interp: expected bool, got: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Value Exp2 -> String
forall a. Show a => a -> String
show Value Exp2
oth

        MkProdE [Exp2]
ls -> do
            ([Value Exp2]
args, [Size]
szs) <- [(Value Exp2, Size)] -> ([Value Exp2], [Size])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Value Exp2, Size)] -> ([Value Exp2], [Size]))
-> InterpM Store Exp2 [(Value Exp2, Size)]
-> InterpM Store Exp2 ([Value Exp2], [Size])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp2 -> InterpM Store Exp2 (Value Exp2, Size))
-> [Exp2] -> InterpM Store Exp2 [(Value Exp2, Size)]
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 (ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv) [Exp2]
ls
            (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value Exp2] -> Value Exp2
forall e. [Value e] -> Value e
VProd [Value Exp2]
args , [Size] -> Size
SMany [Size]
szs)

        ProjE Int
ix Exp2
e0 -> do
            (Value Exp2, Size)
val <- ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
e0
            case (Value Exp2, Size)
val of
              (VProd [Value Exp2]
ls, SMany [Size]
szs) -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value Exp2]
ls [Value Exp2] -> Int -> Value Exp2
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix, [Size]
szs [Size] -> Int -> Size
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix)
              (VProd [Value Exp2]
ls, SOne Int
sz)   -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value Exp2]
ls [Value Exp2] -> Int -> Value Exp2
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix, Int -> Size
SOne Int
sz)
              (Value Exp2, Size)
oth -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: expected VProd, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Exp2, (Value Exp2, Size)) -> String
forall a. Out a => a -> String
sdoc (Exp2
ex, (Value Exp2, Size)
oth)

        TimeIt Exp2
bod UrTy Var
_ Bool
isIter -> do
              let iters :: Word64
iters = if Bool
isIter then RunConfig -> Word64
rcIters RunConfig
rc else Word64
1
              !ValEnv Exp2
_ <- ValEnv Exp2 -> InterpM Store Exp2 (ValEnv Exp2)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValEnv Exp2 -> InterpM Store Exp2 (ValEnv Exp2))
-> ValEnv Exp2 -> InterpM Store Exp2 (ValEnv Exp2)
forall a b. (a -> b) -> a -> b
$! ValEnv Exp2 -> ValEnv Exp2
forall a. NFData a => a -> a
force ValEnv Exp2
env
              TimeSpec
st <- IO TimeSpec -> InterpM Store Exp2 TimeSpec
forall a. IO a -> InterpM Store Exp2 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeSpec -> InterpM Store Exp2 TimeSpec)
-> IO TimeSpec -> InterpM Store Exp2 TimeSpec
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
getTime Clock
clk
              (Value Exp2
val,Size
sz) <- ((Value Exp2, Size)
 -> Word64 -> InterpM Store Exp2 (Value Exp2, Size))
-> (Value Exp2, Size)
-> [Word64]
-> InterpM Store Exp2 (Value Exp2, Size)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ (Value Exp2, Size)
_ Word64
i -> Word64
-> ValEnv Exp2
-> SizeEnv
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
goWrapper Word64
i ValEnv Exp2
env SizeEnv
sizeEnv Exp2
bod)
                            (String -> (Value Exp2, Size)
forall a. HasCallStack => String -> a
error String
"Internal error: this should be unused.")
                          [Word64
1..Word64
iters]
              TimeSpec
en <- IO TimeSpec -> InterpM Store Exp2 TimeSpec
forall a. IO a -> InterpM Store Exp2 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeSpec -> InterpM Store Exp2 TimeSpec)
-> IO TimeSpec -> InterpM Store Exp2 TimeSpec
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
getTime Clock
clk
              let tm :: Double
tm = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs (TimeSpec -> Integer) -> TimeSpec -> Integer
forall a b. (a -> b) -> a -> b
$ TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec TimeSpec
en TimeSpec
st)
                        Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10e9 :: Double
              if Bool
isIter
               then do InterpLog -> InterpM Store Exp2 ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell(InterpLog -> InterpM Store Exp2 ())
-> InterpLog -> InterpM Store Exp2 ()
forall a b. (a -> b) -> a -> b
$ String -> InterpLog
string8 (String -> InterpLog) -> String -> InterpLog
forall a b. (a -> b) -> a -> b
$ String
"ITERS: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Word64 -> String
forall a. Show a => a -> String
show Word64
iters       String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
                       InterpLog -> InterpM Store Exp2 ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell(InterpLog -> InterpM Store Exp2 ())
-> InterpLog -> InterpM Store Exp2 ()
forall a b. (a -> b) -> a -> b
$ String -> InterpLog
string8 (String -> InterpLog) -> String -> InterpLog
forall a b. (a -> b) -> a -> b
$ String
"SIZE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (RunConfig -> Int
rcSize RunConfig
rc) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
                       InterpLog -> InterpM Store Exp2 ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell(InterpLog -> InterpM Store Exp2 ())
-> InterpLog -> InterpM Store Exp2 ()
forall a b. (a -> b) -> a -> b
$ String -> InterpLog
string8 (String -> InterpLog) -> String -> InterpLog
forall a b. (a -> b) -> a -> b
$ String
"BATCHTIME: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
tm      String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
               else InterpLog -> InterpM Store Exp2 ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell(InterpLog -> InterpM Store Exp2 ())
-> InterpLog -> InterpM Store Exp2 ()
forall a b. (a -> b) -> a -> b
$ String -> InterpLog
string8 (String -> InterpLog) -> String -> InterpLog
forall a b. (a -> b) -> a -> b
$ String
"SELFTIMED: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
tm String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
              (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size))
-> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$! (Value Exp2
val, Size
sz)

        SpawnE Var
f [Var]
locs [Exp2]
args -> ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv (Var -> [Var] -> [Exp2] -> Exp2
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Var]
locs [Exp2]
args)
        Exp2
SyncE -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size))
-> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ (Int -> Value Exp2
forall e. Int -> Value e
VInt (-Int
1), Int -> Size
SOne Int
0)

        WithArenaE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error String
"L2.Interp: WithArenE not handled"

        MapE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
ex
        FoldE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp2 -> String
forall a. Out a => a -> String
sdoc Exp2
ex

{-
          DataConE _ k ls -> do
              args <- mapM (go env) ls
              return $ VPacked k args
              -- Constructors are overloaded.  They have different behavior depending on
              -- whether we are AFTER Cursorize or not.
              case args of
                [ VCursor idx off ] | rcCursors rc ->
                    do Store store <- get
                       let tag       = SerTag (getTagOfDataCon ddefs k) k
                           store'    = IM.alter (\(Just (Buffer s1)) -> Just (Buffer $ s1 |> tag)) idx store
                       put (Store store')
                       return $ VCursor idx (off+1)
                _ -> return $ VPacked k args


-}

interpExt :: SizeEnv -> RunConfig -> ValEnv Exp2 -> DDefs Ty2 -> M.Map Var (FunDef Exp2)
           -> E2Ext LocVar Ty2 -> InterpM Store Exp2 (Value Exp2, Size)
interpExt :: SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> E2Ext Var (UrTy Var)
-> InterpM Store Exp2 (Value Exp2, Size)
interpExt SizeEnv
sizeEnv RunConfig
rc ValEnv Exp2
env DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv E2Ext Var (UrTy Var)
ext =
  case E2Ext Var (UrTy Var)
ext of
    LetRegionE Region
reg RegionSize
_ Maybe RegionType
_ Exp2
bod -> do
      Var -> Buffer -> InterpM Store Exp2 ()
insertIntoStore (Region -> Var
regionToVar Region
reg) Buffer
emptyBuffer
      ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
env SizeEnv
sizeEnv Exp2
bod

    LetParRegionE Region
reg RegionSize
sz Maybe RegionType
ty Exp2
bod ->
      SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> E2Ext Var (UrTy Var)
-> InterpM Store Exp2 (Value Exp2, Size)
interpExt SizeEnv
sizeEnv RunConfig
rc ValEnv Exp2
env DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv (Region
-> RegionSize -> Maybe RegionType -> Exp2 -> E2Ext Var (UrTy Var)
forall loc dec.
Region
-> RegionSize -> Maybe RegionType -> E2 loc dec -> E2Ext loc dec
LetRegionE Region
reg RegionSize
sz Maybe RegionType
ty Exp2
bod)

    LetLocE Var
loc PreLocExp Var
locexp Exp2
bod ->
      case PreLocExp Var
locexp of
        StartOfRegionLE Region
reg -> do
          Maybe Buffer
buf_maybe <- Var -> InterpM Store Exp2 (Maybe Buffer)
lookupInStore (Region -> Var
regionToVar Region
reg)
          case Maybe Buffer
buf_maybe of
            Maybe Buffer
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unbound region: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Region -> String
forall a. Out a => a -> String
sdoc Region
reg
            Just Buffer
_ ->
              ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go (Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc (Region -> Var
regionToVar Region
reg) Int
0) ValEnv Exp2
env) SizeEnv
sizeEnv Exp2
bod

        AfterConstantLE Int
i Var
loc2 -> do
          case Var -> ValEnv Exp2 -> Maybe (Value Exp2)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
loc2 ValEnv Exp2
env of
            Maybe (Value Exp2)
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unbound location: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc2
            Just (VLoc Var
reg Int
offset) ->
              ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go (Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
reg (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)) ValEnv Exp2
env) SizeEnv
sizeEnv Exp2
bod
            Just Value Exp2
val ->
              String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unexpected value for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
val

        AfterVariableLE Var
v Var
loc2 Bool
_ -> do
          case Var -> ValEnv Exp2 -> Maybe (Value Exp2)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
loc2 ValEnv Exp2
env of
            Maybe (Value Exp2)
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unbound location: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc2
            Just (VLoc Var
reg Int
offset) ->
              case Var -> SizeEnv -> Maybe Size
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v SizeEnv
sizeEnv of
                Maybe Size
Nothing -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: No size info found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
v
                Just Size
sz ->
                  ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go (Var -> Value Exp2 -> ValEnv Exp2 -> ValEnv Exp2
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
loc (Var -> Int -> Value Exp2
forall e. Var -> Int -> Value e
VLoc Var
reg (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Size -> Int
sizeToInt Size
sz))) ValEnv Exp2
env)
                     SizeEnv
sizeEnv Exp2
bod
            Just Value Exp2
val ->
              String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: Unexpected value for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
forall a. Out a => a -> String
sdoc Var
loc2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value Exp2 -> String
forall a. Out a => a -> String
sdoc Value Exp2
val

        FromEndLE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
        InRegionLE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
        FreeLE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext


    -- Ignoring end-witnesses atm.
    StartOfPkdCursor{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    TagCursor{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    RetE [Var]
_locs Var
v -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValEnv Exp2
env ValEnv Exp2 -> Var -> Value Exp2
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v, SizeEnv
sizeEnv SizeEnv -> Var -> Size
forall a b.
(Ord a, Out a, Out b, Show a, HasCallStack) =>
Map a b -> a -> b
# Var
v)
    FromEndE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    BoundsCheck{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    AddFixed{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    IndirectionE{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    GetCilkWorkerNum{} -> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a. a -> InterpM Store Exp2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size))
-> (Value Exp2, Size) -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ (Int -> Value Exp2
forall e. Int -> Value e
VInt Int
1, Int -> Size
SOne (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 d. UrTy d -> Maybe Int
byteSizeOfTy UrTy Any
forall loc. UrTy loc
IntTy))
    LetAvail{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    AllocateTagHere{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    AllocateScalarsHere{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    SSPush{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext
    SSPop{} -> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a. HasCallStack => String -> a
error (String -> InterpM Store Exp2 (Value Exp2, Size))
-> String -> InterpM Store Exp2 (Value Exp2, Size)
forall a b. (a -> b) -> a -> b
$ String
"L2.Interp: TODO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ E2Ext Var (UrTy Var) -> String
forall a. Out a => a -> String
sdoc E2Ext Var (UrTy Var)
ext

  where
    go :: ValEnv Exp2
-> SizeEnv -> Exp2 -> InterpM Store Exp2 (Value Exp2, Size)
go ValEnv Exp2
valenv SizeEnv
szenv = SizeEnv
-> RunConfig
-> ValEnv Exp2
-> DDefs (UrTy Var)
-> FunDefs Exp2
-> Exp2
-> InterpM Store Exp2 (Value Exp2, Size)
interp SizeEnv
szenv RunConfig
rc ValEnv Exp2
valenv DDefs (UrTy Var)
ddefs FunDefs Exp2
fenv


clk :: Clock
clk :: Clock
clk = Clock
Monotonic

strToInt :: String -> Int
strToInt :: String -> Int
strToInt = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Int] -> Int) -> (String -> [Int]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord

--------------------------------------------------------------------------------
-- Stores and buffers:
--------------------------------------------------------------------------------

-- | A store is an address space full of buffers.
newtype Store = Store (M.Map Var Buffer)
  deriving (ReadPrec [Store]
ReadPrec Store
Int -> ReadS Store
ReadS [Store]
(Int -> ReadS Store)
-> ReadS [Store]
-> ReadPrec Store
-> ReadPrec [Store]
-> Read Store
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Store
readsPrec :: Int -> ReadS Store
$creadList :: ReadS [Store]
readList :: ReadS [Store]
$creadPrec :: ReadPrec Store
readPrec :: ReadPrec Store
$creadListPrec :: ReadPrec [Store]
readListPrec :: ReadPrec [Store]
Read, Int -> Store -> String -> String
[Store] -> String -> String
Store -> String
(Int -> Store -> String -> String)
-> (Store -> String) -> ([Store] -> String -> String) -> Show Store
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Store -> String -> String
showsPrec :: Int -> Store -> String -> String
$cshow :: Store -> String
show :: Store -> String
$cshowList :: [Store] -> String -> String
showList :: [Store] -> String -> String
Show, Store -> Store -> Bool
(Store -> Store -> Bool) -> (Store -> Store -> Bool) -> Eq Store
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Store -> Store -> Bool
== :: Store -> Store -> Bool
$c/= :: Store -> Store -> Bool
/= :: Store -> Store -> Bool
Eq, Eq Store
Eq Store
-> (Store -> Store -> Ordering)
-> (Store -> Store -> Bool)
-> (Store -> Store -> Bool)
-> (Store -> Store -> Bool)
-> (Store -> Store -> Bool)
-> (Store -> Store -> Store)
-> (Store -> Store -> Store)
-> Ord Store
Store -> Store -> Bool
Store -> Store -> Ordering
Store -> Store -> Store
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Store -> Store -> Ordering
compare :: Store -> Store -> Ordering
$c< :: Store -> Store -> Bool
< :: Store -> Store -> Bool
$c<= :: Store -> Store -> Bool
<= :: Store -> Store -> Bool
$c> :: Store -> Store -> Bool
> :: Store -> Store -> Bool
$c>= :: Store -> Store -> Bool
>= :: Store -> Store -> Bool
$cmax :: Store -> Store -> Store
max :: Store -> Store -> Store
$cmin :: Store -> Store -> Store
min :: Store -> Store -> Store
Ord, (forall x. Store -> Rep Store x)
-> (forall x. Rep Store x -> Store) -> Generic Store
forall x. Rep Store x -> Store
forall x. Store -> Rep Store x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Store -> Rep Store x
from :: forall x. Store -> Rep Store x
$cto :: forall x. Rep Store x -> Store
to :: forall x. Rep Store x -> Store
Generic, Int -> Store -> Doc
[Store] -> Doc
Store -> Doc
(Int -> Store -> Doc)
-> (Store -> Doc) -> ([Store] -> Doc) -> Out Store
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> Store -> Doc
docPrec :: Int -> Store -> Doc
$cdoc :: Store -> Doc
doc :: Store -> Doc
$cdocList :: [Store] -> Doc
docList :: [Store] -> Doc
Out)

emptyStore :: Store
emptyStore :: Store
emptyStore = Map Var Buffer -> Store
Store Map Var Buffer
forall k a. Map k a
M.empty

insertIntoStore :: Var -> Buffer -> InterpM Store Exp2 ()
insertIntoStore :: Var -> Buffer -> InterpM Store Exp2 ()
insertIntoStore Var
v Buffer
buf = (Store -> Store) -> InterpM Store Exp2 ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\(Store Map Var Buffer
x) -> Map Var Buffer -> Store
Store (Var -> Buffer -> Map Var Buffer -> Map Var Buffer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v Buffer
buf Map Var Buffer
x))

lookupInStore :: Var -> InterpM Store Exp2 (Maybe Buffer)
lookupInStore :: Var -> InterpM Store Exp2 (Maybe Buffer)
lookupInStore Var
v = do
  Store Map Var Buffer
store <- InterpM Store Exp2 Store
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe Buffer -> InterpM Store Exp2 (Maybe Buffer)
forall a. a -> InterpM Store Exp2 a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Buffer -> InterpM Store Exp2 (Maybe Buffer))
-> Maybe Buffer -> InterpM Store Exp2 (Maybe Buffer)
forall a b. (a -> b) -> a -> b
$ Var -> Map Var Buffer -> Maybe Buffer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v Map Var Buffer
store

lookupInStore' :: Var -> Store -> Maybe Buffer
lookupInStore' :: Var -> Store -> Maybe Buffer
lookupInStore' Var
reg (Store Map Var Buffer
mp) = Var -> Map Var Buffer -> Maybe Buffer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
reg Map Var Buffer
mp

newtype Buffer = Buffer (Seq SerializedVal)
  deriving (ReadPrec [Buffer]
ReadPrec Buffer
Int -> ReadS Buffer
ReadS [Buffer]
(Int -> ReadS Buffer)
-> ReadS [Buffer]
-> ReadPrec Buffer
-> ReadPrec [Buffer]
-> Read Buffer
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Buffer
readsPrec :: Int -> ReadS Buffer
$creadList :: ReadS [Buffer]
readList :: ReadS [Buffer]
$creadPrec :: ReadPrec Buffer
readPrec :: ReadPrec Buffer
$creadListPrec :: ReadPrec [Buffer]
readListPrec :: ReadPrec [Buffer]
Read, Int -> Buffer -> String -> String
[Buffer] -> String -> String
Buffer -> String
(Int -> Buffer -> String -> String)
-> (Buffer -> String)
-> ([Buffer] -> String -> String)
-> Show Buffer
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Buffer -> String -> String
showsPrec :: Int -> Buffer -> String -> String
$cshow :: Buffer -> String
show :: Buffer -> String
$cshowList :: [Buffer] -> String -> String
showList :: [Buffer] -> String -> String
Show, Buffer -> Buffer -> Bool
(Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool) -> Eq Buffer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Buffer -> Buffer -> Bool
== :: Buffer -> Buffer -> Bool
$c/= :: Buffer -> Buffer -> Bool
/= :: Buffer -> Buffer -> Bool
Eq, Eq Buffer
Eq Buffer
-> (Buffer -> Buffer -> Ordering)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Buffer)
-> (Buffer -> Buffer -> Buffer)
-> Ord Buffer
Buffer -> Buffer -> Bool
Buffer -> Buffer -> Ordering
Buffer -> Buffer -> Buffer
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Buffer -> Buffer -> Ordering
compare :: Buffer -> Buffer -> Ordering
$c< :: Buffer -> Buffer -> Bool
< :: Buffer -> Buffer -> Bool
$c<= :: Buffer -> Buffer -> Bool
<= :: Buffer -> Buffer -> Bool
$c> :: Buffer -> Buffer -> Bool
> :: Buffer -> Buffer -> Bool
$c>= :: Buffer -> Buffer -> Bool
>= :: Buffer -> Buffer -> Bool
$cmax :: Buffer -> Buffer -> Buffer
max :: Buffer -> Buffer -> Buffer
$cmin :: Buffer -> Buffer -> Buffer
min :: Buffer -> Buffer -> Buffer
Ord, (forall x. Buffer -> Rep Buffer x)
-> (forall x. Rep Buffer x -> Buffer) -> Generic Buffer
forall x. Rep Buffer x -> Buffer
forall x. Buffer -> Rep Buffer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Buffer -> Rep Buffer x
from :: forall x. Buffer -> Rep Buffer x
$cto :: forall x. Rep Buffer x -> Buffer
to :: forall x. Rep Buffer x -> Buffer
Generic, Int -> Buffer -> Doc
[Buffer] -> Doc
Buffer -> Doc
(Int -> Buffer -> Doc)
-> (Buffer -> Doc) -> ([Buffer] -> Doc) -> Out Buffer
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> Buffer -> Doc
docPrec :: Int -> Buffer -> Doc
$cdoc :: Buffer -> Doc
doc :: Buffer -> Doc
$cdocList :: [Buffer] -> Doc
docList :: [Buffer] -> Doc
Out)

emptyBuffer :: Buffer
emptyBuffer :: Buffer
emptyBuffer = Seq SerializedVal -> Buffer
Buffer Seq SerializedVal
forall a. Seq a
S.empty

-- | Insert a value at a particular index in the buffer
insertAtBuffer :: Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer :: Int -> SerializedVal -> Buffer -> Buffer
insertAtBuffer Int
i SerializedVal
v (Buffer Seq SerializedVal
b) =
    if Int
expected_size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    then Seq SerializedVal -> Buffer
Buffer Seq SerializedVal
b'
    -- We must make 'v' occupy 'expected_size' number of cells in the buffer.
    else
      let pad :: Int
pad = Int
expected_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          b'' :: Seq SerializedVal
b'' = (Seq SerializedVal -> Int -> Seq SerializedVal)
-> Seq SerializedVal -> [Int] -> Seq SerializedVal
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Seq SerializedVal
acc Int
j -> Int -> SerializedVal -> Seq SerializedVal -> Seq SerializedVal
forall a. Int -> a -> Seq a -> Seq a
S.insertAt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j) SerializedVal
SerPad Seq SerializedVal
acc) Seq SerializedVal
b' [Int
1..Int
pad]
      in Seq SerializedVal -> Buffer
Buffer Seq SerializedVal
b''
  where
    expected_size :: Int
expected_size = SerializedVal -> Int
byteSize SerializedVal
v
    b' :: Seq SerializedVal
b' = Int -> SerializedVal -> Seq SerializedVal -> Seq SerializedVal
forall a. Int -> a -> Seq a -> Seq a
S.insertAt Int
i SerializedVal
v Seq SerializedVal
b

dropInBuffer :: Int -> Buffer -> Buffer
dropInBuffer :: Int -> Buffer -> Buffer
dropInBuffer Int
off (Buffer Seq SerializedVal
ls) = Seq SerializedVal -> Buffer
Buffer (Int -> Seq SerializedVal -> Seq SerializedVal
forall a. Int -> Seq a -> Seq a
S.drop Int
off Seq SerializedVal
ls)

data SerializedVal
    = SerTag Word8 DataCon
    | SerInt Int
    | SerChar Char
    | SerBool Int
    | SerFloat Double
    | SerPtr { SerializedVal -> Var
bufID :: Var, SerializedVal -> Int
offset :: Int }
    | SerPad
    -- ^ Used to make values artificially occupy more cells in the buffer.
    -- For example, everywhere else we assume that Ints occupy 8 cells.
    -- But 'SerInt' only occupies a single cell. To make 'SerInt' occupy 8
    -- cells, we add 7 'SerPad's after it.
  deriving (ReadPrec [SerializedVal]
ReadPrec SerializedVal
Int -> ReadS SerializedVal
ReadS [SerializedVal]
(Int -> ReadS SerializedVal)
-> ReadS [SerializedVal]
-> ReadPrec SerializedVal
-> ReadPrec [SerializedVal]
-> Read SerializedVal
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SerializedVal
readsPrec :: Int -> ReadS SerializedVal
$creadList :: ReadS [SerializedVal]
readList :: ReadS [SerializedVal]
$creadPrec :: ReadPrec SerializedVal
readPrec :: ReadPrec SerializedVal
$creadListPrec :: ReadPrec [SerializedVal]
readListPrec :: ReadPrec [SerializedVal]
Read, Int -> SerializedVal -> String -> String
[SerializedVal] -> String -> String
SerializedVal -> String
(Int -> SerializedVal -> String -> String)
-> (SerializedVal -> String)
-> ([SerializedVal] -> String -> String)
-> Show SerializedVal
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SerializedVal -> String -> String
showsPrec :: Int -> SerializedVal -> String -> String
$cshow :: SerializedVal -> String
show :: SerializedVal -> String
$cshowList :: [SerializedVal] -> String -> String
showList :: [SerializedVal] -> String -> String
Show, SerializedVal -> SerializedVal -> Bool
(SerializedVal -> SerializedVal -> Bool)
-> (SerializedVal -> SerializedVal -> Bool) -> Eq SerializedVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SerializedVal -> SerializedVal -> Bool
== :: SerializedVal -> SerializedVal -> Bool
$c/= :: SerializedVal -> SerializedVal -> Bool
/= :: SerializedVal -> SerializedVal -> Bool
Eq, Eq SerializedVal
Eq SerializedVal
-> (SerializedVal -> SerializedVal -> Ordering)
-> (SerializedVal -> SerializedVal -> Bool)
-> (SerializedVal -> SerializedVal -> Bool)
-> (SerializedVal -> SerializedVal -> Bool)
-> (SerializedVal -> SerializedVal -> Bool)
-> (SerializedVal -> SerializedVal -> SerializedVal)
-> (SerializedVal -> SerializedVal -> SerializedVal)
-> Ord SerializedVal
SerializedVal -> SerializedVal -> Bool
SerializedVal -> SerializedVal -> Ordering
SerializedVal -> SerializedVal -> SerializedVal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SerializedVal -> SerializedVal -> Ordering
compare :: SerializedVal -> SerializedVal -> Ordering
$c< :: SerializedVal -> SerializedVal -> Bool
< :: SerializedVal -> SerializedVal -> Bool
$c<= :: SerializedVal -> SerializedVal -> Bool
<= :: SerializedVal -> SerializedVal -> Bool
$c> :: SerializedVal -> SerializedVal -> Bool
> :: SerializedVal -> SerializedVal -> Bool
$c>= :: SerializedVal -> SerializedVal -> Bool
>= :: SerializedVal -> SerializedVal -> Bool
$cmax :: SerializedVal -> SerializedVal -> SerializedVal
max :: SerializedVal -> SerializedVal -> SerializedVal
$cmin :: SerializedVal -> SerializedVal -> SerializedVal
min :: SerializedVal -> SerializedVal -> SerializedVal
Ord, (forall x. SerializedVal -> Rep SerializedVal x)
-> (forall x. Rep SerializedVal x -> SerializedVal)
-> Generic SerializedVal
forall x. Rep SerializedVal x -> SerializedVal
forall x. SerializedVal -> Rep SerializedVal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SerializedVal -> Rep SerializedVal x
from :: forall x. SerializedVal -> Rep SerializedVal x
$cto :: forall x. Rep SerializedVal x -> SerializedVal
to :: forall x. Rep SerializedVal x -> SerializedVal
Generic, Int -> SerializedVal -> Doc
[SerializedVal] -> Doc
SerializedVal -> Doc
(Int -> SerializedVal -> Doc)
-> (SerializedVal -> Doc)
-> ([SerializedVal] -> Doc)
-> Out SerializedVal
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> SerializedVal -> Doc
docPrec :: Int -> SerializedVal -> Doc
$cdoc :: SerializedVal -> Doc
doc :: SerializedVal -> Doc
$cdocList :: [SerializedVal] -> Doc
docList :: [SerializedVal] -> Doc
Out, SerializedVal -> ()
(SerializedVal -> ()) -> NFData SerializedVal
forall a. (a -> ()) -> NFData a
$crnf :: SerializedVal -> ()
rnf :: SerializedVal -> ()
NFData)

-- Must match with sizes returned by 'byteSizeOfTy'.
byteSize :: SerializedVal -> Int
byteSize :: SerializedVal -> Int
byteSize (SerTag{})   = Int
1
byteSize (SerBool{})  = Int
1
byteSize (SerializedVal
SerPad)     = Int
1
byteSize (SerInt{})   = Int
8
byteSize (SerChar{})  = Int
1
byteSize (SerFloat{}) = Int
8
byteSize (SerPtr{})   = Int
8

-- | Everything occupies a single cell in the 'Buffer'.
byteSizeOfTy :: UrTy d -> Maybe Int
byteSizeOfTy :: forall d. UrTy d -> Maybe Int
byteSizeOfTy = UrTy d -> Maybe Int
forall d. UrTy d -> Maybe Int
sizeOfTy

instance Out a => Out (Seq a) where
  doc :: Seq a -> Doc
doc Seq a
s       = [a] -> Doc
forall a. Out a => a -> Doc
doc       (Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq a
s)
  docPrec :: Int -> Seq a -> Doc
docPrec Int
n Seq a
s = Int -> [a] -> Doc
forall a. Out a => Int -> a -> Doc
docPrec Int
n (Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq a
s)

-- | Code to read a final answer back out.
deserialize :: (Out ty) => DDefs ty -> Store -> Buffer -> Value Exp2
deserialize :: forall ty. Out ty => DDefs ty -> Store -> Buffer -> Value Exp2
deserialize DDefs ty
ddefs Store
store (Buffer Seq SerializedVal
seq0) = Value Exp2
final
 where
  ([Value Exp2
final],Seq SerializedVal
_) = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN Int
1 Seq SerializedVal
seq0

  readN :: Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN Int
0 Seq SerializedVal
seq1 = ([],Seq SerializedVal
seq1)
  readN Int
n Seq SerializedVal
seq1 =
     case Seq SerializedVal -> ViewL SerializedVal
forall a. Seq a -> ViewL a
S.viewl Seq SerializedVal
seq1 of
       ViewL SerializedVal
S.EmptyL -> String -> ([Value Exp2], Seq SerializedVal)
forall a. HasCallStack => String -> a
error (String -> ([Value Exp2], Seq SerializedVal))
-> String -> ([Value Exp2], Seq SerializedVal)
forall a b. (a -> b) -> a -> b
$ String
"deserialize: unexpected end of sequence: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Seq SerializedVal -> String
forall a. Out a => a -> String
ndoc Seq SerializedVal
seq0
       SerInt Int
i :< Seq SerializedVal
rst ->
         let ([Value Exp2]
more,Seq SerializedVal
rst') = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Seq SerializedVal
rst
         in (Int -> Value Exp2
forall e. Int -> Value e
VInt Int
i Value Exp2 -> [Value Exp2] -> [Value Exp2]
forall a. a -> [a] -> [a]
: [Value Exp2]
more, Seq SerializedVal
rst')

       SerBool Int
i :< Seq SerializedVal
rst ->
         let ([Value Exp2]
more,Seq SerializedVal
rst') = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Seq SerializedVal
rst
             -- 1 is True
             b :: Bool
b = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
         in (Bool -> Value Exp2
forall e. Bool -> Value e
VBool Bool
b Value Exp2 -> [Value Exp2] -> [Value Exp2]
forall a. a -> [a] -> [a]
: [Value Exp2]
more, Seq SerializedVal
rst')

       SerTag Word8
_ String
k :< Seq SerializedVal
rst ->
         let ([Value Exp2]
args,Seq SerializedVal
rst')  = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN ([ty] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DDefs ty -> String -> [ty]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs ty
ddefs String
k)) Seq SerializedVal
rst
             ([Value Exp2]
more,Seq SerializedVal
rst'') = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Seq SerializedVal
rst'
         in (String -> [Value Exp2] -> Value Exp2
forall e. String -> [Value e] -> Value e
VPacked String
k [Value Exp2]
args Value Exp2 -> [Value Exp2] -> [Value Exp2]
forall a. a -> [a] -> [a]
: [Value Exp2]
more, Seq SerializedVal
rst'')

       SerFloat Double
i :< Seq SerializedVal
rst ->
         let ([Value Exp2]
more,Seq SerializedVal
rst') = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Seq SerializedVal
rst
         in (Double -> Value Exp2
forall e. Double -> Value e
VFloat Double
i Value Exp2 -> [Value Exp2] -> [Value Exp2]
forall a. a -> [a] -> [a]
: [Value Exp2]
more, Seq SerializedVal
rst')

       SerPtr Var
buf_id Int
off :< Seq SerializedVal
rst ->
         let Store Map Var Buffer
s = Store
store
             Buffer Seq SerializedVal
pointee = Int -> Buffer -> Buffer
dropInBuffer Int
off (Map Var Buffer
s Map Var Buffer -> Var -> Buffer
forall k a. Ord k => Map k a -> k -> a
M.! Var
buf_id)
             ([Value Exp2]
ls, Seq SerializedVal
_rst') = Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN Int
n Seq SerializedVal
pointee
         in ([Value Exp2]
ls, Seq SerializedVal
rst)

       SerializedVal
SerPad :< Seq SerializedVal
rst ->
         Int -> Seq SerializedVal -> ([Value Exp2], Seq SerializedVal)
readN Int
n Seq SerializedVal
rst
         -- let (more,rst') = readN (n-1) rst
         -- in (VInt (-1) : more, rst')

       ViewL SerializedVal
oth -> String -> ([Value Exp2], Seq SerializedVal)
forall a. HasCallStack => String -> a
error (String -> ([Value Exp2], Seq SerializedVal))
-> String -> ([Value Exp2], Seq SerializedVal)
forall a b. (a -> b) -> a -> b
$ String
"todo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ViewL SerializedVal -> String
forall a. Show a => a -> String
show ViewL SerializedVal
oth

data Size = SOne Int
          | SMany [Size]
  deriving (ReadPrec [Size]
ReadPrec Size
Int -> ReadS Size
ReadS [Size]
(Int -> ReadS Size)
-> ReadS [Size] -> ReadPrec Size -> ReadPrec [Size] -> Read Size
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Size
readsPrec :: Int -> ReadS Size
$creadList :: ReadS [Size]
readList :: ReadS [Size]
$creadPrec :: ReadPrec Size
readPrec :: ReadPrec Size
$creadListPrec :: ReadPrec [Size]
readListPrec :: ReadPrec [Size]
Read, Int -> Size -> String -> String
[Size] -> String -> String
Size -> String
(Int -> Size -> String -> String)
-> (Size -> String) -> ([Size] -> String -> String) -> Show Size
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Size -> String -> String
showsPrec :: Int -> Size -> String -> String
$cshow :: Size -> String
show :: Size -> String
$cshowList :: [Size] -> String -> String
showList :: [Size] -> String -> String
Show, Size -> Size -> Bool
(Size -> Size -> Bool) -> (Size -> Size -> Bool) -> Eq Size
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Size -> Size -> Bool
== :: Size -> Size -> Bool
$c/= :: Size -> Size -> Bool
/= :: Size -> Size -> Bool
Eq, Eq Size
Eq Size
-> (Size -> Size -> Ordering)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Size)
-> (Size -> Size -> Size)
-> Ord Size
Size -> Size -> Bool
Size -> Size -> Ordering
Size -> Size -> Size
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Size -> Size -> Ordering
compare :: Size -> Size -> Ordering
$c< :: Size -> Size -> Bool
< :: Size -> Size -> Bool
$c<= :: Size -> Size -> Bool
<= :: Size -> Size -> Bool
$c> :: Size -> Size -> Bool
> :: Size -> Size -> Bool
$c>= :: Size -> Size -> Bool
>= :: Size -> Size -> Bool
$cmax :: Size -> Size -> Size
max :: Size -> Size -> Size
$cmin :: Size -> Size -> Size
min :: Size -> Size -> Size
Ord, (forall x. Size -> Rep Size x)
-> (forall x. Rep Size x -> Size) -> Generic Size
forall x. Rep Size x -> Size
forall x. Size -> Rep Size x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Size -> Rep Size x
from :: forall x. Size -> Rep Size x
$cto :: forall x. Rep Size x -> Size
to :: forall x. Rep Size x -> Size
Generic, Int -> Size -> Doc
[Size] -> Doc
Size -> Doc
(Int -> Size -> Doc)
-> (Size -> Doc) -> ([Size] -> Doc) -> Out Size
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> Size -> Doc
docPrec :: Int -> Size -> Doc
$cdoc :: Size -> Doc
doc :: Size -> Doc
$cdocList :: [Size] -> Doc
docList :: [Size] -> Doc
Out)

type SizeEnv = M.Map Var Size

sizeToInt :: Size -> Int
sizeToInt :: Size -> Int
sizeToInt (SOne Int
i)   = Int
i
sizeToInt (SMany [Size]
ls) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Size -> Int) -> [Size] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Size -> Int
sizeToInt [Size]
ls

appendSize :: Size -> Size -> Size
appendSize :: Size -> Size -> Size
appendSize Size
a Size
b =
    case (Size
a,Size
b) of
        (SOne Int
i, SOne Int
j)     -> Int -> Size
SOne (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j)
        (SMany [Size]
xs, SMany [Size]
ys) -> [Size] -> Size
SMany ([Size]
xs [Size] -> [Size] -> [Size]
forall a. [a] -> [a] -> [a]
++ [Size]
ys)
        (Size
x, SMany [Size]
xs) -> [Size] -> Size
SMany (Size
xSize -> [Size] -> [Size]
forall a. a -> [a] -> [a]
:[Size]
xs)
        (SMany [Size]
xs, Size
x) -> [Size] -> Size
SMany ([Size]
xs[Size] -> [Size] -> [Size]
forall a. [a] -> [a] -> [a]
++[Size
x])