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

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' eval :: PrimStep
eval fu :: PrimUnwind
fu bm :: BindingMap
bm tcm :: TyConMap
tcm ph :: PrimHeap
ph ids :: Supply
ids is :: InScopeSet
is isSubj :: Bool
isSubj e :: 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 x :: 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 tcm :: TyConMap
tcm isSubj :: Bool
isSubj m :: 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 s :: Machine
s = case Step
step Machine
s TyConMap
tcm of
      Just s' :: Machine
s' -> Machine -> Machine
go Machine
s'
      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 m :: Machine
m
  | Machine -> Bool
stackNull Machine
m = Machine -> Maybe Machine
forall a. a -> Maybe a
Just Machine
m
  | Bool
otherwise = do
      (m' :: Machine
m', kf :: StackFrame
kf) <- Machine -> Maybe (Machine, StackFrame)
stackPop Machine
m

      case StackFrame
kf of
        PrimApply p :: PrimInfo
p tys :: [Type]
tys vs :: [Value]
vs tms :: [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 ty :: 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 n :: Id
n ->
          case IdScope -> Id -> Machine -> Maybe Term
heapLookup IdScope
LocalId Id
n Machine
m' of
            Just e :: 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')

            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
$
              [ "Clash.Core.Evaluator.unwindStack:"
              , "Stack:"
              ] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<>
              [ "  " [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
<>
              [ ""
              , "Expression:"
              , Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr (Machine -> Term
mTerm Machine
m)
              , ""
              , "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 _ [] ->
          Machine -> Maybe Machine
unwindStack Machine
m'

        Scrutinise ty :: Type
ty alts :: [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 LocalId x :: Id
x ->
          Machine -> Maybe Machine
unwindStack (IdScope -> Id -> Term -> Machine -> Machine
heapInsert IdScope
LocalId Id
x (Machine -> Term
mTerm Machine
m') Machine
m')

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

        Tickish sp :: 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 i :: Id
i m :: Machine
m _
  | Just e :: Term
e <- IdScope -> Id -> Machine -> Maybe Term
heapLookup IdScope
LocalId Id
i Machine
m
  = IdScope -> Term -> Maybe Machine
go IdScope
LocalId Term
e

  | Just e :: 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 s :: IdScope
s e :: 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 "."
  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 '_' (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 dc :: DataCon
dc m :: Machine
m tcm :: 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 l :: Literal
l m :: Machine
m tcm :: TyConMap
tcm = TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (Literal -> Value
Lit Literal
l)

stepPrim :: PrimInfo -> Step
stepPrim :: PrimInfo -> Step
stepPrim pInfo :: PrimInfo
pInfo m :: Machine
m tcm :: TyConMap
tcm
  | PrimInfo -> Text
primName PrimInfo
pInfo Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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
        tys :: [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 x :: Id
x e :: Term
e m :: Machine
m tcm :: 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 x :: TyVar
x e :: Term
e m :: Machine
m tcm :: 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 x :: Term
x y :: Term
y m :: Machine
m tcm :: TyConMap
tcm =
  case Term
term of
    Data dc :: 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
            EQ -> TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
            LT -> [Either TyVar Type] -> Term -> Step
newBinder [Either TyVar Type]
tys' (Term -> Term -> Term
App Term
x Term
y) Machine
m TyConMap
tcm
            GT -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error "Overapplied DC"

    Prim p :: 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
            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.
              [a0 :: Term
a0, a1 :: Term
a1] | PrimInfo -> Text
primName PrimInfo
p Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ["GHC.Classes.&&","GHC.Classes.||"] ->
                    let (m0 :: Machine
m0,i :: Id
i) = TyConMap -> Machine -> Term -> (Machine, Id)
newLetBinding TyConMap
tcm Machine
m  Term
a0
                        (m1 :: Machine
m1,j :: 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

              (e' :: Term
e':es :: [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

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

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

            GT -> let (m0 :: Machine
m0, n :: 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

    _ -> let (m0 :: Machine
m0, n :: 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
term, args :: [Either Term Type]
args, _) = 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 x :: Term
x ty :: Type
ty m :: Machine
m tcm :: TyConMap
tcm =
  case Term
term of
    Data dc :: 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
            EQ -> TyConMap -> Machine -> Value -> Maybe Machine
unwind TyConMap
tcm Machine
m (DataCon -> [Either Term Type] -> Value
DC DataCon
dc [Either Term Type]
args)
            LT -> [Either TyVar Type] -> Term -> Step
newBinder [Either TyVar Type]
tys' (Term -> Type -> Term
TyApp Term
x Type
ty) Machine
m TyConMap
tcm
            GT -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error "Overapplied DC"

    Prim p :: 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
            EQ -> case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                    [] | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Transformations.removedArg" ->
                            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

                    (e' :: Term
e':es :: [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

            LT -> [Either TyVar Type] -> Term -> Step
newBinder [Either TyVar Type]
tys' (Term -> Type -> Term
TyApp Term
x Type
ty) Machine
m TyConMap
tcm
            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

    _ -> 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
term, args :: [Either Term Type]
args, _) = 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 bs :: [LetBinding]
bs x :: Term
x m :: Machine
m _ = 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 scrut :: Term
scrut ty :: Type
ty alts :: [Alt]
alts m :: Machine
m _ =
  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 _ _ _ _ _ =
  ([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
    [ "WARNING: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> $(curLoc) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> "Clash can't symbolically evaluate casts"
    , "Please file an issue at https://github.com/clash-lang/clash-compiler/issues"
    ]

stepTick :: TickInfo -> Term -> Step
stepTick :: TickInfo -> Term -> Step
stepTick tick :: TickInfo
tick x :: Term
x m :: Machine
m _ =
  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 m :: Machine
m = case Machine -> Term
mTerm Machine
m of
  Var i :: Id
i -> Id -> Step
stepVar Id
i Machine
m
  Data dc :: DataCon
dc -> DataCon -> Step
stepData DataCon
dc Machine
m
  Literal l :: Literal
l -> Literal -> Step
stepLiteral Literal
l Machine
m
  Prim p :: PrimInfo
p -> PrimInfo -> Step
stepPrim PrimInfo
p Machine
m
  Lam v :: Id
v x :: Term
x -> Id -> Term -> Step
stepLam Id
v Term
x Machine
m
  TyLam v :: TyVar
v x :: Term
x -> TyVar -> Term -> Step
stepTyLam TyVar
v Term
x Machine
m
  App x :: Term
x y :: Term
y -> Term -> Term -> Step
stepApp Term
x Term
y Machine
m
  TyApp x :: Term
x ty :: Type
ty -> Term -> Type -> Step
stepTyApp Term
x Type
ty Machine
m
  Letrec bs :: [LetBinding]
bs x :: Term
x -> [LetBinding] -> Term -> Step
stepLetRec [LetBinding]
bs Term
x Machine
m
  Case s :: Term
s ty :: Type
ty as :: [Alt]
as -> Term -> Type -> [Alt] -> Step
stepCase Term
s Type
ty [Alt]
as Machine
m
  Cast x :: Term
x a :: Type
a b :: Type
b -> Term -> Type -> Type -> Step
stepCast Term
x Type
a Type
b Machine
m
  Tick t :: TickInfo
t x :: 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 tys :: [Either TyVar Type]
tys x :: Term
x m :: Machine
m tcm :: TyConMap
tcm =
  let (s' :: Supply
s', iss' :: InScopeSet
iss', x' :: 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 tv :: TyVar
tv) (s' :: Supply
s', iss' :: InScopeSet
iss', e' :: 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 ty :: Type
ty) (s' :: Supply
s', iss' :: InScopeSet
iss', e' :: Term
e') =
        let ((s'' :: Supply
s'', _), n :: Id
n) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
mkUniqSystemId (Supply
s', InScopeSet
iss') ("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 tcm :: TyConMap
tcm m :: Machine
m e :: Term
e
  | Var v :: 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
  ((ids' :: Supply
ids', is1 :: InScopeSet
is1), id_ :: Id
id_) = (Supply, InScopeSet) -> (Text, Type) -> ((Supply, InScopeSet), Id)
mkUniqSystemId (Machine -> Supply
mSupply Machine
m, Machine -> InScopeSet
mScopeNames Machine
m) ("x", Type
ty)

-- | Unwind the stack by 1
unwind
  :: TyConMap
  -> Machine
  -> Value
  -> Maybe Machine
unwind :: TyConMap -> Machine -> Value -> Maybe Machine
unwind tcm :: TyConMap
tcm m :: Machine
m v :: Value
v = do
  (m' :: Machine
m', kf :: 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 s :: IdScope
s x :: 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 x :: 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
. Value -> Id -> Machine -> Machine
apply Value
v Id
x
  go (Instantiate ty :: 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
. Value -> Type -> Machine -> Machine
instantiate Value
v Type
ty
  go (PrimApply p :: PrimInfo
p tys :: [Type]
tys vs :: [Value]
vs tms :: [Term]
tms) = Machine -> PrimUnwind
mPrimUnwind Machine
m TyConMap
tcm PrimInfo
p [Type]
tys [Value]
vs Value
v [Term]
tms
  go (Scrutinise _ as :: [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 -> [Alt] -> Machine -> Machine
scrutinise Value
v [Alt]
as
  go (Tickish _)              = 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 s :: IdScope
s x :: 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 :: Value -> Id -> Machine -> Machine
apply :: Value -> Id -> Machine -> Machine
apply (Lambda x' :: Id
x' e :: Term
e) x :: Id
x m :: Machine
m =
  Term -> Machine -> Machine
setTerm (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "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 _ _ _ = [Char] -> Machine
forall a. HasCallStack => [Char] -> a
error "Evaluator.apply: Not a lambda"

-- | Instantiate a type-abstraction
instantiate :: Value -> Type -> Machine -> Machine
instantiate :: Value -> Type -> Machine -> Machine
instantiate (TyLambda x :: TyVar
x e :: Term
e) ty :: Type
ty =
  Term -> Machine -> Machine
setTerm (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
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 _ _ = [Char] -> Machine -> Machine
forall a. HasCallStack => [Char] -> a
error "Evaluator.instantiate: Not a tylambda"

-- | Evaluate a case-expression
scrutinise :: Value -> [Alt] -> Machine -> Machine
scrutinise :: Value -> [Alt] -> Machine -> Machine
scrutinise v :: Value
v [] m :: 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 l :: Literal
l) alts :: [Alt]
alts m :: Machine
m = case [Alt]
alts of
  (DefaultPat, altE :: Term
altE):alts1 :: [Alt]
alts1 -> Term -> Machine -> Machine
setTerm (Term -> [Alt] -> Term
go Term
altE [Alt]
alts1) Machine
m
  _ -> 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
$ "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 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 :: 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 "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 :: 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 "Evaluator.scrutinise" Subst
subst1 Term
altE
  go def :: Term
def (_:alts1 :: [Alt]
alts1) = Term -> [Alt] -> Term
go Term
def [Alt]
alts1

scrutinise (DC dc :: DataCon
dc xs :: [Either Term Type]
xs) alts :: [Alt]
alts m :: Machine
m
  | altE :: Term
altE:_ <- [DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
substInAlt 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 ]
  = Term -> Machine -> Machine
setTerm Term
altE Machine
m

scrutinise v :: Value
v@(PrimVal p :: PrimInfo
p _ vs :: [Value]
vs) alts :: [Alt]
alts m :: Machine
m
  | (Alt -> Bool) -> [Alt] -> Bool
forall (t :: Type -> Type) 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) -> Term -> Machine -> Machine
setTerm (Term -> [Alt] -> Term
forall t. t -> [(Pat, t)] -> t
go Term
altE [Alt]
alts1) Machine
m
      _ -> 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
$ "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 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 PrimInfo -> Text
primName PrimInfo
p 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
        _ -> [Char] -> Literal
forall a. HasCallStack => [Char] -> a
error ("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 v :: Value
v alts :: [Alt]
alts _ = [Char] -> Machine
forall a. HasCallStack => [Char] -> a
error ("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 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.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 xes :: [LetBinding]
xes e :: Term
e m :: 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
  (ids' :: Supply
ids', s :: [(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
  (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 :: 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 "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)
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 h' :: PureHeap
h' ids :: Supply
ids x :: 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
    (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 (Name Term -> Int -> Name Term
forall a. Uniquable a => a -> Int -> a
`setUnique` Int
i) Id
x