{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
  Copyright     : (C) 2020-2022, QBayLogic B.V.
  License       : BSD2 (see the file LICENSE)
  Maintainer    : QBayLogic B.V. <devops@qbaylogic.com>

  Types for the Partial Evaluator
-}
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 (fromMaybe, isJust)

#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter (hsep)
#else
import Data.Text.Prettyprint.Doc (hsep)
#endif

import Clash.Core.DataCon (DataCon, dcType)
import Clash.Core.HasType
import Clash.Core.Literal (Literal(CharLiteral))
import Clash.Core.Pretty (fromPpr, ppr, showPpr)
import Clash.Core.Term (Term(..), PrimInfo(..), TickInfo, Alt, mkApps)
import Clash.Core.TyCon (TyConMap)
import Clash.Core.Type (Type (..), mkFunTy)
import Clash.Core.Var (Id, IdScope(..), TyVar)
import Clash.Core.VarEnv
import Clash.Driver.Types (BindingMap, bindingTerm)
import Clash.Pretty (ClashPretty(..), fromPretty, showDoc)

whnf'
  :: Evaluator
  -> BindingMap
  -> VarEnv Term
  -> TyConMap
  -> PrimHeap
  -> Supply
  -> InScopeSet
  -> Bool
  -> Term
  -> (PrimHeap, PureHeap, Term)
whnf' :: Evaluator
-> BindingMap
-> VarEnv Term
-> TyConMap
-> PrimHeap
-> Supply
-> InScopeSet
-> Bool
-> Term
-> (PrimHeap, VarEnv Term, Term)
whnf' Evaluator
eval BindingMap
bm VarEnv Term
lh TyConMap
tcm PrimHeap
ph Supply
ids InScopeSet
is Bool
isSubj Term
e =
  Machine -> (PrimHeap, VarEnv Term, Term)
toResult (Machine -> (PrimHeap, VarEnv Term, Term))
-> Machine -> (PrimHeap, VarEnv Term, Term)
forall a b. (a -> b) -> a -> b
$ Evaluator -> TyConMap -> Bool -> Machine -> Machine
whnf Evaluator
eval TyConMap
tcm Bool
isSubj Machine
m
 where
  toResult :: Machine -> (PrimHeap, VarEnv Term, Term)
toResult Machine
x = (Machine -> PrimHeap
mHeapPrim Machine
x, Machine -> VarEnv Term
mHeapLocal Machine
x, Machine -> Term
mTerm Machine
x)

  m :: Machine
m  = PrimHeap
-> VarEnv Term
-> VarEnv Term
-> Stack
-> Supply
-> InScopeSet
-> Term
-> Machine
Machine PrimHeap
ph VarEnv Term
gh VarEnv Term
lh [] Supply
ids InScopeSet
is Term
e
  gh :: VarEnv Term
gh = (Binding Term -> Term) -> BindingMap -> VarEnv Term
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv Binding Term -> Term
forall a. Binding a -> a
bindingTerm BindingMap
bm

-- | Evaluate to WHNF given an existing Heap and Stack
whnf
  :: Evaluator
  -> TyConMap
  -> Bool
  -> Machine
  -> Machine
whnf :: Evaluator -> TyConMap -> Bool -> Machine -> Machine
whnf Evaluator
eval TyConMap
tcm Bool
isSubj Machine
m
  | Bool
isSubj =
      -- See [Note: empty case expressions]
      let ty :: Type
ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm (Machine -> Term
mTerm Machine
m)
       in Machine -> Machine
go (StackFrame -> Machine -> Machine
stackPush (Type -> [Alt] -> StackFrame
Scrutinise Type
ty []) Machine
m)
  | Bool
otherwise = Machine -> Machine
go Machine
m
  where
    go :: Machine -> Machine
    go :: Machine -> Machine
go Machine
s = case Evaluator -> Step
step Evaluator
eval Machine
s TyConMap
tcm of
      Just Machine
s' -> Machine -> Machine
go Machine
s'
      Maybe Machine
Nothing -> Machine -> Maybe Machine -> Machine
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Machine
forall a. HasCallStack => [Char] -> a
error ([Char] -> Machine) -> (Term -> [Char]) -> Term -> Machine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ClashAnnotation -> [Char]
forall ann. Doc ann -> [Char]
showDoc (Doc ClashAnnotation -> [Char])
-> (Term -> Doc ClashAnnotation) -> Term -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Doc ClashAnnotation
forall p. PrettyPrec p => p -> Doc ClashAnnotation
ppr (Term -> Machine) -> Term -> Machine
forall a b. (a -> b) -> a -> b
$ Machine -> Term
mTerm Machine
m) (Machine -> Maybe Machine
unwindStack Machine
s)


-- | An evaluator is a collection of basic building blocks which are used to
-- define partial evaluation. In this implementation, it consists of two types
-- of function:
--
--   * steps, which applies the reduction realtion to the current term
--   * unwindings, which pop the stack and evaluate the stack frame
--
-- Variants of these functions also exist for evalauting primitive operations.
-- This is because there may be multiple frontends to the compiler which can
-- reuse a common step and unwind, but have different primitives.
--
data Evaluator = Evaluator
  { Evaluator -> Step
step        :: Step
  , Evaluator -> Unwind
unwind      :: Unwind
  , Evaluator -> PrimStep
primStep    :: PrimStep
  , Evaluator -> PrimUnwind
primUnwind  :: PrimUnwind
  }

-- | Completely unwind the stack to get back the complete term
unwindStack :: Machine -> Maybe Machine
unwindStack :: Machine -> Maybe Machine
unwindStack Machine
m
  | Machine -> Bool
stackNull Machine
m = Machine -> Maybe Machine
forall a. a -> Maybe a
Just Machine
m
  | Bool
otherwise = do
      (Machine
m', StackFrame
kf) <- Machine -> Maybe (Machine, StackFrame)
stackPop Machine
m

      case StackFrame
kf of
        PrimApply PrimInfo
p [Type]
tys [Value]
vs [Term]
tms ->
          let term :: Term
term = (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 -> 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
p) [Type]
tys)
                         ((Value -> Term) -> [Value] -> [Term]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Term
valToTerm [Value]
vs))
                       (Machine -> Term
mTerm Machine
m' Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
tms)
           in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

        Instantiate Type
ty ->
          let term :: Term
term = Term -> Type -> Term
TyApp (Machine -> Term
getTerm Machine
m') Type
ty
           in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

        Apply Id
n ->
          case IdScope -> Id -> Machine -> Maybe Term
heapLookup IdScope
LocalId Id
n Machine
m' of
            Just Term
e ->
              let term :: Term
term = Term -> Term -> Term
App (Machine -> Term
getTerm Machine
m') Term
e
               in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

            Maybe Term
Nothing -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe Machine) -> [Char] -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
              [ [Char]
"Clash.Core.Evaluator.unwindStack:"
              , [Char]
"Stack:"
              ] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<>
              [ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Doc () -> [Char]
forall ann. Doc ann -> [Char]
showDoc (StackFrame -> Doc ()
forall a. ClashPretty a => a -> Doc ()
clashPretty StackFrame
frame) | StackFrame
frame <- Machine -> Stack
mStack Machine
m] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<>
              [ [Char]
""
              , [Char]
"Expression:"
              , Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr (Machine -> Term
mTerm Machine
m)
              , [Char]
""
              , [Char]
"Heap:"
              , Doc () -> [Char]
forall ann. Doc ann -> [Char]
showDoc (VarEnv Term -> Doc ()
forall a. ClashPretty a => a -> Doc ()
clashPretty (VarEnv Term -> Doc ()) -> VarEnv Term -> Doc ()
forall a b. (a -> b) -> a -> b
$ Machine -> VarEnv Term
mHeapLocal Machine
m)
              ]

        Scrutinise Type
_ [] ->
          Machine -> Maybe Machine
unwindStack Machine
m'

        Scrutinise Type
ty [Alt]
alts ->
          let term :: Term
term = Term -> Type -> [Alt] -> Term
Case (Machine -> Term
getTerm Machine
m') Type
ty [Alt]
alts
           in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

        Update IdScope
LocalId Id
x ->
          Machine -> Maybe Machine
unwindStack (IdScope -> Id -> Term -> Machine -> Machine
heapInsert IdScope
LocalId Id
x (Machine -> Term
mTerm Machine
m') Machine
m')

        Update IdScope
GlobalId Id
_ ->
          Machine -> Maybe Machine
unwindStack Machine
m'

        Tickish TickInfo
sp ->
          let term :: Term
term = TickInfo -> Term -> Term
Tick TickInfo
sp (Machine -> Term
getTerm Machine
m')
           in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

-- | A single step in the partial evaluator. The result is the new heap and
-- stack, and the next expression to be reduced.
--
type Step = Machine -> TyConMap -> Maybe Machine

type Unwind = Value -> Step

type PrimStep
  =  TyConMap
  -> Bool
  -> PrimInfo
  -> [Type]
  -> [Value]
  -> Machine
  -> Maybe Machine

type PrimUnwind
  =  TyConMap
  -> PrimInfo
  -> [Type]
  -> [Value]
  -> Value
  -> [Term]
  -> Machine
  -> Maybe Machine

-- | A machine represents the current state of the abstract machine used to
-- evaluate terms. A machine has a term under evaluation, a stack, and three
-- heaps:
--
--  * a primitive heap to store IO values from primitives (like ByteArrays)
--  * a global heap to store top-level bindings in scope
--  * a local heap to store local bindings in scope
--
-- Machines also include a unique supply and InScopeSet. These are needed when
-- new heap bindings are created, and are just an implementation detail.
--
data Machine = Machine
  { Machine -> PrimHeap
mHeapPrim   :: PrimHeap
  , Machine -> VarEnv Term
mHeapGlobal :: PureHeap
  , Machine -> VarEnv Term
mHeapLocal  :: PureHeap
  , Machine -> Stack
mStack      :: Stack
  , Machine -> Supply
mSupply     :: Supply
  , Machine -> InScopeSet
mScopeNames :: InScopeSet
  , Machine -> Term
mTerm       :: Term
  }

instance Show Machine where
  show :: Machine -> [Char]
show (Machine PrimHeap
ph VarEnv Term
gh VarEnv Term
lh Stack
s Supply
_ InScopeSet
_ Term
x) =
    [[Char]] -> [Char]
unlines
      [ [Char]
"Machine:"
      , [Char]
""
      , [Char]
"Heap (Prim):"
      , PrimHeap -> [Char]
forall a. Show a => a -> [Char]
show PrimHeap
ph
      , [Char]
""
      , [Char]
"Heap (Globals):"
      , VarEnv Term -> [Char]
forall a. Show a => a -> [Char]
show VarEnv Term
gh
      , [Char]
""
      , [Char]
"Heap (Locals):"
      , VarEnv Term -> [Char]
forall a. Show a => a -> [Char]
show VarEnv Term
lh
      , [Char]
""
      , [Char]
"Stack:"
      , [Doc ()] -> [Char]
forall a. Show a => a -> [Char]
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)
      , [Char]
""
      , [Char]
"Term:"
      , Term -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> [Char]
Stack -> [Char] -> [Char]
StackFrame -> [Char]
(Int -> StackFrame -> [Char] -> [Char])
-> (StackFrame -> [Char])
-> (Stack -> [Char] -> [Char])
-> Show StackFrame
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: Stack -> [Char] -> [Char]
$cshowList :: Stack -> [Char] -> [Char]
show :: StackFrame -> [Char]
$cshow :: StackFrame -> [Char]
showsPrec :: Int -> StackFrame -> [Char] -> [Char]
$cshowsPrec :: Int -> StackFrame -> [Char] -> [Char]
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
forall a. HasType a => a -> Type
coreTypeOf 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]

-- Values
data Value
  = Lambda Id Term
  -- ^ Functions
  | TyLambda TyVar Term
  -- ^ Type abstractions
  | DC DataCon [Either Term Type]
  -- ^ Data constructors
  | Lit Literal
  -- ^ Literals
  | PrimVal  PrimInfo [Type] [Value]
  -- ^ Clash's number types are represented by their "fromInteger#" primitive
  -- function. So some primitives are values.
  | Suspend Term
  -- ^ Used by lazy primitives
  | TickValue TickInfo Value
  -- ^ Preserve ticks from Terms in Values
  | CastValue Value Type Type
  -- ^ Preserve casts from Terms in Values
  deriving Int -> Value -> [Char] -> [Char]
[Value] -> [Char] -> [Char]
Value -> [Char]
(Int -> Value -> [Char] -> [Char])
-> (Value -> [Char]) -> ([Value] -> [Char] -> [Char]) -> Show Value
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Value] -> [Char] -> [Char]
$cshowList :: [Value] -> [Char] -> [Char]
show :: Value -> [Char]
$cshow :: Value -> [Char]
showsPrec :: Int -> Value -> [Char] -> [Char]
$cshowsPrec :: Int -> Value -> [Char] -> [Char]
Show

instance InferType Value where
  inferCoreTypeOf :: TyConMap -> Value -> Type
inferCoreTypeOf TyConMap
tcm = Value -> Type
go
   where
    go :: Value -> Type
go = \case
      Lambda Id
i Term
t -> Type -> Type -> Type
mkFunTy (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
i) (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
t)
      TyLambda TyVar
v Term
t -> TyVar -> Type -> Type
ForAllTy TyVar
v (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
t)
      DC DataCon
dc [Either Term Type]
args -> Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs (Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
dc) [Either Term Type]
args) TyConMap
tcm (DataCon -> Type
dcType DataCon
dc) [Either Term Type]
args
      Lit Literal
l -> Literal -> Type
forall a. HasType a => a -> Type
coreTypeOf Literal
l
      PrimVal PrimInfo
p [Type]
tys [Value]
vals ->
        let args :: [Either Term Type]
args = (Type -> Either Term Type) -> [Type] -> [Either Term Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either Term Type
forall a b. b -> Either a b
Right [Type]
tys [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++ (Value -> Either Term Type) -> [Value] -> [Either Term Type]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term Type
forall a b. a -> Either a b
Left (Term -> Either Term Type)
-> (Value -> Term) -> Value -> Either Term Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valToTerm) [Value]
vals
         in Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs
              (Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
p) [Either Term Type]
args)
              TyConMap
tcm
              (PrimInfo -> Type
primType PrimInfo
p)
              [Either Term Type]
args
      Suspend Term
t -> TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
t
      TickValue TickInfo
_ Value
v -> Value -> Type
go Value
v
      CastValue Value
_ Type
_ Type
t -> Type
t

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

-- Collect all the ticks from a value, exposing the ticked value.
--
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)

-- | Are we in a context where special primitives must be forced.
--
-- See [Note: forcing special primitives]
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
  -- When do we need to force the compile-time evaluation of a primitive?
  --
  -- 1. When they are the subject of a case-expression
  go :: Stack -> Bool
go (Scrutinise{}:Stack
_) = Bool
True
  -- 2. When they are in the argument position of another primitive:
  --    primitives are assumed to be strict in their arguments
  go (PrimApply{}:Stack
_)  = Bool
True
  -- We look through ticks
  go (Tickish{}:Stack
xs)   = Stack -> Bool
go Stack
xs
  -- We are in a context where we dereferenced a heap-binding, hence the
  -- update fram on the stack. So now we need to check whether that variable
  -- reference was in a position where the result must be evaluated to WHNF
  go (Update{}: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 -> VarEnv Term -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
i (VarEnv Term -> Maybe Term) -> VarEnv Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Machine -> VarEnv Term
mHeapGlobal Machine
m
heapLookup IdScope
LocalId Id
i Machine
m =
  Id -> VarEnv Term -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
i (VarEnv Term -> Maybe Term) -> VarEnv Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Machine -> VarEnv Term
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 :: VarEnv Term
mHeapGlobal = Id -> Term -> VarEnv Term -> VarEnv Term
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
i Term
x (Machine -> VarEnv Term
mHeapGlobal Machine
m) }
heapInsert IdScope
LocalId Id
i Term
x Machine
m =
  Machine
m { mHeapLocal :: VarEnv Term
mHeapLocal = Id -> Term -> VarEnv Term -> VarEnv Term
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
i Term
x (Machine -> VarEnv Term
mHeapLocal Machine
m) }

heapDelete :: IdScope -> Id -> Machine -> Machine
heapDelete :: IdScope -> Id -> Machine -> Machine
heapDelete IdScope
GlobalId Id
i Machine
m =
  Machine
m { mHeapGlobal :: VarEnv Term
mHeapGlobal = VarEnv Term -> Id -> VarEnv Term
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv (Machine -> VarEnv Term
mHeapGlobal Machine
m) Id
i }
heapDelete IdScope
LocalId Id
i Machine
m =
  Machine
m { mHeapLocal :: VarEnv Term
mHeapLocal = VarEnv Term -> Id -> VarEnv Term
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv (Machine -> VarEnv Term
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 }