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

    {-|
      Copyright     : (C) 2020-2024, 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 Data.IntMap.Strict (IntMap)
    import qualified Data.IntMap.Strict as IntMap (insert, lookup)
    #if !MIN_VERSION_base(4,20,0)
    import Data.List (foldl')
    #endif
    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)
    import Clash.Util.Supply (Supply)

    whnf'
      :: Evaluator
      -> BindingMap
      -> VarEnv Term
      -> TyConMap
      -> PrimHeap
      -> Supply
      -> InScopeSet
      -> Bool
      -> Term
      -> (PrimHeap, PureHeap, Term)
    whnf' :: Evaluator
    -> BindingMap
    -> PureHeap
    -> TyConMap
    -> PrimHeap
    -> Supply
    -> InScopeSet
    -> Bool
    -> Term
    -> (PrimHeap, PureHeap, Term)
    whnf' Evaluator
    eval BindingMap
    bm PureHeap
    lh TyConMap
    tcm PrimHeap
    ph Supply
    ids InScopeSet
    is Bool
    isSubj Term
    e =
      Machine -> (PrimHeap, PureHeap, Term)
    toResult (Machine -> (PrimHeap, PureHeap, Term))
    -> Machine -> (PrimHeap, PureHeap, 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, PureHeap, Term)
    toResult Machine
    x = (Machine -> PrimHeap
    mHeapPrim Machine
    x, Machine -> PureHeap
    mHeapLocal Machine
    x, Machine -> Term
    mTerm Machine
    x)

      m :: Machine
    m  = PrimHeap
    -> PureHeap
    -> PureHeap
    -> Stack
    -> Supply
    -> InScopeSet
    -> Term
    -> Machine
    Machine PrimHeap
    ph PureHeap
    gh PureHeap
    lh [] Supply
    ids InScopeSet
    is Term
    e
      gh :: PureHeap
    gh = (Binding Term -> Term) -> BindingMap -> PureHeap
    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 (String -> Machine
    forall a. HasCallStack => String -> a
    error (String -> Machine) -> (Term -> String) -> Term -> Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Doc ClashAnnotation -> String
    forall ann. Doc ann -> String
    showDoc (Doc ClashAnnotation -> String)
    -> (Term -> Doc ClashAnnotation) -> Term -> String
    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
          (m', kf) <- Machine -> Maybe (Machine, StackFrame)
    stackPop Machine
    m

          case kf of
            PrimApply PrimInfo
    p [Type]
    tys [Value]
    vs [Term]
    tms ->
              let term :: Term
    term = (Term -> Term -> Term) -> Term -> [Term] -> Term
    forall b a. (b -> a -> b) -> b -> [a] -> b
    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 b a. (b -> a -> b) -> b -> [a] -> b
    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 b a. (b -> a -> b) -> b -> [a] -> b
    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 a b. (a -> b) -> [a] -> [b]
    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 -> String -> Maybe Machine
    forall a. HasCallStack => String -> a
    error (String -> Maybe Machine) -> String -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $
                  [ String
    "Clash.Core.Evaluator.unwindStack:"
                  , String
    "Stack:"
                  ] [String] -> [String] -> [String]
    forall a. Semigroup a => a -> a -> a
    <>
                  [ String
    "  " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Doc () -> String
    forall ann. Doc ann -> String
    showDoc (StackFrame -> Doc ()
    forall a. ClashPretty a => a -> Doc ()
    clashPretty StackFrame
    frame) | StackFrame
    frame <- Machine -> Stack
    mStack Machine
    m] [String] -> [String] -> [String]
    forall a. Semigroup a => a -> a -> a
    <>
                  [ String
    ""
                  , String
    "Expression:"
                  , Term -> String
    forall p. PrettyPrec p => p -> String
    showPpr (Machine -> Term
    mTerm Machine
    m)
                  , String
    ""
                  , String
    "Heap:"
                  , Doc () -> String
    forall ann. Doc ann -> String
    showDoc (PureHeap -> Doc ()
    forall a. ClashPretty a => a -> Doc ()
    clashPretty (PureHeap -> Doc ()) -> PureHeap -> Doc ()
    forall a b. (a -> b) -> a -> b
    $ Machine -> PureHeap
    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 -> 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 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 a b. (a -> b) -> [a] -> [b]
    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 -> String -> String
    Stack -> String -> String
    StackFrame -> String
    (Int -> StackFrame -> String -> String)
    -> (StackFrame -> String)
    -> (Stack -> String -> String)
    -> Show StackFrame
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> StackFrame -> String -> String
    showsPrec :: Int -> StackFrame -> String -> String
    $cshow :: StackFrame -> String
    show :: StackFrame -> String
    $cshowList :: Stack -> String -> String
    showList :: Stack -> String -> String
    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 -> String -> String
    [Value] -> String -> String
    Value -> String
    (Int -> Value -> String -> String)
    -> (Value -> String) -> ([Value] -> String -> String) -> Show Value
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> Value -> String -> String
    showsPrec :: Int -> Value -> String -> String
    $cshow :: Value -> String
    show :: Value -> String
    $cshowList :: [Value] -> String -> String
    showList :: [Value] -> String -> String
    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 b a. (b -> a -> b) -> b -> [a] -> b
    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 b a. (b -> a -> b) -> b -> [a] -> b
    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 b a. (b -> a -> b) -> b -> [a] -> b
    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 = (IntMap.insert i x gh, c + 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 = (IntMap.insert i x gh, 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 = extendVarEnv i x (mHeapGlobal m) }
    heapInsert IdScope
    LocalId Id
    i Term
    x Machine
    m =
      Machine
    m { mHeapLocal = extendVarEnv i x (mHeapLocal m) }

    heapDelete :: IdScope -> Id -> Machine -> Machine
    heapDelete :: IdScope -> Id -> Machine -> Machine
    heapDelete IdScope
    GlobalId Id
    i Machine
    m =
      Machine
    m { mHeapGlobal = delVarEnv (mHeapGlobal m) i }
    heapDelete IdScope
    LocalId Id
    i Machine
    m =
      Machine
    m { mHeapLocal = delVarEnv (mHeapLocal m) i }

    stackPush :: StackFrame -> Machine -> Machine
    stackPush :: StackFrame -> Machine -> Machine
    stackPush StackFrame
    f Machine
    m = Machine
    m { mStack = f : mStack 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 = xs }, StackFrame
    x)

    stackClear :: Machine -> Machine
    stackClear :: Machine -> Machine
    stackClear Machine
    m = Machine
    m { mStack = [] }

    stackNull :: Machine -> Bool
    stackNull :: Machine -> Bool
    stackNull = Stack -> Bool
    forall a. [a] -> 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 = x }