-- | Interpreter for the target language (L4)

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Gibbon.L4.Interp
    ( Val(..), applyPrim
    , execProg
    ) where

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

import Control.Monad
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)

import Data.Sequence (Seq, ViewL ((:<)), (|>))
import qualified Data.Sequence as Seq
import Gibbon.L4.Syntax
import Gibbon.Common (fromVar)
import GHC.Generics
import Control.DeepSeq
import Text.PrettyPrint.GenericPretty
import Text.PrettyPrint

-- import Data.Time.Clock
import System.Clock
--------------------------------------------------------------------------------

data Val
  = FunVal FunDecl
  | IntVal Int  -- ^ These also serve as Bools
  | CharVal Char
  | FloatVal Double  -- ^ These also serve as Bools
  | TagVal Tag
  | BufVal (Seq Int)
      -- ^ Tags are also written as integers.
  deriving (Val -> Val -> Bool
(Val -> Val -> Bool) -> (Val -> Val -> Bool) -> Eq Val
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Val -> Val -> Bool
== :: Val -> Val -> Bool
$c/= :: Val -> Val -> Bool
/= :: Val -> Val -> Bool
Eq, Int -> Val -> ShowS
[Val] -> ShowS
Val -> String
(Int -> Val -> ShowS)
-> (Val -> String) -> ([Val] -> ShowS) -> Show Val
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Val -> ShowS
showsPrec :: Int -> Val -> ShowS
$cshow :: Val -> String
show :: Val -> String
$cshowList :: [Val] -> ShowS
showList :: [Val] -> ShowS
Show, (forall x. Val -> Rep Val x)
-> (forall x. Rep Val x -> Val) -> Generic Val
forall x. Rep Val x -> Val
forall x. Val -> Rep Val x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Val -> Rep Val x
from :: forall x. Val -> Rep Val x
$cto :: forall x. Rep Val x -> Val
to :: forall x. Rep Val x -> Val
Generic, Val -> ()
(Val -> ()) -> NFData Val
forall a. (a -> ()) -> NFData a
$crnf :: Val -> ()
rnf :: Val -> ()
NFData)

instance NFData TimeSpec where
  rnf :: TimeSpec -> ()
rnf (TimeSpec !Int64
_ !Int64
_) = ()

{-
instance Out UTCTime where
    doc s = text (show s)
    docPrec n s = text (show s)
-}
instance Out TimeSpec where
    doc :: TimeSpec -> Doc
doc TimeSpec
s = String -> Doc
text (TimeSpec -> String
forall a. Show a => a -> String
show TimeSpec
s)
    docPrec :: Int -> TimeSpec -> Doc
docPrec Int
_ TimeSpec
s = String -> Doc
text (TimeSpec -> String
forall a. Show a => a -> String
show TimeSpec
s)

instance Out Val

instance Out (Seq Int) where
    doc :: Seq Int -> Doc
doc Seq Int
s = String -> Doc
text (Seq Int -> String
forall a. Show a => a -> String
show Seq Int
s)
    docPrec :: Int -> Seq Int -> Doc
docPrec Int
_ Seq Int
s = String -> Doc
text (Seq Int -> String
forall a. Show a => a -> String
show Seq Int
s)

execProg :: Prog -> IO [Val]
execProg :: Prog -> IO [Val]
execProg (Prog InfoTable
_ SymTable
_ [FunDecl]
_ Maybe MainExp
Nothing) = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"Can't evaluate program: No expression given"
execProg (Prog InfoTable
_ SymTable
_ [FunDecl]
funs (Just (PrintExp Tail
expr))) = Env -> Tail -> IO [Val]
exec Env
env Tail
expr
  where
    env :: Env
env = [(Var, Val)] -> Env
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((FunDecl -> (Var, Val)) -> [FunDecl] -> [(Var, Val)]
forall a b. (a -> b) -> [a] -> [b]
map (\FunDecl
f -> (FunDecl -> Var
funName FunDecl
f, FunDecl -> Val
FunVal FunDecl
f)) [FunDecl]
funs)

type Env = M.Map Var Val


clk :: Clock
clk :: Clock
clk = Clock
Monotonic
-- Linux specific:
-- clk = MonotonicRaw


eval :: Env -> Triv -> Val
eval :: Env -> Triv -> Val
eval Env
env (VarTriv Var
v) = Val -> Var -> Env -> Val
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (String -> Val
forall a. HasCallStack => String -> a
error (String
"Unbound var: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Var -> String
fromVar Var
v))) Var
v Env
env
eval Env
_   (IntTriv Int64
i) = Int -> Val
IntVal (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i) -- TODO: Change L1 to Int64 too.
eval Env
_   (CharTriv Char
i) = Char -> Val
CharVal Char
i
eval Env
_   (FloatTriv Double
i) = Double -> Val
FloatVal Double
i -- TODO: Change L1 to Int64 too.
eval Env
_   (TagTriv Tag
t) = Tag -> Val
TagVal Tag
t
eval Env
_   (SymTriv Word16
_) = String -> Val
forall a. HasCallStack => String -> a
error String
"eval: SymTriv not handled"
eval Env
_   (ProdTriv{}) = String -> Val
forall a. HasCallStack => String -> a
error String
"eval: ProdTriv not handled"
eval Env
_   (ProjTriv{}) = String -> Val
forall a. HasCallStack => String -> a
error String
"eval: ProjTriv not handled"
eval Env
_   (BoolTriv{}) = String -> Val
forall a. HasCallStack => String -> a
error String
"eval: BoolTriv not handled"


exec :: Env -> Tail -> IO [Val]

exec :: Env -> Tail -> IO [Val]
exec Env
env (RetValsT [Triv]
ts) = [Val] -> IO [Val]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Val] -> IO [Val]) -> [Val] -> IO [Val]
forall a b. (a -> b) -> a -> b
$! (Triv -> Val) -> [Triv] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> Triv -> Val
eval Env
env) [Triv]
ts

exec Env
env (LetTrivT (Var
v,Ty
_t,Triv
rhs) Tail
body) =
    Env -> Tail -> IO [Val]
exec Env
env' Tail
body
  where
    env' :: Env
env' = Env -> [(Var, Val)] -> Env
extendEnv Env
env [(Var
v,Val
rhs')]
    rhs' :: Val
rhs' = Env -> Triv -> Val
eval Env
env Triv
rhs

exec Env
env (LetCallT Bool
_async [(Var, Ty)]
binds Var
op [Triv]
args Tail
body) = do
    [Val]
rets <- Env -> Val -> [Val] -> IO [Val]
apply Env
env (Env -> Triv -> Val
eval Env
env (Var -> Triv
VarTriv Var
op)) ((Triv -> Val) -> [Triv] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> Triv -> Val
eval Env
env) [Triv]
args)
    let env' :: Env
env' = Env -> [(Var, Val)] -> Env
extendEnv Env
env ([Var] -> [Val] -> [(Var, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Ty) -> Var) -> [(Var, Ty)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty)]
binds) [Val]
rets)
    Env -> Tail -> IO [Val]
exec Env
env' Tail
body

exec Env
env (LetPrimCallT [(Var, Ty)]
binds Prim
op [Triv]
args Tail
body) = do
    [Val]
rets <- Prim -> [Val] -> IO [Val]
applyPrim Prim
op ((Triv -> Val) -> [Triv] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> Triv -> Val
eval Env
env) [Triv]
args)
    let env' :: Env
env' = Env -> [(Var, Val)] -> Env
extendEnv Env
env ([Var] -> [Val] -> [(Var, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Ty) -> Var) -> [(Var, Ty)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty)]
binds) [Val]
rets)
    Env -> Tail -> IO [Val]
exec Env
env' Tail
body

exec Env
env (LetIfT [(Var, Ty)]
bnds (Triv
tst,Tail
thn,Tail
els) Tail
bod) =
  do let scrut :: Val
scrut = Env -> Triv -> Val
eval Env
env Triv
tst
     [Val]
vals <- if Val
scrut Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Val
IntVal Int
1
             then Env -> Tail -> IO [Val]
exec Env
env Tail
thn
             else Env -> Tail -> IO [Val]
exec Env
env Tail
els
     let env' :: Env
env' = Env -> [(Var, Val)] -> Env
extendEnv Env
env ([Var] -> [Val] -> [(Var, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Ty) -> Var) -> [(Var, Ty)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty)]
bnds) [Val]
vals)
     Env -> Tail -> IO [Val]
exec Env
env' Tail
bod

exec Env
env (IfT Triv
v1 Tail
then_ Tail
else_) =
    if Val
v1' Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Val
IntVal Int
1 then Env -> Tail -> IO [Val]
exec Env
env Tail
then_ else Env -> Tail -> IO [Val]
exec Env
env Tail
else_
  where
    v1' :: Val
v1' = Env -> Triv -> Val
eval Env
env Triv
v1

exec Env
_ (ErrT String
s) =
    String -> IO [Val]
forall a. HasCallStack => String -> a
error (String -> IO [Val]) -> String -> IO [Val]
forall a b. (a -> b) -> a -> b
$ String
"ErrT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

exec Env
env (LetTimedT Bool
flg [(Var, Ty)]
bnds Tail
rhs Tail
bod) = do
    let iters :: Int
iters = if Bool
flg then (String -> Int
forall a. HasCallStack => String -> a
error String
"Implement timed iteration inside the interpreter...")
                else Int
1
    !Env
_ <- Env -> IO Env
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$! Env -> Env
forall a. NFData a => a -> a
force Env
env
    TimeSpec
st <- Clock -> IO TimeSpec
getTime Clock
clk
    [Val]
vals <- ([Val] -> Int -> IO [Val]) -> [Val] -> [Int] -> IO [Val]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ [Val]
_ Int
i -> Int -> Env -> Tail -> IO [Val]
execWrapper Int
i Env
env Tail
rhs)
                  (String -> [Val]
forall a. HasCallStack => String -> a
error String
"Internal error: this should be unused.")
               [Int
1..Int
iters]
    TimeSpec
en <- Clock -> IO TimeSpec
getTime Clock
clk
    let env' :: Env
env' = Env -> [(Var, Val)] -> Env
extendEnv Env
env ([Var] -> [Val] -> [(Var, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Ty) -> Var) -> [(Var, Ty)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty)]
bnds) [Val]
vals)
    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
flg
     then do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ITERS: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
iters
             String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SIZE: " String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. HasCallStack => String -> a
error String
"FINISHME: get size param" :: Int)
             String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"BATCHTIME: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
tm
     else String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SELFTIMED: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
tm
    Env -> Tail -> IO [Val]
exec Env
env' Tail
bod

exec Env
env (Switch Var
_ Triv
tr Alts
alts Maybe Tail
def) =
    case Maybe Tail
final_alt of
      Maybe Tail
Nothing -> String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"Switch: No branch to choose."
      Just Tail
br -> Env -> Tail -> IO [Val]
exec Env
env Tail
br
  where
    tr' :: Val
tr' = Env -> Triv -> Val
eval Env
env Triv
tr

    intAlts :: [(Int64, Tail)]
intAlts
      | IntAlts [(Int64, Tail)]
alts' <- Alts
alts
      = [(Int64, Tail)]
alts'
      | Bool
otherwise
      = String -> [(Int64, Tail)]
forall a. HasCallStack => String -> a
error String
"intAlts: Found TagAlts"

    tagAlts :: [(Tag, Tail)]
tagAlts
      | TagAlts [(Tag, Tail)]
alts' <- Alts
alts
      = [(Tag, Tail)]
alts'
      | Bool
otherwise
      = String -> [(Tag, Tail)]
forall a. HasCallStack => String -> a
error String
"tagAlts: Found IntAlts"

    chooseIntAlt :: Int64 -> Maybe Tail
chooseIntAlt Int64
i = (Int64, Tail) -> Tail
forall a b. (a, b) -> b
snd ((Int64, Tail) -> Tail) -> Maybe (Int64, Tail) -> Maybe Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int64, Tail)] -> Maybe (Int64, Tail)
forall a. [a] -> Maybe a
listToMaybe (((Int64, Tail) -> Bool) -> [(Int64, Tail)] -> [(Int64, Tail)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int64 -> Bool)
-> ((Int64, Tail) -> Int64) -> (Int64, Tail) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64, Tail) -> Int64
forall a b. (a, b) -> a
fst) [(Int64, Tail)]
intAlts)
    chooseTagAlt :: Tag -> Maybe Tail
chooseTagAlt Tag
t = (Tag, Tail) -> Tail
forall a b. (a, b) -> b
snd ((Tag, Tail) -> Tail) -> Maybe (Tag, Tail) -> Maybe Tail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tag, Tail)] -> Maybe (Tag, Tail)
forall a. [a] -> Maybe a
listToMaybe (((Tag, Tail) -> Bool) -> [(Tag, Tail)] -> [(Tag, Tail)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
==) (Tag -> Bool) -> ((Tag, Tail) -> Tag) -> (Tag, Tail) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag, Tail) -> Tag
forall a b. (a, b) -> a
fst) [(Tag, Tail)]
tagAlts)

    final_alt :: Maybe Tail
final_alt =
      Maybe Tail -> (Tail -> Maybe Tail) -> Maybe Tail -> Maybe Tail
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Tail
def Tail -> Maybe Tail
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Tail -> Maybe Tail) -> Maybe Tail -> Maybe Tail
forall a b. (a -> b) -> a -> b
$
        case Val
tr' of
          IntVal Int
i -> Int64 -> Maybe Tail
chooseIntAlt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
          TagVal Tag
t -> Tag -> Maybe Tail
chooseTagAlt Tag
t
          Val
_        -> String -> Maybe Tail
forall a. HasCallStack => String -> a
error (String
"Switch: invalid value in scrutinee position: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
tr')

exec Env
env (TailCall Var
fn [Triv]
args) =
    Env -> Val -> [Val] -> IO [Val]
apply Env
env Val
fn' [Val]
args'
  where
    fn' :: Val
fn' = Env -> Triv -> Val
eval Env
env (Var -> Triv
VarTriv Var
fn)
    args' :: [Val]
args' = (Triv -> Val) -> [Triv] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> Triv -> Val
eval Env
env) [Triv]
args

exec Env
_ Tail
e = String -> IO [Val]
forall a. HasCallStack => String -> a
error(String -> IO [Val]) -> String -> IO [Val]
forall a b. (a -> b) -> a -> b
$ String
"Interpreter/exec, unhandled expression:\n  "String -> ShowS
forall a. [a] -> [a] -> [a]
++Doc -> String
forall a. Show a => a -> String
show (Tail -> Doc
forall a. Out a => a -> Doc
doc Tail
e)

{-# NOINLINE execWrapper #-}
execWrapper :: Int -> Env -> Tail -> IO [Val]
execWrapper :: Int -> Env -> Tail -> IO [Val]
execWrapper Int
_i Env
env Tail
ex = ([Val] -> [Val]) -> IO [Val] -> IO [Val]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Val] -> [Val]
forall a. NFData a => a -> a
force (IO [Val] -> IO [Val]) -> IO [Val] -> IO [Val]
forall a b. (a -> b) -> a -> b
$ Env -> Tail -> IO [Val]
exec Env
env Tail
ex

extendEnv :: Env -> [(Var, Val)] -> Env
extendEnv :: Env -> [(Var, Val)] -> Env
extendEnv = ((Var, Val) -> Env -> Env) -> Env -> [(Var, Val)] -> Env
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Var -> Val -> Env -> Env) -> (Var, Val) -> Env -> Env
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> Val -> Env -> Env
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert)

apply :: Env -> Val -> [Val] -> IO [Val]

apply :: Env -> Val -> [Val] -> IO [Val]
apply Env
env (FunVal (FunDecl Var
_ [(Var, Ty)]
as Ty
_ Tail
body Bool
_)) [Val]
args =
    Env -> Tail -> IO [Val]
exec (Env -> [(Var, Val)] -> Env
extendEnv Env
env ([Var] -> [Val] -> [(Var, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Var, Ty) -> Var) -> [(Var, Ty)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty)]
as) [Val]
args)) Tail
body

apply Env
_ Val
notFun [Val]
_ =
    String -> IO [Val]
forall a. HasCallStack => String -> a
error (String
"apply to a non-function: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
notFun)

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

applyPrim :: Prim -> [Val] -> IO [Val]

applyPrim :: Prim -> [Val] -> IO [Val]
applyPrim Prim
AddP [IntVal Int
i1, IntVal Int
i2] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Val
IntVal (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i2)]
applyPrim Prim
SubP [IntVal Int
i1, IntVal Int
i2] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Val
IntVal (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i2)]
applyPrim Prim
MulP [IntVal Int
i1, IntVal Int
i2] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Val
IntVal (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i2)]

applyPrim Prim
EqP  [IntVal Int
i1, IntVal Int
i2] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Val
IntVal (if Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2 then Int
1 else Int
0)]

applyPrim NewBuffer{} [] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Seq Int -> Val
BufVal Seq Int
forall a. Seq a
Seq.empty]

applyPrim NewParBuffer{} [] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Seq Int -> Val
BufVal Seq Int
forall a. Seq a
Seq.empty]

applyPrim Prim
WriteTag [TagVal Tag
tag, BufVal Seq Int
is] = [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Seq Int -> Val
BufVal (Seq Int
is Seq Int -> Int -> Seq Int
forall a. Seq a -> a -> Seq a
|> Tag -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Tag
tag)]

applyPrim Prim
ReadTag [BufVal Seq Int
is] = case Seq Int -> ViewL Int
forall a. Seq a -> ViewL a
Seq.viewl Seq Int
is of
                                ViewL Int
Seq.EmptyL -> String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"ReadTag: Empty buffer"
                                Int
t :< Seq Int
is'   -> [Val] -> IO [Val]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tag -> Val
TagVal (Int -> Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t), Seq Int -> Val
BufVal Seq Int
is']

-- [2019.06.10] CSK: Implement this later.
-- applyPrim (WriteScalar s) [IntVal i, BufVal is] = pure [BufVal (is |> i)]
-- applyPrim (ReadScalar s) [BufVal is] = case Seq.viewl is of
--                                          Seq.EmptyL -> error "ReadInt: Empty buffer"
--                                          i :< is'   -> pure  [IntVal i, BufVal is']

applyPrim Prim
PrintInt [IntVal Int
i] = do Int -> IO ()
forall a. Show a => a -> IO ()
print Int
i; [Val] -> IO [Val]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
applyPrim (PrintString String
st) [] = do String -> IO ()
putStrLn String
st; [Val] -> IO [Val]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

applyPrim Prim
SizeParam [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"TargetInterp/applyPrim: finish SizeParam"
applyPrim ScopedBuffer{} [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"TargetInterp/applyPrim: finish ScopedBuf"
applyPrim ScopedParBuffer{} [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"TargetInterp/applyPrim: finish ScopedBuf"
applyPrim Prim
GetFirstWord [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"TargetInterp/applyPrim: finish GetFirstWord"

applyPrim (DictInsertP Ty
_) [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error String
"TargetInterp/applyPrim: finish DictInsertP"
applyPrim (DictLookupP Ty
_) [] = String -> IO [Val]
forall a. HasCallStack => String -> a
error (String -> IO [Val]) -> String -> IO [Val]
forall a b. (a -> b) -> a -> b
$ String
"TargetInterp/applyPrim: finish DictLookupP"
applyPrim (DictEmptyP Ty
_) []  = String -> IO [Val]
forall a. HasCallStack => String -> a
error (String -> IO [Val]) -> String -> IO [Val]
forall a b. (a -> b) -> a -> b
$ String
"TargetInterp/applyPrim: finish DictEmptyP"


applyPrim Prim
op [Val]
args = String -> IO [Val]
forall a. HasCallStack => String -> a
error (String
"applyPrim: Unsupported form or bad arguments: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim -> String
forall a. Show a => a -> String
show Prim
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Val] -> String
forall a. Show a => a -> String
show [Val]
args)