{-|
  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 LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Core.Evaluator where

import           Prelude                                 hiding (lookup)

import           Control.Concurrent.Supply               (Supply, freshId)
import           Data.Either                             (lefts,rights)
import           Data.List                               (foldl',mapAccumL)
import           Data.Maybe                              (fromMaybe)
import qualified Data.Primitive.ByteArray                as BA
import qualified Data.Text as Text
import qualified Data.Vector.Primitive                   as PV
import           GHC.Integer.GMP.Internals
  (Integer (..), BigNat (..))

import           Clash.Core.DataCon
import           Clash.Core.Evaluator.Types
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.TermInfo
import           Clash.Core.TyCon
import           Clash.Core.Type
import           Clash.Core.Util
import           Clash.Core.Var
import           Clash.Core.VarEnv
import           Clash.Debug
import           Clash.Driver.Types                      (BindingMap, Binding(..))
import           Clash.Pretty
import           Clash.Unique
import           Clash.Util                              (curLoc)

isUndefinedPrimVal :: Value -> Bool
isUndefinedPrimVal :: Value -> Bool
isUndefinedPrimVal (PrimVal (PrimInfo{Text
primName :: PrimInfo -> Text
primName :: Text
primName}) [Type]
_ [Value]
_) =
  Text
primName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Transformations.undefined"
isUndefinedPrimVal Value
_ = Bool
False

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

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

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

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

      case StackFrame
kf of
        PrimApply PrimInfo
p [Type]
tys [Value]
vs [Term]
tms ->
          let term :: Term
term = (Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App
                       ((Term -> Term -> Term) -> Term -> [Term] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
App
                         ((Term -> Type -> Term) -> Term -> [Type] -> Term
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
p) [Type]
tys)
                         ((Value -> Term) -> [Value] -> [Term]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Term
valToTerm [Value]
vs))
                       (Machine -> Term
mTerm Machine
m' Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
tms)
           in Machine -> Maybe Machine
unwindStack (Term -> Machine -> Machine
setTerm Term
term Machine
m')

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

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

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

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

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

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

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

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

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

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
. 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 Machine
m TyConMap
tcm = TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [])

stepLiteral :: Literal -> Step
stepLiteral :: Literal -> Step
stepLiteral Literal
l Machine
m TyConMap
tcm = TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (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#" =
      TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
pInfo [] [])

  | 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
        []  -> Machine -> PrimStep
mPrimStep Machine
m 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 Machine
m TyConMap
tcm = TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (Id -> Term -> Value
Lambda Id
x Term
e)

stepTyLam :: TyVar -> Term -> Step
stepTyLam :: TyVar -> Term -> Step
stepTyLam TyVar
x Term
e Machine
m TyConMap
tcm = TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
            Ordering
EQ -> TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
            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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> 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 (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  Machine -> PrimStep
mPrimStep Machine
m 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) ->
                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
termType 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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either TyVar Type]
tys) of
            Ordering
EQ -> TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
            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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
args) ([Either TyVar Type] -> 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 (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ Text
"Clash.Transformations.removedArg"
                                           , Text
"Clash.Transformations.undefined" ] ->
                            TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args) [])

                       | Bool
otherwise ->
                            Machine -> PrimStep
mPrimStep Machine
m 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
termType 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

stepLetRec :: [LetBinding] -> Term -> Step
stepLetRec :: [LetBinding] -> Term -> Step
stepLetRec [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
<> $([Char]
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.
--
step :: Step
step :: Step
step 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
  Letrec [LetBinding]
bs Term
x -> [LetBinding] -> Term -> Step
stepLetRec [LetBinding]
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
step 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 (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
termType 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
unwind
  :: TyConMap
  -> Machine
  -> Value
  -> Maybe Machine
unwind :: TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m Value
v = 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 (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 (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 (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) = Machine -> PrimUnwind
mPrimUnwind Machine
m TyConMap
tcm PrimInfo
p [Type]
tys [Value]
vs Value
v [Term]
tms
  go (Scrutinise Type
altTy [Alt]
as)    = Machine -> Maybe Machine
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 (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 :: Type
primType :: PrimInfo -> Type
primType}) [Type]
tys []) Id
x Machine
m
  | Value -> Bool
isUndefinedPrimVal Value
pVal
  = Term -> Machine -> Machine
setTerm (Type -> Term
undefinedTm (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tcm Type
primType ([Type]
tys[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++[Id -> Type
forall a. Var a -> Type
varType Id
x]))) Machine
m

apply TyConMap
_ Value
_ Id
_ Machine
_ = [Char] -> Machine
forall a. HasCallStack => [Char] -> a
error [Char]
"Evaluator.apply: Not a lambda"

-- | 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.instantiate" 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   = VarSet -> InScopeSet
mkInScopeSet ([Term] -> VarSet
forall (f :: Type -> Type). Foldable f => f Term -> VarSet
localFVsOfTerms [Term
e] VarSet -> VarSet -> VarSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSet` [Type] -> VarSet
forall (f :: Type -> Type). Foldable f => f Type -> VarSet
tyFVsOfTypes [Type
ty])
instantiate TyConMap
tcm pVal :: Value
pVal@(PrimVal (PrimInfo{Type
primType :: Type
primType :: PrimInfo -> Type
primType}) [Type]
tys []) Type
ty Machine
m
  | Value -> Bool
isUndefinedPrimVal Value
pVal
  = Term -> Machine -> Machine
setTerm (Type -> Term
undefinedTm (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
ty]))) Machine
m

instantiate TyConMap
_ Value
_ Type
_ Machine
_ = [Char] -> Machine
forall a. HasCallStack => [Char] -> a
error [Char]
"Evaluator.instantiate: Not a tylambda"

-- | 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)) ->
          let !(Jp# !(BN# 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 Int
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)
       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)) ->
          let !(Jn# !(BN# 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 Int
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)
       Int
_ -> Maybe Literal
forall a. Maybe a
Nothing
    = let inScope :: VarSet
inScope = [Term] -> VarSet
forall (f :: Type -> Type). 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 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)) ->
          let !(Jp# !(BN# 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 Int
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)
       Int
_ -> Maybe Literal
forall a. Maybe a
Nothing
    = let inScope :: VarSet
inScope = [Term] -> VarSet
forall (f :: Type -> Type). 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 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
isUndefinedPrimVal Value
v
  = Term -> Machine -> Machine
setTerm (Type -> Term
undefinedTm 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#"
          | [Value
_,Lit (IntegerLiteral 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
_ [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 (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 :: VarSet
inScope    = [Type] -> VarSet
forall (f :: Type -> Type). Foldable f => f Type -> VarSet
tyFVsOfTypes [Type]
tys VarSet -> VarSet -> VarSet
`unionVarSet` [Term] -> VarSet
forall (f :: Type -> Type). 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 :: [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 (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) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 (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 (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