{-|
  Copyright   :  (C) 2017, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.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 BangPatterns      #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Core.Evaluator where

import           Control.Arrow                           (second)
import           Control.Concurrent.Supply               (Supply, freshId)
import           Control.Lens                            (view, _4)
import           Data.Bits                               (shiftL)
import           Data.Either                             (lefts,rights)
import           Data.List
  (foldl',mapAccumL,uncons)
import           Data.IntMap                             (IntMap)
import qualified Data.Primitive.ByteArray                as BA
import qualified Data.Vector.Primitive                   as PV
import           Data.Text                               (Text)
import           Data.Text.Prettyprint.Doc
import           Debug.Trace                             (trace)
import           GHC.Integer.GMP.Internals
  (Integer (..), BigNat (..))
import           Clash.Core.DataCon
import           Clash.Core.FreeVars
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.Driver.Types                      (BindingMap)
import           Prelude                                 hiding (lookup)
import           Clash.Unique
import           Clash.Util                              (curLoc)
import           Clash.Pretty

-- | The heap
data Heap = Heap GlobalHeap GPureHeap PureHeap Supply InScopeSet

type PureHeap = VarEnv Term
newtype GPureHeap = GPureHeap { GPureHeap -> PureHeap
unGPureHeap :: PureHeap }

-- | Global heap
type GlobalHeap = (IntMap Term, Int)

-- | The stack
type Stack = [StackFrame]

data StackFrame
  = Update Id
  | GUpdate Id
  | Apply  Id
  | Instantiate Type
  | PrimApply  Text PrimInfo [Type] [Value] [Term]
  | Scrutinise Type [Alt]
  | Tickish TickInfo
  deriving Int -> StackFrame -> ShowS
[StackFrame] -> ShowS
StackFrame -> String
(Int -> StackFrame -> ShowS)
-> (StackFrame -> String)
-> ([StackFrame] -> ShowS)
-> Show StackFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StackFrame] -> ShowS
$cshowList :: [StackFrame] -> ShowS
show :: StackFrame -> String
$cshow :: StackFrame -> String
showsPrec :: Int -> StackFrame -> ShowS
$cshowsPrec :: Int -> StackFrame -> ShowS
Show

instance ClashPretty StackFrame where
  clashPretty :: StackFrame -> Doc ()
clashPretty (Update i :: Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["Update", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
  clashPretty (GUpdate i :: Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["GUpdate", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
  clashPretty (Apply i :: Id
i) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["Apply", Id -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Id
i]
  clashPretty (Instantiate t :: Type
t) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["Instantiate", Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr Type
t]
  clashPretty (PrimApply a :: Text
a b :: PrimInfo
b c :: [Type]
c d :: [Value]
d e :: [Term]
e) = do
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["PrimApply", Text -> Doc ()
forall a. Pretty a => a -> Doc ()
fromPretty Text
a, "::", Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr (PrimInfo -> Type
primType PrimInfo
b),
          "; type args=", [Type] -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr [Type]
c,
          "; 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]
d),
          "term args=", [Term] -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr [Term]
e]
  clashPretty (Scrutinise a :: Type
a b :: [Alt]
b) =
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["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 '_')) Type
a [Alt]
b)]
  clashPretty (Tickish sp :: TickInfo
sp) =
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ["Tick", TickInfo -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr TickInfo
sp]

mkTickish
  :: Stack
  -> [TickInfo]
  -> Stack
mkTickish :: [StackFrame] -> [TickInfo] -> [StackFrame]
mkTickish s :: [StackFrame]
s sps :: [TickInfo]
sps = (TickInfo -> StackFrame) -> [TickInfo] -> [StackFrame]
forall a b. (a -> b) -> [a] -> [b]
map TickInfo -> StackFrame
Tickish [TickInfo]
sps [StackFrame] -> [StackFrame] -> [StackFrame]
forall a. [a] -> [a] -> [a]
++ [StackFrame]
s

-- Values
data Value
  = Lambda Id Term
  -- ^ Functions
  | TyLambda TyVar Term
  -- ^ Type abstractions
  | DC DataCon [Either Term Type]
  -- ^ Data constructors
  | Lit Literal
  -- ^ Literals
  | PrimVal  Text 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
  deriving Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show

-- | State of the evaluator
type State = (Heap, Stack, Term)

-- | Function that can evaluator primitives, i.e., perform delta-reduction
type PrimEvaluator =
  Bool -> -- Force special primitives? See [Note: forcing special primitives]
  TyConMap -> -- Type constructors
  Heap ->
  Stack ->
  Text -> -- Name of the primitive
  PrimInfo -> -- Type of the primitive
  [Type] -> -- Type arguments of the primitive
  [Value] -> -- Value arguments of the primitive
  Maybe State -- Delta-reduction can get stuck, so Nothing is an option

-- | Evaluate to WHNF starting with an empty Heap and Stack
whnf'
  :: PrimEvaluator
  -> BindingMap
  -> TyConMap
  -> GlobalHeap
  -> Supply
  -> InScopeSet
  -> Bool
  -> Term
  -> (GlobalHeap, PureHeap, Term)
whnf' :: PrimEvaluator
-> BindingMap
-> TyConMap
-> GlobalHeap
-> Supply
-> InScopeSet
-> Bool
-> Term
-> (GlobalHeap, PureHeap, Term)
whnf' eval :: PrimEvaluator
eval gbl0 :: BindingMap
gbl0 tcm :: TyConMap
tcm gh :: GlobalHeap
gh ids :: Supply
ids is :: InScopeSet
is isSubj :: Bool
isSubj e :: Term
e
  = case PrimEvaluator -> TyConMap -> Bool -> State -> State
whnf PrimEvaluator
eval TyConMap
tcm Bool
isSubj (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl1 PureHeap
forall a. VarEnv a
emptyVarEnv Supply
ids InScopeSet
is,[],Term
e) of
      (Heap gh' :: GlobalHeap
gh' _ ph' :: PureHeap
ph' _ _,_,e' :: Term
e') -> (GlobalHeap
gh',PureHeap
ph',Term
e')
 where
  gbl1 :: GPureHeap
gbl1 = PureHeap -> GPureHeap
GPureHeap (((Id, SrcSpan, InlineSpec, Term) -> Term) -> BindingMap -> PureHeap
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Getting Term (Id, SrcSpan, InlineSpec, Term) Term
-> (Id, SrcSpan, InlineSpec, Term) -> Term
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Term (Id, SrcSpan, InlineSpec, Term) Term
forall s t a b. Field4 s t a b => Lens s t a b
_4) BindingMap
gbl0)

-- | Evaluate to WHNF given an existing Heap and Stack
whnf
  :: PrimEvaluator
  -> TyConMap
  -> Bool
  -> State
  -> State
whnf :: PrimEvaluator -> TyConMap -> Bool -> State -> State
whnf eval :: PrimEvaluator
eval tcm :: TyConMap
tcm isSubj :: Bool
isSubj (h :: Heap
h,k :: [StackFrame]
k,e :: Term
e) =
    if Bool
isSubj
       then State -> State
go (Heap
h,Type -> [Alt] -> StackFrame
Scrutinise Type
ty []StackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e) -- See [Note: empty case expressions]
       else State -> State
go (Heap
h,[StackFrame]
k,Term
e)
  where
    ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e

    go :: State -> State
go s :: State
s = case PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm State
s of
      Just s' :: State
s' -> State -> State
go State
s'
      Nothing
        | Just e' :: State
e' <- State -> Maybe State
unwindStack State
s
        -> State
e'
        | Bool
otherwise
        -> String -> State
forall a. HasCallStack => String -> a
error (String -> State) -> String -> State
forall a b. (a -> b) -> a -> b
$ Doc ClashAnnotation -> String
forall ann. Doc ann -> String
showDoc (Doc ClashAnnotation -> String) -> Doc ClashAnnotation -> String
forall a b. (a -> b) -> a -> b
$ Term -> Doc ClashAnnotation
forall p. PrettyPrec p => p -> Doc ClashAnnotation
ppr Term
e

-- | Are we in a context where special primitives must be forced.
--
-- See [Note: forcing special primitives]
isScrut :: Stack -> Bool
isScrut :: [StackFrame] -> Bool
isScrut (Scrutinise {}:_) = Bool
True
isScrut (PrimApply {} :_) = Bool
True
isScrut (Tickish {}:k :: [StackFrame]
k) = [StackFrame] -> Bool
isScrut [StackFrame]
k
isScrut _ = Bool
False

-- | Completely unwind the stack to get back the complete term
unwindStack :: State -> Maybe State
unwindStack :: State -> Maybe State
unwindStack s :: State
s@(_,[],_) = State -> Maybe State
forall a. a -> Maybe a
Just State
s
unwindStack (h :: Heap
h@(Heap gh :: GlobalHeap
gh gbl :: GPureHeap
gbl h' :: PureHeap
h' ids :: Supply
ids is :: InScopeSet
is),(kf :: StackFrame
kf:k' :: [StackFrame]
k'),e :: Term
e) = case StackFrame
kf of
  PrimApply nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vs :: [Value]
vs tms :: [Term]
tms ->
    State -> Maybe State
unwindStack
      (Heap
h,[StackFrame]
k'
      ,(Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App
              ((Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App ((Term -> Type -> Term) -> Term -> [Type] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Type -> Term
TyApp (Text -> PrimInfo -> Term
Prim Text
nm PrimInfo
ty) [Type]
tys) ((Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Term
valToTerm [Value]
vs))
              (Term
eTerm -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
tms))
  Instantiate ty :: Type
ty ->
    State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',Term -> Type -> Term
TyApp Term
e Type
ty)
  Apply id_ :: Id
id_ -> do
    case Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ PureHeap
h' of
      Just e' :: Term
e' -> State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',Term -> Term -> Term
App Term
e Term
e')
      Nothing -> String -> Maybe State
forall a. HasCallStack => String -> a
error (String -> Maybe State) -> String -> Maybe State
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                       ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ "Clash.Core.Evaluator.unwindStack:"
                         , "Stack:"
                         ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                         [ "  "String -> ShowS
forall 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 <- StackFrame
kfStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                         [ ""
                         , "Expression:"
                         , Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
                         , ""
                         , "Heap:"
                         , Doc () -> String
forall ann. Doc ann -> String
showDoc (PureHeap -> Doc ()
forall a. ClashPretty a => a -> Doc ()
clashPretty PureHeap
h')
                         ]
  Scrutinise _ [] ->
    State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',Term
e)
  Scrutinise ty :: Type
ty alts :: [Alt]
alts ->
    State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',Term -> Type -> [Alt] -> Term
Case Term
e Type
ty [Alt]
alts)
  Update x :: Id
x ->
    State -> Maybe State
unwindStack (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl (Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
x Term
e PureHeap
h') Supply
ids InScopeSet
is,[StackFrame]
k',Term
e)
  GUpdate _ ->
    State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',Term
e)
  Tickish sp :: TickInfo
sp ->
    State -> Maybe State
unwindStack (Heap
h,[StackFrame]
k',TickInfo -> Term -> Term
Tick TickInfo
sp Term
e)

{- [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.
-}

-- | Small-step operational semantics.
step
  :: PrimEvaluator
  -> TyConMap
  -> State
  -> Maybe State
step :: PrimEvaluator -> TyConMap -> State -> Maybe State
step eval :: PrimEvaluator
eval tcm :: TyConMap
tcm (h :: Heap
h, k :: [StackFrame]
k, e :: Term
e) = case Term
e of
  Var v :: Id
v        -> Heap -> [StackFrame] -> Id -> Maybe State
force Heap
h [StackFrame]
k Id
v
  (Lam x :: Id
x e' :: Term
e')   -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Id -> Term -> Value
Lambda Id
x Term
e')
  (TyLam x :: TyVar
x e' :: Term
e') -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (TyVar -> Term -> Value
TyLambda TyVar
x Term
e')
  (Literal l :: Literal
l)  -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Literal -> Value
Lit Literal
l)
  (App e1 :: Term
e1 e2 :: Term
e2)
    | (Data dc :: DataCon
dc,args :: [Either Term Type]
args,_ticks :: [TickInfo]
_ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
    , (tys :: [Either TyVar Type]
tys,_) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy (DataCon -> Type
dcType DataCon
dc)
    -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Either Term Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
         EQ -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
         LT -> let (tys' :: [Either TyVar Type]
tys',_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                   (h2 :: Heap
h2,e' :: Term
e')  = (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr (Heap
h,Term
e) [Either TyVar Type]
tys'
               in  PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm (Heap
h2,[StackFrame]
k,Term
e')
         GT -> String -> Maybe State
forall a. HasCallStack => String -> a
error "Overapplied DC"
    | (Prim nm :: Text
nm pInfo :: PrimInfo
pInfo,args :: [Either Term Type]
args,_ticks :: [TickInfo]
_ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
    , let ty :: Type
ty = PrimInfo -> Type
primType PrimInfo
pInfo
    , (tys :: [Either TyVar Type]
tys,_) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
    -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Either Term Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
         EQ -> let (e' :: Term
e':es :: [Term]
es) = [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
               in  State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Text -> PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
PrimApply Text
nm PrimInfo
pInfo ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args) [] [Term]
esStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e')
         LT -> let (tys' :: [Either TyVar Type]
tys',_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                   (h2 :: Heap
h2,e' :: Term
e') = (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr (Heap
h,Term
e) [Either TyVar Type]
tys'
               in  PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm (Heap
h2,[StackFrame]
k,Term
e')
         GT -> let (h2 :: Heap
h2,id_ :: Id
id_) = TyConMap -> Heap -> Term -> (Heap, Id)
newLetBinding TyConMap
tcm Heap
h Term
e2
               in  State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h2,Id -> StackFrame
Apply Id
id_StackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e1)
  (TyApp e1 :: Term
e1 ty :: Type
ty)
    | (Data dc :: DataCon
dc,args :: [Either Term Type]
args,_ticks :: [TickInfo]
_ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
    , (tys :: [Either TyVar Type]
tys,_) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy (DataCon -> Type
dcType DataCon
dc)
    -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Either Term Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
         EQ -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
         LT -> let (tys' :: [Either TyVar Type]
tys',_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                   (h2 :: Heap
h2,e' :: Term
e') = (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr (Heap
h,Term
e) [Either TyVar Type]
tys'
               in  PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm (Heap
h2,[StackFrame]
k,Term
e')
         GT -> String -> Maybe State
forall a. HasCallStack => String -> a
error "Overapplied DC"
    | (Prim nm :: Text
nm pInfo :: PrimInfo
pInfo,args :: [Either Term Type]
args,_ticks :: [TickInfo]
_ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
    , let ty' :: Type
ty' = PrimInfo -> Type
primType PrimInfo
pInfo
    , (tys :: [Either TyVar Type]
tys,_) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty'
    -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Either Term Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
         EQ -> case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
              [] | Text
nm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["Clash.Transformations.removedArg"]
                 -- The above primitives are actually values, and not operations.
                 -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
pInfo ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args) [])
                 | Bool
otherwise
                 -> PrimEvaluator
eval ([StackFrame] -> Bool
isScrut [StackFrame]
k) TyConMap
tcm Heap
h [StackFrame]
k Text
nm PrimInfo
pInfo ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args) []
              (e' :: Term
e':es :: [Term]
es) -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Text -> PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
PrimApply Text
nm PrimInfo
pInfo ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args) [] [Term]
esStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e')
         LT -> let (tys' :: [Either TyVar Type]
tys',_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                   (h2 :: Heap
h2,e' :: Term
e') = (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr (Heap
h,Term
e) [Either TyVar Type]
tys'
               in  PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm (Heap
h2,[StackFrame]
k,Term
e')
         GT -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Type -> StackFrame
Instantiate Type
tyStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e1)
  (Data dc :: DataCon
dc) -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [])
  (Prim nm :: Text
nm pInfo :: PrimInfo
pInfo)
    | Text
nm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["GHC.Prim.realWorld#"]
    -> PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
pInfo [] [])
    | Bool
otherwise
    , let ty' :: Type
ty' = PrimInfo -> Type
primType PrimInfo
pInfo
    -> case ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty')  of
        []  -> PrimEvaluator
eval ([StackFrame] -> Bool
isScrut [StackFrame]
k) TyConMap
tcm Heap
h [StackFrame]
k Text
nm PrimInfo
pInfo [] []
        tys :: [Either TyVar Type]
tys -> let (h2 :: Heap
h2,e' :: Term
e') = (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr (Heap
h,Term
e) [Either TyVar Type]
tys
               in  PrimEvaluator -> TyConMap -> State -> Maybe State
step PrimEvaluator
eval TyConMap
tcm (Heap
h2,[StackFrame]
k,Term
e')
  (App e1 :: Term
e1 e2 :: Term
e2)  -> let (h2 :: Heap
h2,id_ :: Id
id_) = TyConMap -> Heap -> Term -> (Heap, Id)
newLetBinding TyConMap
tcm Heap
h Term
e2
                  in  State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h2,Id -> StackFrame
Apply Id
id_StackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e1)
  (TyApp e1 :: Term
e1 ty :: Type
ty) -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Type -> StackFrame
Instantiate Type
tyStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e1)
  (Case scrut :: Term
scrut ty :: Type
ty alts :: [Alt]
alts) -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Type -> [Alt] -> StackFrame
Scrutinise Type
ty [Alt]
altsStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
scrut)
  (Letrec bs :: [LetBinding]
bs e' :: Term
e') -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap -> [StackFrame] -> [LetBinding] -> Term -> State
allocate Heap
h [StackFrame]
k [LetBinding]
bs Term
e')
  Tick sp :: TickInfo
sp e' :: Term
e' -> State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,TickInfo -> StackFrame
Tickish TickInfo
spStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e')
  Cast _ _ _ -> String -> Maybe State -> Maybe State
forall a. String -> a -> a
trace ([String] -> String
unlines ["WARNING: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ $(curLoc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Clash currently can't symbolically evaluate casts"
                                    ,"If you have testcase that produces this message, please open an issue about it."]) Maybe State
forall a. Maybe a
Nothing

newLetBinding
  :: TyConMap
  -> Heap
  -> Term
  -> (Heap,Id)
newLetBinding :: TyConMap -> Heap -> Term -> (Heap, Id)
newLetBinding tcm :: TyConMap
tcm h :: Heap
h@(Heap gh :: GlobalHeap
gh gbl :: GPureHeap
gbl h' :: PureHeap
h' ids :: Supply
ids is0 :: InScopeSet
is0) e :: Term
e
  | Var v :: Id
v <- Term
e
  , Just _ <- Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
v PureHeap
h'
  = (Heap
h, Id
v)
  | Bool
otherwise
  = (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl (Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
id_ Term
e PureHeap
h') Supply
ids' InScopeSet
is1,Id
id_)
  where
    ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
    ((ids' :: Supply
ids',is1 :: InScopeSet
is1),id_ :: Id
id_) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
mkUniqSystemId (Supply
ids,InScopeSet
is0) ("x",Type
ty)

newLetBindings'
  :: TyConMap
  -> Heap
  -> [Either Term Type]
  -> (Heap,[Either Term Type])
newLetBindings' :: TyConMap
-> Heap -> [Either Term Type] -> (Heap, [Either Term Type])
newLetBindings' tcm :: TyConMap
tcm =
    (([Either Id Type] -> [Either Term Type])
-> (Heap, [Either Id Type]) -> (Heap, [Either Term Type])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Either Id Type -> Either Term Type)
-> [Either Id Type] -> [Either Term Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Either Term Type)
-> (Type -> Either Term Type) -> Either Id Type -> Either Term Type
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Term -> Either Term Type
forall a b. a -> Either a b
Left (Term -> Either Term Type)
-> (Id -> Term) -> Id -> Either Term Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Term
toVar) (Type -> Either Term Type
forall a b. b -> Either a b
Right (Type -> Either Term Type)
-> (Type -> Type) -> Type -> Either Term Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
forall a. a -> a
id))) ((Heap, [Either Id Type]) -> (Heap, [Either Term Type]))
-> ([Either Term Type] -> (Heap, [Either Id Type]))
-> [Either Term Type]
-> (Heap, [Either Term Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Either Term Type] -> (Heap, [Either Id Type]))
 -> [Either Term Type] -> (Heap, [Either Term Type]))
-> (Heap -> [Either Term Type] -> (Heap, [Either Id Type]))
-> Heap
-> [Either Term Type]
-> (Heap, [Either Term Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Heap -> Either Term Type -> (Heap, Either Id Type))
-> Heap -> [Either Term Type] -> (Heap, [Either Id Type])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Heap -> Either Term Type -> (Heap, Either Id Type)
forall b. Heap -> Either Term b -> (Heap, Either Id b)
go
  where
    go :: Heap -> Either Term b -> (Heap, Either Id b)
go h :: Heap
h (Left tm :: Term
tm)  = (Id -> Either Id b) -> (Heap, Id) -> (Heap, Either Id b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Id -> Either Id b
forall a b. a -> Either a b
Left (TyConMap -> Heap -> Term -> (Heap, Id)
newLetBinding TyConMap
tcm Heap
h Term
tm)
    go h :: Heap
h (Right ty :: b
ty) = (Heap
h,b -> Either Id b
forall a b. b -> Either a b
Right b
ty)

mkAbstr
  :: (Heap,Term)
  -> [Either TyVar Type]
  -> (Heap,Term)
mkAbstr :: (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
mkAbstr = (Either TyVar Type -> (Heap, Term) -> (Heap, Term))
-> (Heap, Term) -> [Either TyVar Type] -> (Heap, Term)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Either TyVar Type -> (Heap, Term) -> (Heap, Term)
go
  where
    go :: Either TyVar Type -> (Heap, Term) -> (Heap, Term)
go (Left tv :: TyVar
tv)  (h :: Heap
h,e :: Term
e)          =
      (Heap
h,TyVar -> Term -> Term
TyLam TyVar
tv (Term -> Type -> Term
TyApp Term
e (TyVar -> Type
VarTy TyVar
tv)))
    go (Right ty :: Type
ty) (Heap gh :: GlobalHeap
gh gbl :: GPureHeap
gbl h :: PureHeap
h ids :: Supply
ids is :: InScopeSet
is,e :: Term
e) =
      let ((ids' :: Supply
ids',_),id_ :: Id
id_) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
mkUniqSystemId (Supply
ids,InScopeSet
is) ("x",Type
ty)
      in  (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl PureHeap
h Supply
ids' InScopeSet
is,Id -> Term -> Term
Lam Id
id_ (Term -> Term -> Term
App Term
e (Id -> Term
Var Id
id_)))

-- | Force the evaluation of a variable.
force :: Heap -> Stack -> Id -> Maybe State
force :: Heap -> [StackFrame] -> Id -> Maybe State
force (Heap gh :: GlobalHeap
gh g :: GPureHeap
g@(GPureHeap gbl :: PureHeap
gbl) h :: PureHeap
h ids :: Supply
ids is :: InScopeSet
is) k :: [StackFrame]
k x' :: Id
x' = case Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
x' PureHeap
h of
    Nothing -> case Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
x' PureHeap
gbl of
      Just e :: Term
e | Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
x'
        -> State -> Maybe State
forall a. a -> Maybe a
Just (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh (PureHeap -> GPureHeap
GPureHeap (PureHeap -> Id -> PureHeap
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv PureHeap
gbl Id
x')) PureHeap
h Supply
ids InScopeSet
is,Id -> StackFrame
GUpdate Id
x'StackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e)
      _ -> Maybe State
forall a. Maybe a
Nothing
    Just e :: Term
e -> State -> Maybe State
forall a. a -> Maybe a
Just (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
g (PureHeap -> Id -> PureHeap
forall a b. VarEnv a -> Var b -> VarEnv a
delVarEnv PureHeap
h Id
x') Supply
ids InScopeSet
is,Id -> StackFrame
Update Id
x'StackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e)
    -- Removing the heap-bound value on a force ensures we do not get stuck on
    -- expressions such as: "let x = x in x"

-- | Unwind the stack by 1
unwind
  :: PrimEvaluator
  -> TyConMap
  -> Heap -> Stack -> Value -> Maybe State
unwind :: PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind eval :: PrimEvaluator
eval tcm :: TyConMap
tcm h :: Heap
h k :: [StackFrame]
k v :: Value
v = do
  (kf :: StackFrame
kf,k' :: [StackFrame]
k') <- [StackFrame] -> Maybe (StackFrame, [StackFrame])
forall a. [a] -> Maybe (a, [a])
uncons [StackFrame]
k
  case StackFrame
kf of
    Update x :: Id
x                     -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap -> [StackFrame] -> Id -> Value -> State
update Heap
h [StackFrame]
k' Id
x Value
v)
    GUpdate x :: Id
x                    -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap -> [StackFrame] -> Id -> Value -> State
gupdate Heap
h [StackFrame]
k' Id
x Value
v)
    Apply x :: Id
x                      -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap -> [StackFrame] -> Value -> Id -> State
apply  Heap
h [StackFrame]
k' Value
v Id
x)
    Instantiate ty :: Type
ty               -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap -> [StackFrame] -> Value -> Type -> State
instantiate Heap
h [StackFrame]
k' Value
v Type
ty)
    PrimApply nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vals :: [Value]
vals tms :: [Term]
tms -> PrimEvaluator
-> TyConMap
-> Heap
-> [StackFrame]
-> Text
-> PrimInfo
-> [Type]
-> [Value]
-> Value
-> [Term]
-> Maybe State
primop PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k' Text
nm PrimInfo
ty [Type]
tys [Value]
vals Value
v [Term]
tms
    Scrutinise _ alts :: [Alt]
alts            -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap -> [StackFrame] -> Value -> [Alt] -> State
scrutinise Heap
h [StackFrame]
k' Value
v [Alt]
alts)
    -- Adding back the Tick constructor will make the evaluator loop
    Tickish _                    -> State -> Maybe State
forall (m :: * -> *) a. Monad m => a -> m a
return (Heap
h,[StackFrame]
k',Value -> Term
valToTerm Value
v)

-- | Update the Heap with the evaluated term
update :: Heap -> Stack -> Id -> Value -> State
update :: Heap -> [StackFrame] -> Id -> Value -> State
update (Heap gh :: GlobalHeap
gh gbl :: GPureHeap
gbl h :: PureHeap
h ids :: Supply
ids is :: InScopeSet
is) k :: [StackFrame]
k x :: Id
x v :: Value
v = (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl (Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
x Term
v' PureHeap
h) Supply
ids InScopeSet
is,[StackFrame]
k,Term
v')
  where
    v' :: Term
v' = Value -> Term
valToTerm Value
v

-- | Update the Globals with the evaluated term
gupdate :: Heap -> Stack -> Id -> Value -> State
gupdate :: Heap -> [StackFrame] -> Id -> Value -> State
gupdate (Heap gh :: GlobalHeap
gh (GPureHeap gbl :: PureHeap
gbl) h :: PureHeap
h ids :: Supply
ids is :: InScopeSet
is) k :: [StackFrame]
k x :: Id
x v :: Value
v =
  (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh (PureHeap -> GPureHeap
GPureHeap (Id -> Term -> PureHeap -> PureHeap
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
x Term
v' PureHeap
gbl)) PureHeap
h Supply
ids InScopeSet
is,[StackFrame]
k,Term
v')
 where
  v' :: Term
v' = Value -> Term
valToTerm Value
v

valToTerm :: Value -> Term
valToTerm :: Value -> Term
valToTerm v :: Value
v = case Value
v of
  Lambda x :: Id
x e :: Term
e           -> Id -> Term -> Term
Lam Id
x Term
e
  TyLambda x :: TyVar
x e :: Term
e         -> TyVar -> Term -> Term
TyLam TyVar
x Term
e
  DC dc :: DataCon
dc pxs :: [Either Term Type]
pxs            -> (Term -> Either Term Type -> Term)
-> Term -> [Either Term Type] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\e :: Term
e a :: 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 l :: Literal
l                -> Literal -> Term
Literal Literal
l
  PrimVal nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vs :: [Value]
vs -> (Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App ((Term -> Type -> Term) -> Term -> [Type] -> Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Type -> Term
TyApp (Text -> PrimInfo -> Term
Prim Text
nm PrimInfo
ty) [Type]
tys)
                                 ((Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Term
valToTerm [Value]
vs)
  Suspend e :: Term
e            -> Term
e

toVar :: Id -> Term
toVar :: Id -> Term
toVar x :: Id
x = Id -> Term
Var Id
x

toType :: TyVar -> Type
toType :: TyVar -> Type
toType x :: TyVar
x = TyVar -> Type
VarTy TyVar
x

-- | Apply a value to a function
apply :: Heap -> Stack -> Value -> Id -> State
apply :: Heap -> [StackFrame] -> Value -> Id -> State
apply h :: Heap
h@(Heap _ _ _ _ is0 :: InScopeSet
is0) k :: [StackFrame]
k (Lambda x' :: Id
x' e :: Term
e) x :: Id
x = (Heap
h,[StackFrame]
k,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "Evaluator.apply" Subst
subst Term
e)
 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 -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
x)
apply _ _ _ _ = String -> State
forall a. HasCallStack => String -> a
error "not a lambda"

-- | Instantiate a type-abstraction
instantiate :: Heap -> Stack -> Value -> Type -> State
instantiate :: Heap -> [StackFrame] -> Value -> Type -> State
instantiate h :: Heap
h k :: [StackFrame]
k (TyLambda x :: TyVar
x e :: Term
e) ty :: Type
ty = (Heap
h,[StackFrame]
k,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "Evaluator.instantiate" Subst
subst Term
e)
 where
  subst :: Subst
subst  = Subst -> TyVar -> Type -> Subst
extendTvSubst Subst
subst0 TyVar
x Type
ty
  subst0 :: Subst
subst0 = InScopeSet -> Subst
mkSubst InScopeSet
is0
  is0 :: InScopeSet
is0    = VarSet -> InScopeSet
mkInScopeSet ([Term] -> VarSet
forall (f :: * -> *). Foldable f => f Term -> VarSet
localFVsOfTerms [Term
e] VarSet -> VarSet -> VarSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSet` [Type] -> VarSet
forall (f :: * -> *). Foldable f => f Type -> VarSet
tyFVsOfTypes [Type
ty])
instantiate _ _ _ _ = String -> State
forall a. HasCallStack => String -> a
error "not a ty lambda"

naturalLiteral :: Value -> Maybe Integer
naturalLiteral :: Value -> Maybe Integer
naturalLiteral v :: Value
v =
  case Value
v of
    Lit (NaturalLiteral i :: Integer
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    DC dc :: DataCon
dc [Left (Literal (WordLiteral i :: Integer
i))]
      | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    DC dc :: DataCon
dc [Left (Literal (ByteArrayLiteral (PV.Vector _ _ (BA.ByteArray ba :: ByteArray#
ba))))]
      | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (BigNat -> Integer
Jp# (ByteArray# -> BigNat
BN# ByteArray#
ba))
    _ -> Maybe Integer
forall a. Maybe a
Nothing

integerLiteral :: Value -> Maybe Integer
integerLiteral :: Value -> Maybe Integer
integerLiteral v :: Value
v =
  case Value
v of
    Lit (IntegerLiteral i :: Integer
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    DC dc :: DataCon
dc [Left (Literal (IntLiteral i :: Integer
i))]
      | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    DC dc :: DataCon
dc [Left (Literal (ByteArrayLiteral (PV.Vector _ _ (BA.ByteArray ba :: ByteArray#
ba))))]
      | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (BigNat -> Integer
Jp# (ByteArray# -> BigNat
BN# ByteArray#
ba))
      | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3
      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (BigNat -> Integer
Jn# (ByteArray# -> BigNat
BN# ByteArray#
ba))
    _ -> Maybe Integer
forall a. Maybe a
Nothing

-- | Evaluation of primitive operations
primop
  :: PrimEvaluator
  -> TyConMap
  -> Heap
  -> Stack
  -> Text
  -- ^ Name of the primitive
  -> PrimInfo
  -- ^ Type of the primitive
  -> [Type]
  -- ^ Applied types
  -> [Value]
  -- ^ Applied values
  -> Value
  -- ^ The current value
  -> [Term]
  -- ^ The remaining terms which must be evaluated to a value
  -> Maybe State
primop :: PrimEvaluator
-> TyConMap
-> Heap
-> [StackFrame]
-> Text
-> PrimInfo
-> [Type]
-> [Value]
-> Value
-> [Term]
-> Maybe State
primop eval :: PrimEvaluator
eval tcm :: TyConMap
tcm h :: Heap
h k :: [StackFrame]
k nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vs :: [Value]
vs v :: Value
v []
  | Text
nm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["Clash.Sized.Internal.Index.fromInteger#"
              ,"GHC.CString.unpackCString#"
              ,"Clash.Transformations.removedArg"
              ,"GHC.Prim.MutableByteArray#"
              ]
              -- The above primitives are actually values, and not operations.
  = PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
ty [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v]))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.BitVector.fromInteger#"
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just n :: Integer
n,mask :: Value
mask], Value -> Maybe Integer
integerLiteral -> Just i :: Integer
i) ->
      PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
ty [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n)
                                             ,Value
mask
                                             ,Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned Integer
n Integer
i))])
    _ -> String -> Maybe State
forall a. HasCallStack => String -> a
error ($(curLoc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Internal error"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> String
forall a. Show a => a -> String
show ([Value]
vs,Value
v))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.BitVector.fromInteger##"
  = case ([Value]
vs,Value
v) of
    ([mask :: Value
mask], Value -> Maybe Integer
integerLiteral -> Just i :: Integer
i) ->
      PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
ty [Type]
tys [Value
mask
                                             ,Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned 1 Integer
i))])
    _ -> String -> Maybe State
forall a. HasCallStack => String -> a
error ($(curLoc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Internal error"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> String
forall a. Show a => a -> String
show ([Value]
vs,Value
v))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Signed.fromInteger#"
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just n :: Integer
n],Value -> Maybe Integer
integerLiteral -> Just i :: Integer
i) ->
      PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
ty [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n)
                                             ,Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapSigned Integer
n Integer
i))])
    _ -> String -> Maybe State
forall a. HasCallStack => String -> a
error ($(curLoc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Internal error"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> String
forall a. Show a => a -> String
show ([Value]
vs,Value
v))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Unsigned.fromInteger#"
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just n :: Integer
n],Value -> Maybe Integer
integerLiteral -> Just i :: Integer
i) ->
      PrimEvaluator
-> TyConMap -> Heap -> [StackFrame] -> Value -> Maybe State
unwind PrimEvaluator
eval TyConMap
tcm Heap
h [StackFrame]
k (Text -> PrimInfo -> [Type] -> [Value] -> Value
PrimVal Text
nm PrimInfo
ty [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n)
                                             ,Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned Integer
n Integer
i))])
    _ -> String -> Maybe State
forall a. HasCallStack => String -> a
error ($(curLoc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Internal error"  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> String
forall a. Show a => a -> String
show ([Value]
vs,Value
v))
  | Bool
otherwise = PrimEvaluator
eval ([StackFrame] -> Bool
isScrut [StackFrame]
k) TyConMap
tcm Heap
h [StackFrame]
k Text
nm PrimInfo
ty [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v])
primop eval :: PrimEvaluator
eval tcm :: TyConMap
tcm h0 :: Heap
h0 k :: [StackFrame]
k nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vs :: [Value]
vs v :: Value
v [e :: Term
e]
  | Text
nm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ "Clash.Sized.Vector.lazyV"
              , "Clash.Sized.Vector.replicate"
              , "Clash.Sized.Vector.replace_int"
              ]
  = let (h1 :: Heap
h1,i :: Id
i) = TyConMap -> Heap -> Term -> (Heap, Id)
newLetBinding TyConMap
tcm Heap
h0 Term
e
    in  PrimEvaluator
eval ([StackFrame] -> Bool
isScrut [StackFrame]
k) TyConMap
tcm Heap
h1 [StackFrame]
k Text
nm PrimInfo
ty [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v,Term -> Value
Suspend (Id -> Term
Var Id
i)])
primop _ _ h :: Heap
h k :: [StackFrame]
k nm :: Text
nm ty :: PrimInfo
ty tys :: [Type]
tys vs :: [Value]
vs v :: Value
v (e :: Term
e:es :: [Term]
es) =
  State -> Maybe State
forall a. a -> Maybe a
Just (Heap
h,Text -> PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
PrimApply Text
nm PrimInfo
ty [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v]) [Term]
esStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
k,Term
e)

-- | Evaluate a case-expression
scrutinise :: Heap -> Stack -> Value -> [Alt] -> State
scrutinise :: Heap -> [StackFrame] -> Value -> [Alt] -> State
scrutinise h :: Heap
h k :: [StackFrame]
k v :: Value
v [] = (Heap
h,[StackFrame]
k,Value -> Term
valToTerm Value
v)
-- [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 h :: Heap
h k :: [StackFrame]
k (Lit l :: Literal
l) alts :: [Alt]
alts = case [Alt]
alts of
  (DefaultPat,altE :: Term
altE):alts1 :: [Alt]
alts1 -> (Heap
h,[StackFrame]
k,Term -> [Alt] -> Term
go Term
altE [Alt]
alts1)
  _ -> (Heap
h,[StackFrame]
k,Term -> [Alt] -> Term
go (String -> Term
forall a. HasCallStack => String -> a
error ("scrutinise: no match " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          Term -> String
forall p. PrettyPrec p => p -> String
showPpr (Term -> Type -> [Alt] -> Term
Case (Value -> Term
valToTerm (Literal -> Value
Lit Literal
l)) (ConstTy -> Type
ConstTy ConstTy
Arrow) [Alt]
alts))) [Alt]
alts)
 where
  go :: Term -> [Alt] -> Term
go def :: Term
def [] = Term
def
  go _ ((LitPat l1 :: Literal
l1,altE :: Term
altE):_) | Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l = Term
altE
  go _ ((DataPat dc :: DataCon
dc [] [x :: Id
x],altE :: Term
altE):_)
    | IntegerLiteral l1 :: Integer
l1 <- Literal
l
    , Just patE :: Literal
patE <- case DataCon -> Int
dcTag DataCon
dc of
       1 | Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= ((-2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)) Bool -> Bool -> Bool
&&  Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int) ->
          Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
IntLiteral Integer
l1)
       2 | Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= (2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)) ->
          let !(Jp# !(BN# ba0 :: ByteArray#
ba0)) = Integer
l1
              ba1 :: ByteArray
ba1 = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba0
              bv :: Vector a
bv = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba1) ByteArray
ba1
          in  Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)
       3 | Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< ((-2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)) ->
          let !(Jn# !(BN# ba0 :: ByteArray#
ba0)) = Integer
l1
              ba1 :: ByteArray
ba1 = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba0
              bv :: Vector a
bv = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba1) ByteArray
ba1
          in  Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)
       _ -> Maybe Literal
forall a. Maybe a
Nothing
    = let inScope :: VarSet
inScope = [Term] -> VarSet
forall (f :: * -> *). Foldable f => f Term -> VarSet
localFVsOfTerms [Term
altE]
          subst0 :: Subst
subst0  = InScopeSet -> Subst
mkSubst (VarSet -> InScopeSet
mkInScopeSet VarSet
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 "Evaluator.scrutinise" Subst
subst1 Term
altE
    | NaturalLiteral l1 :: Integer
l1  <- Literal
l
    , Just patE :: Literal
patE <- case DataCon -> Int
dcTag DataCon
dc of
       1 | Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&&  Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(64::Int) ->
          Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
WordLiteral Integer
l1)
       2 | Integer
l1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= (2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(64::Int)) ->
          let !(Jp# !(BN# ba0 :: ByteArray#
ba0)) = Integer
l1
              ba1 :: ByteArray
ba1 = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba0
              bv :: Vector a
bv = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba1) ByteArray
ba1
          in  Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)
       _ -> Maybe Literal
forall a. Maybe a
Nothing
    = let inScope :: VarSet
inScope = [Term] -> VarSet
forall (f :: * -> *). Foldable f => f Term -> VarSet
localFVsOfTerms [Term
altE]
          subst0 :: Subst
subst0  = InScopeSet -> Subst
mkSubst (VarSet -> InScopeSet
mkInScopeSet VarSet
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 "Evaluator.scrutinise" Subst
subst1 Term
altE
  go def :: Term
def (_:alts1 :: [Alt]
alts1) = Term -> [Alt] -> Term
go Term
def [Alt]
alts1

scrutinise h :: Heap
h k :: [StackFrame]
k (DC dc :: DataCon
dc xs :: [Either Term Type]
xs) alts :: [Alt]
alts
  | altE :: Term
altE:_ <- [DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
substAlt DataCon
altDc [TyVar]
tvs [Id]
pxs [Either Term Type]
xs Term
altE
              | (DataPat altDc :: DataCon
altDc tvs :: [TyVar]
tvs pxs :: [Id]
pxs,altE :: 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 | (DefaultPat,altE :: Term
altE) <- [Alt]
alts ]
  = (Heap
h,[StackFrame]
k,Term
altE)

scrutinise h :: Heap
h k :: [StackFrame]
k v :: Value
v@(PrimVal nm :: Text
nm _ _ vs :: [Value]
vs) alts :: [Alt]
alts
  | (Alt -> Bool) -> [Alt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case {(LitPat {},_) -> Bool
True; _ -> Bool
False}) [Alt]
alts
  = case [Alt]
alts of
      ((DefaultPat,altE :: Term
altE):alts1 :: [Alt]
alts1) -> (Heap
h,[StackFrame]
k,Term -> [Alt] -> Term
forall t. t -> [(Pat, t)] -> t
go Term
altE [Alt]
alts1)
      _ -> (Heap
h,[StackFrame]
k,Term -> [Alt] -> Term
forall t. t -> [(Pat, t)] -> t
go (String -> Term
forall a. HasCallStack => String -> a
error ("scrutinise: no match " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                Term -> String
forall p. PrettyPrec p => p -> String
showPpr (Term -> Type -> [Alt] -> Term
Case (Value -> Term
valToTerm Value
v) (ConstTy -> Type
ConstTy ConstTy
Arrow) [Alt]
alts))) [Alt]
alts)
 where
  go :: t -> [(Pat, t)] -> t
go def :: t
def [] = t
def
  go _   ((LitPat l1 :: Literal
l1,altE :: t
altE):_) | Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l = t
altE
  go def :: t
def (_:alts1 :: [(Pat, t)]
alts1) = t -> [(Pat, t)] -> t
go t
def [(Pat, t)]
alts1

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

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

substAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
substAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
substAlt dc :: DataCon
dc tvs :: [TyVar]
tvs xs :: [Id]
xs args :: [Either Term Type]
args e :: Term
e = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "Evaluator.substAlt" 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 (t :: * -> *) 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 :: VarSet
inScope    = [Type] -> VarSet
forall (f :: * -> *). Foldable f => f Type -> VarSet
tyFVsOfTypes [Type]
tys VarSet -> VarSet -> VarSet
`unionVarSet` [Term] -> VarSet
forall (f :: * -> *). Foldable f => f Term -> VarSet
localFVsOfTerms (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 (VarSet -> InScopeSet
mkInScopeSet VarSet
inScope)

-- | Allocate let-bindings on the heap
allocate :: Heap -> Stack -> [LetBinding] -> Term -> State
allocate :: Heap -> [StackFrame] -> [LetBinding] -> Term -> State
allocate (Heap gh :: GlobalHeap
gh gbl :: GPureHeap
gbl h :: PureHeap
h ids :: Supply
ids is0 :: InScopeSet
is0) k :: [StackFrame]
k xes :: [LetBinding]
xes e :: Term
e =
  (GlobalHeap -> GPureHeap -> PureHeap -> Supply -> InScopeSet -> Heap
Heap GlobalHeap
gh GPureHeap
gbl (PureHeap
h PureHeap -> [LetBinding] -> PureHeap
forall a b. VarEnv a -> [(Var b, a)] -> VarEnv a
`extendVarEnvList` [LetBinding]
xes') Supply
ids' InScopeSet
isN,[StackFrame]
k,Term
e')
 where
  xNms :: [Id]
xNms     = (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
xes
  is1 :: InScopeSet
is1      = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Id]
xNms
  (ids' :: Supply
ids',s :: [(Id, LetBinding)]
s) = (Supply -> Id -> (Supply, (Id, LetBinding)))
-> Supply -> [Id] -> (Supply, [(Id, LetBinding)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (PureHeap -> Supply -> Id -> (Supply, (Id, LetBinding))
letSubst PureHeap
h) Supply
ids [Id]
xNms
  (nms :: [Id]
nms,s' :: [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 (t :: * -> *) 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]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "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 "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 h :: PureHeap
h acc :: Supply
acc id0 :: Id
id0 =
  let (acc' :: Supply
acc',id1 :: Id
id1) = PureHeap -> Supply -> Id -> (Supply, Id)
uniqueInHeap PureHeap
h Supply
acc Id
id0
  in  (Supply
acc',(Id
id1,(Id
id0,Id -> Term
Var Id
id1)))

-- | Create a name that's unique in the heap
uniqueInHeap
  :: PureHeap
  -> Supply
  -> Id
  -> (Supply, Id)
uniqueInHeap :: PureHeap -> Supply -> Id -> (Supply, Id)
uniqueInHeap h :: PureHeap
h ids :: Supply
ids x :: Id
x = case Id -> PureHeap -> Maybe Term
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
x' PureHeap
h of
  Just _ -> PureHeap -> Supply -> Id -> (Supply, Id)
uniqueInHeap PureHeap
h Supply
ids' Id
x
  _ -> (Supply
ids',Id
x')
 where
  (i :: Int
i,ids' :: 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 (\nm :: Name Term
nm -> Name Term
nm {nameUniq :: Int
nameUniq = Int
i}) Id
x

wrapUnsigned :: Integer -> Integer -> Integer
wrapUnsigned :: Integer -> Integer -> Integer
wrapUnsigned n :: Integer
n i :: Integer
i = Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
sz
 where
  sz :: Integer
sz = 1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n

wrapSigned :: Integer -> Integer -> Integer
wrapSigned :: Integer -> Integer -> Integer
wrapSigned n :: Integer
n i :: Integer
i = if Integer
mask Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then 0 else Integer
res
 where
  mask :: Integer
mask = 1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)
  res :: Integer
res  = case Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
divMod Integer
i Integer
mask of
           (s :: Integer
s,i1 :: Integer
i1) | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
s    -> Integer
i1
                  | Bool
otherwise -> Integer
i1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
mask