{-# LANGUAGE OverloadedStrings #-}
module Clash.Core.Evaluator.Types where
import Control.Concurrent.Supply (Supply)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap (insert, lookup)
import Data.List (foldl')
import Data.Maybe (isJust)
import Data.Text.Prettyprint.Doc (hsep)
import Clash.Core.DataCon (DataCon)
import Clash.Core.Literal (Literal(CharLiteral))
import Clash.Core.Pretty (fromPpr)
import Clash.Core.Term (Term(..), PrimInfo(..), TickInfo, Alt)
import Clash.Core.TyCon (TyConMap)
import Clash.Core.Type (Type)
import Clash.Core.Var (Id, IdScope(..), TyVar)
import Clash.Core.VarEnv
import Clash.Pretty (ClashPretty(..), fromPretty)
type PrimStep
= TyConMap
-> Bool
-> PrimInfo
-> [Type]
-> [Value]
-> Machine
-> Maybe Machine
type PrimUnwind
= TyConMap
-> PrimInfo
-> [Type]
-> [Value]
-> Value
-> [Term]
-> Machine
-> Maybe Machine
type PrimEvaluator = (PrimStep, PrimUnwind)
data Machine = Machine
{ Machine -> PrimStep
mPrimStep :: PrimStep
, Machine -> PrimUnwind
mPrimUnwind :: PrimUnwind
, Machine -> PrimHeap
mHeapPrim :: PrimHeap
, Machine -> PureHeap
mHeapGlobal :: PureHeap
, Machine -> PureHeap
mHeapLocal :: PureHeap
, Machine -> Stack
mStack :: Stack
, Machine -> Supply
mSupply :: Supply
, Machine -> InScopeSet
mScopeNames :: InScopeSet
, Machine -> Term
mTerm :: Term
}
instance Show Machine where
show :: Machine -> String
show (Machine PrimStep
_ PrimUnwind
_ PrimHeap
ph PureHeap
gh PureHeap
lh Stack
s Supply
_ InScopeSet
_ Term
x) =
[String] -> String
unlines
[ String
"Machine:"
, String
""
, String
"Heap (Prim):"
, PrimHeap -> String
forall a. Show a => a -> String
show PrimHeap
ph
, String
""
, String
"Heap (Globals):"
, PureHeap -> String
forall a. Show a => a -> String
show PureHeap
gh
, String
""
, String
"Heap (Locals):"
, PureHeap -> String
forall a. Show a => a -> String
show PureHeap
lh
, String
""
, String
"Stack:"
, [Doc ()] -> String
forall a. Show a => a -> String
show ((StackFrame -> Doc ()) -> Stack -> [Doc ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap StackFrame -> Doc ()
forall a. ClashPretty a => a -> Doc ()
clashPretty Stack
s)
, String
""
, String
"Term:"
, Term -> String
forall a. Show a => a -> String
show Term
x
]
type PrimHeap = (IntMap Term, Int)
type PureHeap = VarEnv Term
type Stack = [StackFrame]
data StackFrame
= Update IdScope Id
| Apply Id
| Instantiate Type
| PrimApply PrimInfo [Type] [Value] [Term]
| Scrutinise Type [Alt]
| Tickish TickInfo
deriving Int -> StackFrame -> ShowS
Stack -> ShowS
StackFrame -> String
(Int -> StackFrame -> ShowS)
-> (StackFrame -> String) -> (Stack -> ShowS) -> Show StackFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Stack -> ShowS
$cshowList :: Stack -> ShowS
show :: StackFrame -> String
$cshow :: StackFrame -> String
showsPrec :: Int -> StackFrame -> ShowS
$cshowsPrec :: Int -> StackFrame -> ShowS
Show
instance ClashPretty StackFrame where
clashPretty :: StackFrame -> Doc ()
clashPretty (Update IdScope
GlobalId Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Update(Global)", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
clashPretty (Update IdScope
LocalId Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Update(Local)", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
clashPretty (Apply Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Apply", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
clashPretty (Instantiate Type
t) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Instantiate", Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Type
t]
clashPretty (PrimApply PrimInfo
p [Type]
tys [Value]
vs [Term]
ts) =
[Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"PrimApply", Text -> Doc ()
forall a. Pretty a => a -> Doc ()
fromPretty (PrimInfo -> Text
primName PrimInfo
p), Doc ()
"::", Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr (PrimInfo -> Type
primType PrimInfo
p),
Doc ()
"; type args=", [Type] -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr [Type]
tys,
Doc ()
"; val args=", [Term] -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr ((Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Term
valToTerm [Value]
vs),
Doc ()
"term args=", [Term] -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr [Term]
ts]
clashPretty (Scrutinise Type
a [Alt]
b) =
[Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Scrutinise ", Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Type
a,
Term -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr (Term -> Type -> [Alt] -> Term
Case (Literal -> Term
Literal (Char -> Literal
CharLiteral Char
'_')) Type
a [Alt]
b)]
clashPretty (Tickish TickInfo
sp) =
[Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()
"Tick", TickInfo -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr TickInfo
sp]
data Value
= Lambda Id Term
| TyLambda TyVar Term
| DC DataCon [Either Term Type]
| Lit Literal
| PrimVal PrimInfo [Type] [Value]
| Suspend Term
| TickValue TickInfo Value
| CastValue Value Type Type
deriving Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show
valToTerm :: Value -> Term
valToTerm :: Value -> Term
valToTerm Value
v = case Value
v of
Lambda Id
x Term
e -> Id -> Term -> Term
Lam Id
x Term
e
TyLambda TyVar
x Term
e -> TyVar -> Term -> Term
TyLam TyVar
x Term
e
DC DataCon
dc [Either Term Type]
pxs -> (Term -> Either Term Type -> Term)
-> Term -> [Either Term Type] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Term
e Either Term Type
a -> (Term -> Term) -> (Type -> Term) -> Either Term Type -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Term -> Term -> Term
App Term
e) (Term -> Type -> Term
TyApp Term
e) Either Term Type
a)
(DataCon -> Term
Data DataCon
dc) [Either Term Type]
pxs
Lit Literal
l -> Literal -> Term
Literal Literal
l
PrimVal PrimInfo
ty [Type]
tys [Value]
vs -> (Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App ((Term -> Type -> Term) -> Term -> [Type] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
ty) [Type]
tys)
((Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Term
valToTerm [Value]
vs)
Suspend Term
e -> Term
e
TickValue TickInfo
t Value
x -> TickInfo -> Term -> Term
Tick TickInfo
t (Value -> Term
valToTerm Value
x)
CastValue Value
x Type
t1 Type
t2 -> Term -> Type -> Type -> Term
Cast (Value -> Term
valToTerm Value
x) Type
t1 Type
t2
collectValueTicks
:: Value
-> (Value, [TickInfo])
collectValueTicks :: Value -> (Value, [TickInfo])
collectValueTicks = [TickInfo] -> Value -> (Value, [TickInfo])
go []
where
go :: [TickInfo] -> Value -> (Value, [TickInfo])
go [TickInfo]
ticks (TickValue TickInfo
t Value
v) = [TickInfo] -> Value -> (Value, [TickInfo])
go (TickInfo
tTickInfo -> [TickInfo] -> [TickInfo]
forall a. a -> [a] -> [a]
:[TickInfo]
ticks) Value
v
go [TickInfo]
ticks Value
v = (Value
v, [TickInfo]
ticks)
forcePrims :: Machine -> Bool
forcePrims :: Machine -> Bool
forcePrims = Stack -> Bool
go (Stack -> Bool) -> (Machine -> Stack) -> Machine -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine -> Stack
mStack
where
go :: Stack -> Bool
go (Scrutinise{}:Stack
_) = Bool
True
go (PrimApply{}:Stack
_) = Bool
True
go (Tickish{}:Stack
xs) = Stack -> Bool
go Stack
xs
go Stack
_ = Bool
False
primCount :: Machine -> Int
primCount :: Machine -> Int
primCount = PrimHeap -> Int
forall a b. (a, b) -> b
snd (PrimHeap -> Int) -> (Machine -> PrimHeap) -> Machine -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine -> PrimHeap
mHeapPrim
primLookup :: Int -> Machine -> Maybe Term
primLookup :: Int -> Machine -> Maybe Term
primLookup Int
i = Int -> IntMap Term -> Maybe Term
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i (IntMap Term -> Maybe Term)
-> (Machine -> IntMap Term) -> Machine -> Maybe Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimHeap -> IntMap Term
forall a b. (a, b) -> a
fst (PrimHeap -> IntMap Term)
-> (Machine -> PrimHeap) -> Machine -> IntMap Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine -> PrimHeap
mHeapPrim
primInsert :: Int -> Term -> Machine -> Machine
primInsert :: Int -> Term -> Machine -> Machine
primInsert Int
i Term
x Machine
m =
let (IntMap Term
gh, Int
c) = Machine -> PrimHeap
mHeapPrim Machine
m
in Machine
m { mHeapPrim :: PrimHeap
mHeapPrim = (Int -> Term -> IntMap Term -> IntMap Term
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Term
x IntMap Term
gh, Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) }
primUpdate :: Int -> Term -> Machine -> Machine
primUpdate :: Int -> Term -> Machine -> Machine
primUpdate Int
i Term
x Machine
m =
let (IntMap Term
gh, Int
c) = Machine -> PrimHeap
mHeapPrim Machine
m
in Machine
m { mHeapPrim :: PrimHeap
mHeapPrim = (Int -> Term -> IntMap Term -> IntMap Term
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Term
x IntMap Term
gh, Int
c) }
heapLookup :: IdScope -> Id -> Machine -> Maybe Term
heapLookup :: IdScope -> Id -> Machine -> Maybe Term
heapLookup IdScope
GlobalId Id
i Machine
m =
Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
i (PureHeap -> Maybe Term) -> PureHeap -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Machine -> PureHeap
mHeapGlobal Machine
m
heapLookup IdScope
LocalId Id
i Machine
m =
Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
i (PureHeap -> Maybe Term) -> PureHeap -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Machine -> PureHeap
mHeapLocal Machine
m
heapContains :: IdScope -> Id -> Machine -> Bool
heapContains :: IdScope -> Id -> Machine -> Bool
heapContains IdScope
scope Id
i = Maybe Term -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Term -> Bool) -> (Machine -> Maybe Term) -> Machine -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdScope -> Id -> Machine -> Maybe Term
heapLookup IdScope
scope Id
i
heapInsert :: IdScope -> Id -> Term -> Machine -> Machine
heapInsert :: IdScope -> Id -> Term -> Machine -> Machine
heapInsert IdScope
GlobalId Id
i Term
x Machine
m =
Machine
m { mHeapGlobal :: PureHeap
mHeapGlobal = Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
i Term
x (Machine -> PureHeap
mHeapGlobal Machine
m) }
heapInsert IdScope
LocalId Id
i Term
x Machine
m =
Machine
m { mHeapLocal :: PureHeap
mHeapLocal = Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
i Term
x (Machine -> PureHeap
mHeapLocal Machine
m) }
heapDelete :: IdScope -> Id -> Machine -> Machine
heapDelete :: IdScope -> Id -> Machine -> Machine
heapDelete IdScope
GlobalId Id
i Machine
m =
Machine
m { mHeapGlobal :: PureHeap
mHeapGlobal = PureHeap -> Id -> PureHeap
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv (Machine -> PureHeap
mHeapGlobal Machine
m) Id
i }
heapDelete IdScope
LocalId Id
i Machine
m =
Machine
m { mHeapLocal :: PureHeap
mHeapLocal = PureHeap -> Id -> PureHeap
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv (Machine -> PureHeap
mHeapLocal Machine
m) Id
i }
stackPush :: StackFrame -> Machine -> Machine
stackPush :: StackFrame -> Machine -> Machine
stackPush StackFrame
f Machine
m = Machine
m { mStack :: Stack
mStack = StackFrame
f StackFrame -> Stack -> Stack
forall a. a -> [a] -> [a]
: Machine -> Stack
mStack Machine
m }
stackPop :: Machine -> Maybe (Machine, StackFrame)
stackPop :: Machine -> Maybe (Machine, StackFrame)
stackPop Machine
m = case Machine -> Stack
mStack Machine
m of
[] -> Maybe (Machine, StackFrame)
forall a. Maybe a
Nothing
(StackFrame
x:Stack
xs) -> (Machine, StackFrame) -> Maybe (Machine, StackFrame)
forall a. a -> Maybe a
Just (Machine
m { mStack :: Stack
mStack = Stack
xs }, StackFrame
x)
stackClear :: Machine -> Machine
stackClear :: Machine -> Machine
stackClear Machine
m = Machine
m { mStack :: Stack
mStack = [] }
stackNull :: Machine -> Bool
stackNull :: Machine -> Bool
stackNull = Stack -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null (Stack -> Bool) -> (Machine -> Stack) -> Machine -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine -> Stack
mStack
getTerm :: Machine -> Term
getTerm :: Machine -> Term
getTerm = Machine -> Term
mTerm
setTerm :: Term -> Machine -> Machine
setTerm :: Term -> Machine -> Machine
setTerm Term
x Machine
m = Machine
m { mTerm :: Term
mTerm = Term
x }