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

      Call-by-need evaluator based on the evaluator described in:

      Maximilian Bolingbroke, Simon Peyton Jones, "Supercompilation by evaluation",
      Haskell '10, Baltimore, Maryland, USA.

    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Clash.GHC.Evaluator where

    import           Prelude                                 hiding (lookup)

    import           Control.Concurrent.Supply               (Supply, freshId)
    import           Data.Either                             (lefts,rights)
    import           Data.List                               (foldl',mapAccumL)
    import qualified Data.Primitive.ByteArray                as BA
    import qualified Data.Text as Text
    #if MIN_VERSION_base(4,15,0)
    import           GHC.Num.Integer                         (Integer (..))
    #else
    import           GHC.Integer.GMP.Internals
      (Integer (..), BigNat (..))
    #endif

    import           Clash.Core.DataCon
    import           Clash.Core.Evaluator.Types
    import           Clash.Core.HasFreeVars
    import           Clash.Core.HasType
    import           Clash.Core.Literal
    import           Clash.Core.Name
    import           Clash.Core.Pretty
    import           Clash.Core.Subst
    import           Clash.Core.Term
    import           Clash.Core.TyCon
    import           Clash.Core.Type
    import           Clash.Core.Util
    import           Clash.Core.Var
    import           Clash.Core.VarEnv
    import           Clash.Debug
    import qualified Clash.Normalize.Primitives as NP (removedArg, undefined, undefinedX)
    import           Clash.Unique
    import           Clash.Util                              (curLoc)

    import           Clash.GHC.Evaluator.Primitive

    evaluator :: Evaluator
    evaluator :: Evaluator
    evaluator = Evaluator
      { step :: Step
    step = Step
    ghcStep
      , unwind :: Unwind
    unwind = Unwind
    ghcUnwind
      , primStep :: PrimStep
    primStep = PrimStep
    ghcPrimStep
      , primUnwind :: PrimUnwind
    primUnwind = PrimUnwind
    ghcPrimUnwind
      }

    {- [Note: forcing special primitives]
    Clash uses the `whnf` function in two places (for now):

      1. The case-of-known-constructor transformation
      2. The reduceConstant transformation

    The first transformation is needed to reach the required normal form. The
    second transformation is more of cleanup transformation, so non-essential.

    Normally, `whnf` would force the evaluation of all primitives, which is needed
    in the `case-of-known-constructor` transformation. However, there are some
    primitives which we want to leave unevaluated in the `reduceConstant`
    transformation. Such primitives are:

      - Primitives such as `Clash.Sized.Vector.transpose`, `Clash.Sized.Vector.map`,
        etc. that do not reduce to an expression in normal form. Where the
        `reduceConstant` transformation is supposed to be normal-form preserving.
      - Primitives such as `GHC.Int.I8#`, `GHC.Word.W32#`, etc. which seem like
        wrappers around a 64-bit literal, but actually perform truncation to the
        desired bit-size.

    This is why the Primitive Evaluator gets a flag telling whether it should
    evaluate these special primitives.
    -}

    stepVar :: Id -> Step
    stepVar :: Id -> Step
    stepVar Id
    i Machine
    m TyConMap
    _
      | Just Term
    e <- IdScope -> Id -> Machine -> Maybe Term
    heapLookup IdScope
    LocalId Id
    i Machine
    m
      = IdScope -> Term -> Maybe Machine
    go IdScope
    LocalId Term
    e

      | Just Term
    e <- IdScope -> Id -> Machine -> Maybe Term
    heapLookup IdScope
    GlobalId Id
    i Machine
    m
      , Id -> Bool
    forall a. Var a -> Bool
    isGlobalId Id
    i
      = IdScope -> Term -> Maybe Machine
    go IdScope
    GlobalId Term
    e

      | Bool
    otherwise
      = Maybe Machine
    forall a. Maybe a
    Nothing
     where
      go :: IdScope -> Term -> Maybe Machine
    go IdScope
    s Term
    e =
        let term :: Term
    term = HasCallStack => InScopeSet -> Term -> Term
    InScopeSet -> Term -> Term
    deShadowTerm (Machine -> InScopeSet
    mScopeNames Machine
    m) (Term -> Term
    tickExpr Term
    e)
         in Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    term (Machine -> Machine) -> (Machine -> Machine) -> Machine -> Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StackFrame -> Machine -> Machine
    stackPush (IdScope -> Id -> StackFrame
    Update IdScope
    s Id
    i) (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ IdScope -> Id -> Machine -> Machine
    heapDelete IdScope
    s Id
    i Machine
    m

      -- Removing the heap-bound value on a force ensures we do not get stuck on
      -- expressions such as: "let x = x in x"
      tickExpr :: Term -> Term
    tickExpr = TickInfo -> Term -> Term
    Tick (NameMod -> Type -> TickInfo
    NameMod NameMod
    PrefixName (LitTy -> Type
    LitTy (LitTy -> Type) -> ([Char] -> LitTy) -> [Char] -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> LitTy
    SymTy ([Char] -> Type) -> [Char] -> Type
    forall a b. (a -> b) -> a -> b
    $ Id -> [Char]
    forall {a}. Var a -> [Char]
    toStr Id
    i))
      unQualName :: Text -> Text
    unQualName = (Text, Text) -> Text
    forall a b. (a, b) -> b
    snd ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HasCallStack => Text -> Text -> (Text, Text)
    Text -> Text -> (Text, Text)
    Text.breakOnEnd Text
    "."
      toStr :: Var a -> [Char]
    toStr = Text -> [Char]
    Text.unpack (Text -> [Char]) -> (Var a -> Text) -> Var a -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    unQualName (Text -> Text) -> (Var a -> Text) -> Var a -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> Char -> Text) -> Char -> Text -> Text
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Text -> Char -> Text
    Text.snoc Char
    '_' (Text -> Text) -> (Var a -> Text) -> Var a -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name a -> Text
    forall a. Name a -> Text
    nameOcc (Name a -> Text) -> (Var a -> Name a) -> Var a -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Var a -> Name a
    forall a. Var a -> Name a
    varName

    stepData :: DataCon -> Step
    stepData :: DataCon -> Step
    stepData DataCon
    dc = Unwind
    ghcUnwind (DataCon -> [Either Term Type] -> Value
    DC DataCon
    dc [])

    stepLiteral :: Literal -> Step
    stepLiteral :: Literal -> Step
    stepLiteral Literal
    l = Unwind
    ghcUnwind (Literal -> Value
    Lit Literal
    l)

    stepPrim :: PrimInfo -> Step
    stepPrim :: PrimInfo -> Step
    stepPrim PrimInfo
    pInfo Machine
    m TyConMap
    tcm
      | PrimInfo -> Text
    primName PrimInfo
    pInfo Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "GHC.Prim.realWorld#" =
          Unwind
    ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
    PrimVal PrimInfo
    pInfo [] []) Machine
    m TyConMap
    tcm

      | Bool
    otherwise =
          case ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> ([Either TyVar Type], Type)
    splitFunForallTy (PrimInfo -> Type
    primType PrimInfo
    pInfo) of
            []  -> PrimStep
    ghcPrimStep TyConMap
    tcm (Machine -> Bool
    forcePrims Machine
    m) PrimInfo
    pInfo [] [] Machine
    m
            [Either TyVar Type]
    tys -> [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys (PrimInfo -> Term
    Prim PrimInfo
    pInfo) Machine
    m TyConMap
    tcm

    stepLam :: Id -> Term -> Step
    stepLam :: Id -> Term -> Step
    stepLam Id
    x Term
    e = Unwind
    ghcUnwind (Id -> Term -> Value
    Lambda Id
    x Term
    e)

    stepTyLam :: TyVar -> Term -> Step
    stepTyLam :: TyVar -> Term -> Step
    stepTyLam TyVar
    x Term
    e = Unwind
    ghcUnwind (TyVar -> Term -> Value
    TyLambda TyVar
    x Term
    e)

    stepApp :: Term -> Term -> Step
    stepApp :: Term -> Term -> Step
    stepApp Term
    x Term
    y Machine
    m TyConMap
    tcm =
      case Term
    term of
        Data DataCon
    dc ->
          let tys :: [Either TyVar Type]
    tys = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> ([Either TyVar Type], Type)
    splitFunForallTy (DataCon -> Type
    dcType DataCon
    dc)
           in case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ([Either Term Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either Term Type]
    args) ([Either TyVar Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either TyVar Type]
    tys) of
                Ordering
    EQ -> Unwind
    ghcUnwind (DataCon -> [Either Term Type] -> Value
    DC DataCon
    dc [Either Term Type]
    args) Machine
    m TyConMap
    tcm
                Ordering
    LT -> [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys' (Term -> Term -> Term
    App Term
    x Term
    y) Machine
    m TyConMap
    tcm
                Ordering
    GT -> [Char] -> Maybe Machine
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Overapplied DC"

        Prim PrimInfo
    p ->
          let tys :: [Either TyVar Type]
    tys = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> ([Either TyVar Type], Type)
    splitFunForallTy (PrimInfo -> Type
    primType PrimInfo
    p)
           in case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ([Either Term Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either Term Type]
    args) ([Either TyVar Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either TyVar Type]
    tys) of
                Ordering
    EQ -> case [Either Term Type] -> [Term]
    forall a b. [Either a b] -> [a]
    lefts [Either Term Type]
    args of
                  -- We make boolean conjunction and disjunction extra lazy by
                  -- deferring the evaluation of the arguments during the evaluation
                  -- of the primop rule.
                  --
                  -- This allows us to implement:
                  --
                  -- x && True  --> x
                  -- x && False --> False
                  -- x || True  --> True
                  -- x || False --> x
                  --
                  -- even when that 'x' is _|_. This makes the evaluation
                  -- rule lazier than the actual Haskel implementations which
                  -- are strict in the first argument and lazy in the second.
                  [Term
    a0, Term
    a1] | PrimInfo -> Text
    primName PrimInfo
    p Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` [Text
    "GHC.Classes.&&",Text
    "GHC.Classes.||"] ->
                        let (Machine
    m0,Id
    i) = TyConMap -> Machine -> Term -> (Machine, Id)
    newLetBinding TyConMap
    tcm Machine
    m  Term
    a0
                            (Machine
    m1,Id
    j) = TyConMap -> Machine -> Term -> (Machine, Id)
    newLetBinding TyConMap
    tcm Machine
    m0 Term
    a1
                        in  PrimStep
    ghcPrimStep TyConMap
    tcm (Machine -> Bool
    forcePrims Machine
    m) PrimInfo
    p [] [Term -> Value
    Suspend (Id -> Term
    Var Id
    i), Term -> Value
    Suspend (Id -> Term
    Var Id
    j)] Machine
    m1

                  (Term
    e':[Term]
    es)
                    | PrimInfo -> Text
    primName PrimInfo
    p Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` ([Text]
    undefinedXPrims [Text] -> [Text] -> [Text]
    forall a. [a] -> [a] -> [a]
    ++ [Text]
    undefinedPrims)
                    -- The above primitives are (bottoming) values, whose arguments
                    -- are never used anywhere in the rest of the compiler. So
                    -- instead of pushing a PrimApply frame on the stack to evaluate
                    -- those arguments, we instead just unwind the stack with the
                    -- primitive value and leave its arguments in an unevaluated
                    -- state (Suspend).
                    -> Unwind
    ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
    PrimVal PrimInfo
    p ([Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args) ((Term -> Value) -> [Term] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map Term -> Value
    Suspend (Term
    e'Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    :[Term]
    es))) Machine
    m TyConMap
    tcm
                    | Bool
    otherwise
                    -> Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    e' (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
    PrimApply PrimInfo
    p ([Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args) [] [Term]
    es) Machine
    m

                  [Term]
    _ -> [Char] -> Maybe Machine
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "internal error"

                Ordering
    LT -> [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys' (Term -> Term -> Term
    App Term
    x Term
    y) Machine
    m TyConMap
    tcm

                Ordering
    GT -> let (Machine
    m0, Id
    n) = TyConMap -> Machine -> Term -> (Machine, Id)
    newLetBinding TyConMap
    tcm Machine
    m Term
    y
                       in Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    x (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (Id -> StackFrame
    Apply Id
    n) Machine
    m0

        Term
    _ -> let (Machine
    m0, Id
    n) = TyConMap -> Machine -> Term -> (Machine, Id)
    newLetBinding TyConMap
    tcm Machine
    m Term
    y
              in Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    x (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (Id -> StackFrame
    Apply Id
    n) Machine
    m0
     where
      (Term
    term, [Either Term Type]
    args, [TickInfo]
    _) = Term -> (Term, [Either Term Type], [TickInfo])
    collectArgsTicks (Term -> Term -> Term
    App Term
    x Term
    y)
      tys' :: [Either TyVar Type]
    tys' = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> (Term -> ([Either TyVar Type], Type))
    -> Term
    -> [Either TyVar Type]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> ([Either TyVar Type], Type)
    splitFunForallTy (Type -> ([Either TyVar Type], Type))
    -> (Term -> Type) -> Term -> ([Either TyVar Type], Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm (Term -> [Either TyVar Type]) -> Term -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Term -> Term -> Term
    App Term
    x Term
    y

    stepTyApp :: Term -> Type -> Step
    stepTyApp :: Term -> Type -> Step
    stepTyApp Term
    x Type
    ty Machine
    m TyConMap
    tcm =
      case Term
    term of
        Data DataCon
    dc ->
          let tys :: [Either TyVar Type]
    tys = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> ([Either TyVar Type], Type)
    splitFunForallTy (DataCon -> Type
    dcType DataCon
    dc)
           in case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ([Either Term Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either Term Type]
    args) ([Either TyVar Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either TyVar Type]
    tys) of
                Ordering
    EQ -> Unwind
    ghcUnwind (DataCon -> [Either Term Type] -> Value
    DC DataCon
    dc [Either Term Type]
    args) Machine
    m TyConMap
    tcm
                Ordering
    LT -> [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys' (Term -> Type -> Term
    TyApp Term
    x Type
    ty) Machine
    m TyConMap
    tcm
                Ordering
    GT -> [Char] -> Maybe Machine
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Overapplied DC"

        Prim PrimInfo
    p ->
          let tys :: [Either TyVar Type]
    tys = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> ([Either TyVar Type], Type)
    splitFunForallTy (PrimInfo -> Type
    primType PrimInfo
    p)
           in case Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare ([Either Term Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either Term Type]
    args) ([Either TyVar Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Either TyVar Type]
    tys) of
                Ordering
    EQ -> case [Either Term Type] -> [Term]
    forall a b. [Either a b] -> [a]
    lefts [Either Term Type]
    args of
                        [] | PrimInfo -> Text
    primName PrimInfo
    p Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: Type -> Type) a.
    (Foldable t, Eq a) =>
    a -> t a -> Bool
    `elem` (PrimInfo -> Text) -> [PrimInfo] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap PrimInfo -> Text
    primName [ PrimInfo
    NP.removedArg
                                                             , PrimInfo
    NP.undefined
                                                             , PrimInfo
    NP.undefinedX ] ->
                                Unwind
    ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
    PrimVal PrimInfo
    p ([Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args) []) Machine
    m TyConMap
    tcm

                           | Bool
    otherwise ->
                                PrimStep
    ghcPrimStep TyConMap
    tcm (Machine -> Bool
    forcePrims Machine
    m) PrimInfo
    p ([Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args) [] Machine
    m

                        (Term
    e':[Term]
    es) ->
                          Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    e' (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
    PrimApply PrimInfo
    p ([Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args) [] [Term]
    es) Machine
    m

                Ordering
    LT -> [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys' (Term -> Type -> Term
    TyApp Term
    x Type
    ty) Machine
    m TyConMap
    tcm
                Ordering
    GT -> Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    x (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (Type -> StackFrame
    Instantiate Type
    ty) Machine
    m

        Term
    _ -> Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    x (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (Type -> StackFrame
    Instantiate Type
    ty) Machine
    m
     where
      (Term
    term, [Either Term Type]
    args, [TickInfo]
    _) = Term -> (Term, [Either Term Type], [TickInfo])
    collectArgsTicks (Term -> Type -> Term
    TyApp Term
    x Type
    ty)
      tys' :: [Either TyVar Type]
    tys' = ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (([Either TyVar Type], Type) -> [Either TyVar Type])
    -> (Term -> ([Either TyVar Type], Type))
    -> Term
    -> [Either TyVar Type]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> ([Either TyVar Type], Type)
    splitFunForallTy (Type -> ([Either TyVar Type], Type))
    -> (Term -> Type) -> Term -> ([Either TyVar Type], Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm (Term -> [Either TyVar Type]) -> Term -> [Either TyVar Type]
    forall a b. (a -> b) -> a -> b
    $ Term -> Type -> Term
    TyApp Term
    x Type
    ty

    stepLet :: Bind Term -> Term -> Step
    stepLet :: Bind Term -> Term -> Step
    stepLet (NonRec Id
    i Term
    b) Term
    x Machine
    m TyConMap
    _ = Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just ([LetBinding] -> Term -> Machine -> Machine
    allocate [(Id
    i,Term
    b)] Term
    x Machine
    m)
    stepLet (Rec [LetBinding]
    bs) Term
    x Machine
    m TyConMap
    _ = Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just ([LetBinding] -> Term -> Machine -> Machine
    allocate [LetBinding]
    bs Term
    x Machine
    m)

    stepCase :: Term -> Type -> [Alt] -> Step
    stepCase :: Term -> Type -> [Alt] -> Step
    stepCase Term
    scrut Type
    ty [Alt]
    alts Machine
    m TyConMap
    _ =
      Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    scrut (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (Type -> [Alt] -> StackFrame
    Scrutinise Type
    ty [Alt]
    alts) Machine
    m

    -- TODO Support stepwise evaluation of casts.
    --
    stepCast :: Term -> Type -> Type -> Step
    stepCast :: Term -> Type -> Type -> Step
    stepCast Term
    _ Type
    _ Type
    _ Machine
    _ TyConMap
    _ =
      ([Char] -> Maybe Machine -> Maybe Machine)
    -> Maybe Machine -> [Char] -> Maybe Machine
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip [Char] -> Maybe Machine -> Maybe Machine
    forall a. [Char] -> a -> a
    trace Maybe Machine
    forall a. Maybe a
    Nothing ([Char] -> Maybe Machine) -> [Char] -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ [[Char]] -> [Char]
    unlines
        [ [Char]
    "WARNING: " [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> $(curLoc) [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> [Char]
    "Clash can't symbolically evaluate casts"
        , [Char]
    "Please file an issue at https://github.com/clash-lang/clash-compiler/issues"
        ]

    stepTick :: TickInfo -> Term -> Step
    stepTick :: TickInfo -> Term -> Step
    stepTick TickInfo
    tick Term
    x Machine
    m TyConMap
    _ =
      Machine -> Maybe Machine
    forall a. a -> Maybe a
    Just (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm Term
    x (Machine -> Maybe Machine) -> Machine -> Maybe Machine
    forall a b. (a -> b) -> a -> b
    $ StackFrame -> Machine -> Machine
    stackPush (TickInfo -> StackFrame
    Tickish TickInfo
    tick) Machine
    m

    -- | Small-step operational semantics.
    --
    ghcStep :: Step
    ghcStep :: Step
    ghcStep Machine
    m = case Machine -> Term
    mTerm Machine
    m of
      Var Id
    i -> Id -> Step
    stepVar Id
    i Machine
    m
      Data DataCon
    dc -> DataCon -> Step
    stepData DataCon
    dc Machine
    m
      Literal Literal
    l -> Literal -> Step
    stepLiteral Literal
    l Machine
    m
      Prim PrimInfo
    p -> PrimInfo -> Step
    stepPrim PrimInfo
    p Machine
    m
      Lam Id
    v Term
    x -> Id -> Term -> Step
    stepLam Id
    v Term
    x Machine
    m
      TyLam TyVar
    v Term
    x -> TyVar -> Term -> Step
    stepTyLam TyVar
    v Term
    x Machine
    m
      App Term
    x Term
    y -> Term -> Term -> Step
    stepApp Term
    x Term
    y Machine
    m
      TyApp Term
    x Type
    ty -> Term -> Type -> Step
    stepTyApp Term
    x Type
    ty Machine
    m
      Let Bind Term
    bs Term
    x -> Bind Term -> Term -> Step
    stepLet Bind Term
    bs Term
    x Machine
    m
      Case Term
    s Type
    ty [Alt]
    as -> Term -> Type -> [Alt] -> Step
    stepCase Term
    s Type
    ty [Alt]
    as Machine
    m
      Cast Term
    x Type
    a Type
    b -> Term -> Type -> Type -> Step
    stepCast Term
    x Type
    a Type
    b Machine
    m
      Tick TickInfo
    t Term
    x -> TickInfo -> Term -> Step
    stepTick TickInfo
    t Term
    x Machine
    m

    -- | Take a list of types or type variables and create a lambda / type lambda
    -- for each one around the given term.
    --
    newBinder :: [Either TyVar Type] -> Term -> Step
    newBinder :: [Either TyVar Type] -> Term -> Step
    newBinder [Either TyVar Type]
    tys Term
    x Machine
    m TyConMap
    tcm =
      let (Supply
    s', InScopeSet
    iss', Term
    x') = (Supply, InScopeSet, Term)
    -> [Either TyVar Type] -> (Supply, InScopeSet, Term)
    mkAbstr (Machine -> Supply
    mSupply Machine
    m, Machine -> InScopeSet
    mScopeNames Machine
    m, Term
    x) [Either TyVar Type]
    tys
          m' :: Machine
    m' = Machine
    m { mSupply :: Supply
    mSupply = Supply
    s', mScopeNames :: InScopeSet
    mScopeNames = InScopeSet
    iss', mTerm :: Term
    mTerm = Term
    x' }
       in Step
    ghcStep Machine
    m' TyConMap
    tcm
     where
      mkAbstr :: (Supply, InScopeSet, Term)
    -> [Either TyVar Type] -> (Supply, InScopeSet, Term)
    mkAbstr = (Either TyVar Type
     -> (Supply, InScopeSet, Term) -> (Supply, InScopeSet, Term))
    -> (Supply, InScopeSet, Term)
    -> [Either TyVar Type]
    -> (Supply, InScopeSet, Term)
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Either TyVar Type
    -> (Supply, InScopeSet, Term) -> (Supply, InScopeSet, Term)
    go
        where
          go :: Either TyVar Type
    -> (Supply, InScopeSet, Term) -> (Supply, InScopeSet, Term)
    go (Left TyVar
    tv) (Supply
    s', InScopeSet
    iss', Term
    e') =
            (Supply
    s', InScopeSet
    iss', TyVar -> Term -> Term
    TyLam TyVar
    tv (Term -> Type -> Term
    TyApp Term
    e' (TyVar -> Type
    VarTy TyVar
    tv)))

          go (Right Type
    ty) (Supply
    s', InScopeSet
    iss', Term
    e') =
            let ((Supply
    s'', InScopeSet
    _), Id
    n) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
    mkUniqSystemId (Supply
    s', InScopeSet
    iss') (Text
    "x", Type
    ty)
            in  (Supply
    s'', InScopeSet
    iss' ,Id -> Term -> Term
    Lam Id
    n (Term -> Term -> Term
    App Term
    e' (Id -> Term
    Var Id
    n)))

    newLetBinding
      :: TyConMap
      -> Machine
      -> Term
      -> (Machine, Id)
    newLetBinding :: TyConMap -> Machine -> Term -> (Machine, Id)
    newLetBinding TyConMap
    tcm Machine
    m Term
    e
      | Var Id
    v <- Term
    e
      , IdScope -> Id -> Machine -> Bool
    heapContains IdScope
    LocalId Id
    v Machine
    m
      = (Machine
    m, Id
    v)

      | Bool
    otherwise
      = let m' :: Machine
    m' = IdScope -> Id -> Term -> Machine -> Machine
    heapInsert IdScope
    LocalId Id
    id_ Term
    e Machine
    m
         in (Machine
    m' { mSupply :: Supply
    mSupply = Supply
    ids', mScopeNames :: InScopeSet
    mScopeNames = InScopeSet
    is1 }, Id
    id_)
     where
      ty :: Type
    ty = TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm Term
    e
      ((Supply
    ids', InScopeSet
    is1), Id
    id_) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
    mkUniqSystemId (Machine -> Supply
    mSupply Machine
    m, Machine -> InScopeSet
    mScopeNames Machine
    m) (Text
    "x", Type
    ty)

    -- | Unwind the stack by 1
    ghcUnwind :: Unwind
    ghcUnwind :: Unwind
    ghcUnwind Value
    v Machine
    m TyConMap
    tcm = do
      (Machine
    m', StackFrame
    kf) <- Machine -> Maybe (Machine, StackFrame)
    stackPop Machine
    m
      StackFrame -> Machine -> Maybe Machine
    go StackFrame
    kf Machine
    m'
     where
      go :: StackFrame -> Machine -> Maybe Machine
    go (Update IdScope
    s Id
    x)             = Machine -> Maybe Machine
    forall a. a -> Maybe a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdScope -> Id -> Value -> Machine -> Machine
    update IdScope
    s Id
    x Value
    v
      go (Apply Id
    x)                = Machine -> Maybe Machine
    forall a. a -> Maybe a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyConMap -> Value -> Id -> Machine -> Machine
    apply TyConMap
    tcm Value
    v Id
    x
      go (Instantiate Type
    ty)         = Machine -> Maybe Machine
    forall a. a -> Maybe a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyConMap -> Value -> Type -> Machine -> Machine
    instantiate TyConMap
    tcm Value
    v Type
    ty
      go (PrimApply PrimInfo
    p [Type]
    tys [Value]
    vs [Term]
    tms) = PrimUnwind
    ghcPrimUnwind TyConMap
    tcm PrimInfo
    p [Type]
    tys [Value]
    vs Value
    v [Term]
    tms
      go (Scrutinise Type
    altTy [Alt]
    as)    = Machine -> Maybe Machine
    forall a. a -> Maybe a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Value -> Type -> [Alt] -> Machine -> Machine
    scrutinise Value
    v Type
    altTy [Alt]
    as
      go (Tickish TickInfo
    _)              = Machine -> Maybe Machine
    forall a. a -> Maybe a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Machine -> Maybe Machine)
    -> (Machine -> Machine) -> Machine -> Maybe Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Machine -> Machine
    setTerm (Value -> Term
    valToTerm Value
    v)

    -- | Update the Heap with the evaluated term
    update :: IdScope -> Id -> Value -> Machine -> Machine
    update :: IdScope -> Id -> Value -> Machine -> Machine
    update IdScope
    s Id
    x (Value -> Term
    valToTerm -> Term
    term) =
      Term -> Machine -> Machine
    setTerm Term
    term (Machine -> Machine) -> (Machine -> Machine) -> Machine -> Machine
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdScope -> Id -> Term -> Machine -> Machine
    heapInsert IdScope
    s Id
    x Term
    term

    -- | Apply a value to a function
    apply :: TyConMap -> Value -> Id -> Machine -> Machine
    apply :: TyConMap -> Value -> Id -> Machine -> Machine
    apply TyConMap
    _tcm (Lambda Id
    x' Term
    e) Id
    x Machine
    m =
      Term -> Machine -> Machine
    setTerm (HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.apply" Subst
    subst Term
    e) Machine
    m
     where
      subst :: Subst
    subst  = Subst -> Id -> Term -> Subst
    extendIdSubst Subst
    subst0 Id
    x' (Id -> Term
    Var Id
    x)
      subst0 :: Subst
    subst0 = InScopeSet -> Subst
    mkSubst (InScopeSet -> Subst) -> InScopeSet -> Subst
    forall a b. (a -> b) -> a -> b
    $ InScopeSet -> Id -> InScopeSet
    forall a. InScopeSet -> Var a -> InScopeSet
    extendInScopeSet (Machine -> InScopeSet
    mScopeNames Machine
    m) Id
    x
    apply TyConMap
    tcm pVal :: Value
    pVal@(PrimVal (PrimInfo{Type
    primType :: PrimInfo -> Type
    primType :: Type
    primType}) [Type]
    tys [Value]
    vs) Id
    x Machine
    m
      | Value -> Bool
    isUndefinedXPrimVal Value
    pVal
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefinedX) Type
    ty) Machine
    m
      | Value -> Bool
    isUndefinedPrimVal Value
    pVal
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefined) Type
    ty) Machine
    m
     where
      ty :: Type
    ty = HasCallStack => TyConMap -> Type -> [Type] -> Type
    TyConMap -> Type -> [Type] -> Type
    piResultTys TyConMap
    tcm Type
    primType ([Type]
    tys [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ (Value -> Type) -> [Value] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm (Term -> Type) -> (Value -> Term) -> Value -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Value -> Term
    valToTerm) [Value]
    vs [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Id -> Type
    forall a. Var a -> Type
    varType Id
    x])

    apply TyConMap
    _ Value
    v Id
    _ Machine
    m = [Char] -> Machine
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Machine) -> [Char] -> Machine
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Evaluator.apply: Not a lambda: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Value -> [Char]
    forall a. Show a => a -> [Char]
    show Value
    v [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "\n" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Machine -> [Char]
    forall a. Show a => a -> [Char]
    show Machine
    m

    -- | Instantiate a type-abstraction
    instantiate :: TyConMap -> Value -> Type -> Machine -> Machine
    instantiate :: TyConMap -> Value -> Type -> Machine -> Machine
    instantiate TyConMap
    _tcm (TyLambda TyVar
    x Term
    e) Type
    ty Machine
    m =
      Term -> Machine -> Machine
    setTerm (HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.instantiate1" Subst
    subst Term
    e) Machine
    m
     where
      subst :: Subst
    subst  = Subst -> TyVar -> Type -> Subst
    extendTvSubst Subst
    subst0 TyVar
    x Type
    ty
      subst0 :: Subst
    subst0 = InScopeSet -> Subst
    mkSubst InScopeSet
    iss0
      iss0 :: InScopeSet
    iss0   = UniqMap (Var Any) -> InScopeSet
    mkInScopeSet (Term -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf Term
    e UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
    forall a. Semigroup a => a -> a -> a
    <> Type -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf Type
    ty)
    -- The evaluator is setup in such a way that under normal conditions anything
    -- of type 'forall a . ty' must be a ty-lambda.
    --
    -- However, sometimes we evaluate to an error /value/. When this happens,
    -- instead of doing a regural type substitition we:
    --
    -- 1. Calculate the 'forall a . ty' type of the error value
    -- 2. Substitute the 'a' by the applied type.
    -- 3. Create a new error value of the shape: 'undefined @substituted_type'
    --    Where this particular 'undefined' has type 'forall a . a'. We destinquish
    --    between error values throwing X exceptions and other error values, and
    --    create appropriate error values that we return. We make this distinctions
    --    in onder to enable conversion of X-exception throwing code to undefined
    --    bitvectors.
    instantiate TyConMap
    tcm pVal :: Value
    pVal@(PrimVal (PrimInfo{Type
    primType :: PrimInfo -> Type
    primType :: Type
    primType}) [Type]
    tys [Value]
    es) Type
    ty Machine
    m
      | Value -> Bool
    isUndefinedXPrimVal Value
    pVal
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefinedX) Type
    primType1) Machine
    m
      | Value -> Bool
    isUndefinedPrimVal Value
    pVal
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefined) Type
    primType1) Machine
    m
     where
      esTys :: [Type]
    esTys = (Value -> Type) -> [Value] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (TyConMap -> Value -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm) [Value]
    es
      -- Calculate the type of: prim @ty0 .. @tyN e0 .. eN @ty
      --
      -- This combines the above-mentioned step 1 and 2
      primType1 :: Type
    primType1 = HasCallStack => TyConMap -> Type -> [Type] -> Type
    TyConMap -> Type -> [Type] -> Type
    piResultTys TyConMap
    tcm Type
    primType ([Type]
    tys [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type]
    esTys [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type
    ty])

    instantiate TyConMap
    _ Value
    p Type
    _ Machine
    _ = [Char] -> Machine
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Machine) -> [Char] -> Machine
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Evaluator.instantiate: Not a tylambda: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Value -> [Char]
    forall a. Show a => a -> [Char]
    show Value
    p

    -- | Evaluate a case-expression
    scrutinise :: Value -> Type -> [Alt] -> Machine -> Machine
    scrutinise :: Value -> Type -> [Alt] -> Machine -> Machine
    scrutinise Value
    v Type
    _altTy [] Machine
    m = Term -> Machine -> Machine
    setTerm (Value -> Term
    valToTerm Value
    v) Machine
    m
    -- [Note: empty case expressions]
    --
    -- Clash does not have empty case-expressions; instead, empty case-expressions
    -- are used to indicate that the `whnf` function was called the context of a
    -- case-expression, which means certain special primitives must be forced.
    -- See also [Note: forcing special primitives]
    scrutinise (Lit Literal
    l) Type
    _altTy [Alt]
    alts Machine
    m = case [Alt]
    alts of
      (Pat
    DefaultPat, Term
    altE):[Alt]
    alts1 -> Term -> Machine -> Machine
    setTerm (Term -> [Alt] -> Term
    go Term
    altE [Alt]
    alts1) Machine
    m
      [Alt]
    _ -> let term :: Term
    term = Term -> [Alt] -> Term
    go ([Char] -> Term
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Term) -> [Char] -> Term
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Evaluator.scrutinise: no match "
                        [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> Term -> [Char]
    forall p. PrettyPrec p => p -> [Char]
    showPpr (Term -> Type -> [Alt] -> Term
    Case (Value -> Term
    valToTerm (Literal -> Value
    Lit Literal
    l)) (ConstTy -> Type
    ConstTy ConstTy
    Arrow) [Alt]
    alts)) [Alt]
    alts
            in Term -> Machine -> Machine
    setTerm Term
    term Machine
    m
     where
      go :: Term -> [Alt] -> Term
    go Term
    def [] = Term
    def
      go Term
    _ ((LitPat Literal
    l1,Term
    altE):[Alt]
    _) | Literal
    l1 Literal -> Literal -> Bool
    forall a. Eq a => a -> a -> Bool
    == Literal
    l = Term
    altE
      go Term
    _ ((DataPat DataCon
    dc [] [Id
    x],Term
    altE):[Alt]
    _)
        | IntegerLiteral Integer
    l1 <- Literal
    l
        , Just Literal
    patE <- case DataCon -> Int
    dcTag DataCon
    dc of
           Int
    1 | Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= ((-Integer
    2)Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    63::Int)) Bool -> Bool -> Bool
    &&  Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    < Integer
    2Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    63::Int) ->
              Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just (Integer -> Literal
    IntLiteral Integer
    l1)
           Int
    2 | Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= (Integer
    2Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    63::Int)) ->
    #if MIN_VERSION_base(4,15,0)
              let !(IP ByteArray#
    ba0) = Integer
    l1
    #else
              let !(Jp# !(BN# ba0)) = l1
    #endif
                  ba1 :: ByteArray
    ba1 = ByteArray# -> ByteArray
    BA.ByteArray ByteArray#
    ba0
              in  Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just (ByteArray -> Literal
    ByteArrayLiteral ByteArray
    ba1)
           Int
    3 | Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    < ((-Integer
    2)Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    63::Int)) ->
    #if MIN_VERSION_base(4,15,0)
              let !(IN ByteArray#
    ba0) = Integer
    l1
    #else
              let !(Jn# !(BN# ba0)) = l1
    #endif
                  ba1 :: ByteArray
    ba1 = ByteArray# -> ByteArray
    BA.ByteArray ByteArray#
    ba0
              in  Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just (ByteArray -> Literal
    ByteArrayLiteral ByteArray
    ba1)
           Int
    _ -> Maybe Literal
    forall a. Maybe a
    Nothing
        = let inScope :: UniqMap (Var Any)
    inScope = Term -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf Term
    altE
              subst0 :: Subst
    subst0  = InScopeSet -> Subst
    mkSubst (UniqMap (Var Any) -> InScopeSet
    mkInScopeSet UniqMap (Var Any)
    inScope)
              subst1 :: Subst
    subst1  = Subst -> Id -> Term -> Subst
    extendIdSubst Subst
    subst0 Id
    x (Literal -> Term
    Literal Literal
    patE)
          in  HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.scrutinise" Subst
    subst1 Term
    altE
        | NaturalLiteral Integer
    l1  <- Literal
    l
        , Just Literal
    patE <- case DataCon -> Int
    dcTag DataCon
    dc of
           Int
    1 | Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Integer
    0 Bool -> Bool -> Bool
    &&  Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    < Integer
    2Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    64::Int) ->
              Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just (Integer -> Literal
    WordLiteral Integer
    l1)
           Int
    2 | Integer
    l1 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= (Integer
    2Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    64::Int)) ->
    #if MIN_VERSION_base(4,15,0)
              let !(IP ByteArray#
    ba0) = Integer
    l1
    #else
              let !(Jp# !(BN# ba0)) = l1
    #endif
                  ba1 :: ByteArray
    ba1 = ByteArray# -> ByteArray
    BA.ByteArray ByteArray#
    ba0
              in  Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just (ByteArray -> Literal
    ByteArrayLiteral ByteArray
    ba1)
           Int
    _ -> Maybe Literal
    forall a. Maybe a
    Nothing
        = let inScope :: UniqMap (Var Any)
    inScope = Term -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf Term
    altE
              subst0 :: Subst
    subst0  = InScopeSet -> Subst
    mkSubst (UniqMap (Var Any) -> InScopeSet
    mkInScopeSet UniqMap (Var Any)
    inScope)
              subst1 :: Subst
    subst1  = Subst -> Id -> Term -> Subst
    extendIdSubst Subst
    subst0 Id
    x (Literal -> Term
    Literal Literal
    patE)
          in  HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.scrutinise" Subst
    subst1 Term
    altE
      go Term
    def (Alt
    _:[Alt]
    alts1) = Term -> [Alt] -> Term
    go Term
    def [Alt]
    alts1

    scrutinise (DC DataCon
    dc [Either Term Type]
    xs) Type
    _altTy [Alt]
    alts Machine
    m
      | Term
    altE:[Term]
    _ <- [DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
    substInAlt DataCon
    altDc [TyVar]
    tvs [Id]
    pxs [Either Term Type]
    xs Term
    altE
                  | (DataPat DataCon
    altDc [TyVar]
    tvs [Id]
    pxs,Term
    altE) <- [Alt]
    alts, DataCon
    altDc DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    dc ] [Term] -> [Term] -> [Term]
    forall a. [a] -> [a] -> [a]
    ++
                  [Term
    altE | (Pat
    DefaultPat,Term
    altE) <- [Alt]
    alts ]
      = Term -> Machine -> Machine
    setTerm Term
    altE Machine
    m

    scrutinise v :: Value
    v@(PrimVal PrimInfo
    p [Type]
    _ [Value]
    vs) Type
    altTy [Alt]
    alts Machine
    m
      | Value -> Bool
    isUndefinedXPrimVal Value
    v
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefinedX) Type
    altTy) Machine
    m
      | Value -> Bool
    isUndefinedPrimVal Value
    v
      = Term -> Machine -> Machine
    setTerm (Term -> Type -> Term
    TyApp (PrimInfo -> Term
    Prim PrimInfo
    NP.undefined) Type
    altTy) Machine
    m

      | (Alt -> Bool) -> [Alt] -> Bool
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> Bool) -> t a -> Bool
    any (\case {(LitPat {},Term
    _) -> Bool
    True; Alt
    _ -> Bool
    False}) [Alt]
    alts
      = case [Alt]
    alts of
          ((Pat
    DefaultPat,Term
    altE):[Alt]
    alts1) -> Term -> Machine -> Machine
    setTerm (Term -> [Alt] -> Term
    forall {t}. t -> [(Pat, t)] -> t
    go Term
    altE [Alt]
    alts1) Machine
    m
          [Alt]
    _ -> let term :: Term
    term = Term -> [Alt] -> Term
    forall {t}. t -> [(Pat, t)] -> t
    go ([Char] -> Term
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Term) -> [Char] -> Term
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Evaluator.scrutinise: no match "
                            [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> Term -> [Char]
    forall p. PrettyPrec p => p -> [Char]
    showPpr (Term -> Type -> [Alt] -> Term
    Case (Value -> Term
    valToTerm Value
    v) (ConstTy -> Type
    ConstTy ConstTy
    Arrow) [Alt]
    alts)) [Alt]
    alts
                in Term -> Machine -> Machine
    setTerm Term
    term Machine
    m
     where
      go :: t -> [(Pat, t)] -> t
    go t
    def [] = t
    def
      go t
    _   ((LitPat Literal
    l1,t
    altE):[(Pat, t)]
    _) | Literal
    l1 Literal -> Literal -> Bool
    forall a. Eq a => a -> a -> Bool
    == Literal
    l = t
    altE
      go t
    def ((Pat, t)
    _:[(Pat, t)]
    alts1) = t -> [(Pat, t)] -> t
    go t
    def [(Pat, t)]
    alts1

      l :: Literal
    l = case PrimInfo -> Text
    primName PrimInfo
    p of
            Text
    "Clash.Sized.Internal.BitVector.fromInteger##"
              | [Lit (WordLiteral Integer
    0), Lit Literal
    l0] <- [Value]
    vs -> Literal
    l0
            Text
    "Clash.Sized.Internal.BitVector.fromInteger#"
              | [Value
    _,Lit (NaturalLiteral Integer
    0),Lit Literal
    l0] <- [Value]
    vs -> Literal
    l0
            Text
    "Clash.Sized.Internal.Index.fromInteger#"
              | [Value
    _,Lit Literal
    l0] <- [Value]
    vs -> Literal
    l0
            Text
    "Clash.Sized.Internal.Signed.fromInteger#"
              | [Value
    _,Lit Literal
    l0] <- [Value]
    vs -> Literal
    l0
            Text
    "Clash.Sized.Internal.Unsigned.fromInteger#"
              | [Value
    _,Lit Literal
    l0] <- [Value]
    vs -> Literal
    l0
            Text
    _ -> [Char] -> Literal
    forall a. HasCallStack => [Char] -> a
    error ([Char]
    "scrutinise: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Term -> [Char]
    forall p. PrettyPrec p => p -> [Char]
    showPpr (Term -> Type -> [Alt] -> Term
    Case (Value -> Term
    valToTerm Value
    v) (ConstTy -> Type
    ConstTy ConstTy
    Arrow) [Alt]
    alts))

    scrutinise Value
    v Type
    _altTy [Alt]
    alts Machine
    _ =
      [Char] -> Machine
    forall a. HasCallStack => [Char] -> a
    error ([Char]
    "scrutinise: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Term -> [Char]
    forall p. PrettyPrec p => p -> [Char]
    showPpr (Term -> Type -> [Alt] -> Term
    Case (Value -> Term
    valToTerm Value
    v) (ConstTy -> Type
    ConstTy ConstTy
    Arrow) [Alt]
    alts))

    substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
    substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
    substInAlt DataCon
    dc [TyVar]
    tvs [Id]
    xs [Either Term Type]
    args Term
    e = HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.substInAlt" Subst
    subst Term
    e
     where
      tys :: [Type]
    tys        = [Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args
      tms :: [Term]
    tms        = [Either Term Type] -> [Term]
    forall a b. [Either a b] -> [a]
    lefts [Either Term Type]
    args
      substTyMap :: [(TyVar, Type)]
    substTyMap = [TyVar] -> [Type] -> [(TyVar, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [TyVar]
    tvs (Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    drop ([TyVar] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length (DataCon -> [TyVar]
    dcUnivTyVars DataCon
    dc)) [Type]
    tys)
      substTmMap :: [LetBinding]
    substTmMap = [Id] -> [Term] -> [LetBinding]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    xs [Term]
    tms
      inScope :: UniqMap (Var Any)
    inScope    = [Type] -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf [Type]
    tys UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
    `unionVarSet` [Term] -> UniqMap (Var Any)
    forall a. HasFreeVars a => a -> UniqMap (Var Any)
    freeVarsOf (Term
    eTerm -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    :[Term]
    tms)
      subst :: Subst
    subst      = Subst -> [(TyVar, Type)] -> Subst
    extendTvSubstList (Subst -> [LetBinding] -> Subst
    extendIdSubstList Subst
    subst0 [LetBinding]
    substTmMap) [(TyVar, Type)]
    substTyMap
      subst0 :: Subst
    subst0     = InScopeSet -> Subst
    mkSubst (UniqMap (Var Any) -> InScopeSet
    mkInScopeSet UniqMap (Var Any)
    inScope)

    -- | Allocate let-bindings on the heap
    allocate :: [LetBinding] -> Term -> Machine -> Machine
    allocate :: [LetBinding] -> Term -> Machine -> Machine
    allocate [LetBinding]
    xes Term
    e Machine
    m =
      Machine
    m { mHeapLocal :: PureHeap
    mHeapLocal = PureHeap -> [LetBinding] -> PureHeap
    forall a b. VarEnv a -> [(Var b, a)] -> VarEnv a
    extendVarEnvList (Machine -> PureHeap
    mHeapLocal Machine
    m) [LetBinding]
    xes'
        , mSupply :: Supply
    mSupply = Supply
    ids'
        , mScopeNames :: InScopeSet
    mScopeNames = InScopeSet
    isN
        , mTerm :: Term
    mTerm = Term
    e'
        }
     where
      xNms :: [Id]
    xNms      = (LetBinding -> Id) -> [LetBinding] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap LetBinding -> Id
    forall a b. (a, b) -> a
    fst [LetBinding]
    xes
      is1 :: InScopeSet
    is1       = InScopeSet -> [Id] -> InScopeSet
    forall a. InScopeSet -> [Var a] -> InScopeSet
    extendInScopeSetList (Machine -> InScopeSet
    mScopeNames Machine
    m) [Id]
    xNms
      (Supply
    ids', [(Id, LetBinding)]
    s) = (Supply -> Id -> (Supply, (Id, LetBinding)))
    -> Supply -> [Id] -> (Supply, [(Id, LetBinding)])
    forall (t :: Type -> Type) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL (PureHeap -> Supply -> Id -> (Supply, (Id, LetBinding))
    letSubst (Machine -> PureHeap
    mHeapLocal Machine
    m)) (Machine -> Supply
    mSupply Machine
    m) [Id]
    xNms
      ([Id]
    nms, [LetBinding]
    s') = [(Id, LetBinding)] -> ([Id], [LetBinding])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, LetBinding)]
    s
      isN :: InScopeSet
    isN       = InScopeSet -> [Id] -> InScopeSet
    forall a. InScopeSet -> [Var a] -> InScopeSet
    extendInScopeSetList InScopeSet
    is1 [Id]
    nms
      subst :: Subst
    subst     = Subst -> [LetBinding] -> Subst
    extendIdSubstList Subst
    subst0 [LetBinding]
    s'
      subst0 :: Subst
    subst0    = InScopeSet -> Subst
    mkSubst ((InScopeSet -> Id -> InScopeSet)
    -> InScopeSet -> [Id] -> InScopeSet
    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' InScopeSet -> Id -> InScopeSet
    forall a. InScopeSet -> Var a -> InScopeSet
    extendInScopeSet InScopeSet
    is1 [Id]
    nms)
      xes' :: [LetBinding]
    xes'      = [Id] -> [Term] -> [LetBinding]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    nms ((LetBinding -> Term) -> [LetBinding] -> [Term]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.allocate0" Subst
    subst (Term -> Term) -> (LetBinding -> Term) -> LetBinding -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LetBinding -> Term
    forall a b. (a, b) -> b
    snd) [LetBinding]
    xes)
      e' :: Term
    e'        = HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "Evaluator.allocate1" Subst
    subst Term
    e

    -- | Create a unique name and substitution for a let-binder
    letSubst
      :: PureHeap
      -> Supply
      -> Id
      -> (Supply, (Id, (Id, Term)))
    letSubst :: PureHeap -> Supply -> Id -> (Supply, (Id, LetBinding))
    letSubst PureHeap
    h Supply
    acc Id
    id0 =
      let (Supply
    acc',Id
    id1) = PureHeap -> Supply -> Id -> (Supply, Id)
    mkUniqueHeapId PureHeap
    h Supply
    acc Id
    id0
      in  (Supply
    acc',(Id
    id1,(Id
    id0,Id -> Term
    Var Id
    id1)))
     where
      mkUniqueHeapId :: PureHeap -> Supply -> Id -> (Supply, Id)
      mkUniqueHeapId :: PureHeap -> Supply -> Id -> (Supply, Id)
    mkUniqueHeapId PureHeap
    h' Supply
    ids Id
    x =
        (Supply, Id)
    -> (Term -> (Supply, Id)) -> Maybe Term -> (Supply, Id)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Supply
    ids', Id
    x') ((Supply, Id) -> Term -> (Supply, Id)
    forall a b. a -> b -> a
    const ((Supply, Id) -> Term -> (Supply, Id))
    -> (Supply, Id) -> Term -> (Supply, Id)
    forall a b. (a -> b) -> a -> b
    $ PureHeap -> Supply -> Id -> (Supply, Id)
    mkUniqueHeapId PureHeap
    h' Supply
    ids' Id
    x) (Id -> PureHeap -> Maybe Term
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Id
    x' PureHeap
    h')
       where
        (Int
    i,Supply
    ids') = Supply -> (Int, Supply)
    freshId Supply
    ids
        x' :: Id
    x'       = (Name Term -> Name Term) -> Id -> Id
    forall a. (Name a -> Name a) -> Var a -> Var a
    modifyVarName (Name Term -> Int -> Name Term
    forall a. Uniquable a => a -> Int -> a
    `setUnique` Int
    i) Id
    x