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

This module provides the "evaluation" part of the partial evaluator. This
is implemented in the classic "eval/apply" style, with a variant of apply for
performing type applications.
-}

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

module Clash.GHC.PartialEval.Eval
  ( eval
  , apply
  , applyTy
  ) where

import           Control.Monad (foldM)
import           Data.Bifunctor
import           Data.Bitraversable
import           Data.Either
import           Data.Graph (SCC(..))
import           Data.Primitive.ByteArray (ByteArray(..))
#if MIN_VERSION_base(4,15,0)
import           GHC.Num.Integer (Integer (..))
#else
import           GHC.Integer.GMP.Internals (BigNat(..), Integer(..))
#endif

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Types.Basic (InlineSpec(..))
#else
import           BasicTypes (InlineSpec(..))
#endif

import           Clash.Core.DataCon (DataCon(..))
import           Clash.Core.Literal (Literal(..))
import           Clash.Core.PartialEval.AsTerm
import           Clash.Core.PartialEval.Monad
import           Clash.Core.PartialEval.NormalForm
import           Clash.Core.Subst (substTy)
import           Clash.Core.Term
import           Clash.Core.TermInfo
import           Clash.Core.TyCon (tyConDataCons)
import           Clash.Core.Type
import           Clash.Core.TysPrim (integerPrimTy)
import qualified Clash.Core.Util as Util
import           Clash.Core.Var
import           Clash.Driver.Types (Binding(..), IsPrim(..))
import           Clash.Unique (lookupUniqMap')

-- | Evaluate a term to WHNF.
--
eval :: Term -> Eval Value
eval :: Term -> Eval Value
eval = \case
  Var Id
i           -> Id -> Eval Value
evalVar Id
i
  Literal Literal
lit     -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Literal -> Value
VLiteral Literal
lit)
  Data DataCon
dc         -> DataCon -> Eval Value
evalData DataCon
dc
  Prim PrimInfo
pr         -> PrimInfo -> Eval Value
evalPrim PrimInfo
pr
  Lam Id
i Term
x         -> Id -> Term -> Eval Value
evalLam Id
i Term
x
  TyLam TyVar
i Term
x       -> TyVar -> Term -> Eval Value
evalTyLam TyVar
i Term
x
  App Term
x Term
y         -> Term -> Arg Term -> Eval Value
evalApp Term
x (Term -> Arg Term
forall a b. a -> Either a b
Left Term
y)
  TyApp Term
x Type
ty      -> Term -> Arg Term -> Eval Value
evalApp Term
x (Type -> Arg Term
forall a b. b -> Either a b
Right Type
ty)
  Letrec [LetBinding]
bs Term
x     -> [LetBinding] -> Term -> Eval Value
evalLetrec [LetBinding]
bs Term
x
  Case Term
x Type
ty [Alt]
alts  -> Term -> Type -> [Alt] -> Eval Value
evalCase Term
x Type
ty [Alt]
alts
  Cast Term
x Type
a Type
b      -> Term -> Type -> Type -> Eval Value
evalCast Term
x Type
a Type
b
  Tick TickInfo
tick Term
x     -> TickInfo -> Term -> Eval Value
evalTick TickInfo
tick Term
x

delayEval :: Term -> Eval Value
delayEval :: Term -> Eval Value
delayEval = \case
  Literal Literal
lit -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Literal -> Value
VLiteral Literal
lit)
  Lam Id
i Term
x -> Id -> Term -> Eval Value
evalLam Id
i Term
x
  TyLam TyVar
i Term
x -> TyVar -> Term -> Eval Value
evalTyLam TyVar
i Term
x
  Tick TickInfo
t Term
x -> (Value -> TickInfo -> Value) -> TickInfo -> Value -> Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> TickInfo -> Value
VTick TickInfo
t (Value -> Value) -> Eval Value -> Eval Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Eval Value
delayEval Term
x
  Term
term -> Term -> LocalEnv -> Value
VThunk Term
term (LocalEnv -> Value) -> Eval LocalEnv -> Eval Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval LocalEnv
getLocalEnv

forceEval :: Value -> Eval Value
forceEval :: Value -> Eval Value
forceEval = [(TyVar, Type)] -> [(Id, Value)] -> Value -> Eval Value
forceEvalWith [] []

forceEvalWith :: [(TyVar, Type)] -> [(Id, Value)] -> Value -> Eval Value
forceEvalWith :: [(TyVar, Type)] -> [(Id, Value)] -> Value -> Eval Value
forceEvalWith [(TyVar, Type)]
tvs [(Id, Value)]
ids = \case
  VThunk Term
term LocalEnv
env -> do
    [(TyVar, Type)]
tvs' <- ((TyVar, Type) -> Eval (TyVar, Type))
-> [(TyVar, Type)] -> Eval [(TyVar, Type)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Type -> Eval Type) -> (TyVar, Type) -> Eval (TyVar, Type)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Eval Type
evalType) [(TyVar, Type)]
tvs
    LocalEnv -> Eval Value -> Eval Value
forall a. LocalEnv -> Eval a -> Eval a
setLocalEnv LocalEnv
env ([(TyVar, Type)] -> Eval Value -> Eval Value
forall a. [(TyVar, Type)] -> Eval a -> Eval a
withTyVars [(TyVar, Type)]
tvs' (Eval Value -> Eval Value)
-> (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Id, Value)] -> Eval Value -> Eval Value
forall a. [(Id, Value)] -> Eval a -> Eval a
withIds [(Id, Value)]
ids (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Term -> Eval Value
eval Term
term)

  Value
value -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Value
value

delayArg :: Arg Term -> Eval (Arg Value)
delayArg :: Arg Term -> Eval (Arg Value)
delayArg = (Term -> Eval Value)
-> (Type -> Eval Type) -> Arg Term -> Eval (Arg Value)
forall (t :: Type -> Type -> Type) (f :: Type -> Type) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Term -> Eval Value
delayEval Type -> Eval Type
evalType

delayArgs :: Args Term -> Eval (Args Value)
delayArgs :: Args Term -> Eval (Args Value)
delayArgs = (Arg Term -> Eval (Arg Value)) -> Args Term -> Eval (Args Value)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Arg Term -> Eval (Arg Value)
delayArg

evalType :: Type -> Eval Type
evalType :: Type -> Eval Type
evalType Type
ty = do
  TyConMap
tcm <- Eval TyConMap
getTyConMap
  Subst
subst <- Eval Subst
getTvSubst

  Type -> Eval Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TyConMap -> Type -> Type
normalizeType TyConMap
tcm (HasCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty))

evalVar :: Id -> Eval Value
evalVar :: Id -> Eval Value
evalVar Id
i
  | Id -> Bool
forall a. Var a -> Bool
isLocalId Id
i = Id -> Eval Value
lookupLocal Id
i
  | Bool
otherwise   = Id -> Eval Value
lookupGlobal Id
i

lookupLocal :: Id -> Eval Value
lookupLocal :: Id -> Eval Value
lookupLocal Id
i = do
  Maybe Value
var <- Id -> Eval (Maybe Value)
findId Id
i
  Type
varTy <- Type -> Eval Type
evalType (Id -> Type
forall a. Var a -> Type
varType Id
i)
  let i' :: Id
i' = Id
i { varType :: Type
varType = Type
varTy }

  case Maybe Value
var of
    Just Value
x  -> do
      Bool
workFree <- Value -> Eval Bool
workFreeValue Value
x
      if Bool
workFree then Value -> Eval Value
forceEval Value
x else Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
i'))

    Maybe Value
Nothing -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
i'))

lookupGlobal :: Id -> Eval Value
lookupGlobal :: Id -> Eval Value
lookupGlobal Id
i = do
  -- inScope <- getInScope
  Word
fuel <- Eval Word
getFuel
  Maybe (Binding Value)
var <- Id -> Eval (Maybe (Binding Value))
findBinding Id
i

  case Maybe (Binding Value)
var of
    Just Binding Value
x
      -- The binding cannot be inlined. Note that this is limited to bindings
      -- which are not primitives in Clash, as these must be marked NOINLINE.
      |  Binding Value -> InlineSpec
forall a. Binding a -> InlineSpec
bindingSpec Binding Value
x InlineSpec -> InlineSpec -> Bool
forall a. Eq a => a -> a -> Bool
== InlineSpec
NoInline
      ,  Binding Value -> IsPrim
forall a. Binding a -> IsPrim
bindingIsPrim Binding Value
x IsPrim -> IsPrim -> Bool
forall a. Eq a => a -> a -> Bool
== IsPrim
IsFun
      -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
i))

      -- There is no fuel, meaning no more inlining can occur.
      |  Word
fuel Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0
      -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
i))

      -- Inlining can occur, using one unit of fuel in the process.
      |  Bool
otherwise
      -> Id -> Eval Value -> Eval Value
forall a. Id -> Eval a -> Eval a
withContext Id
i (Eval Value -> Eval Value)
-> (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval Value -> Eval Value
forall a. Eval a -> Eval a
withFuel (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ do
           Value
val <- Value -> Eval Value
forceEval (Binding Value -> Value
forall a. Binding a -> a
bindingTerm Binding Value
x)
           Binding Value -> Eval ()
replaceBinding (Binding Value
x { bindingTerm :: Value
bindingTerm = Value
val })
           Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Value
val

    Maybe (Binding Value)
Nothing
      -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
i))

evalData :: DataCon -> Eval Value
evalData :: DataCon -> Eval Value
evalData DataCon
dc
  | Type -> Args Any -> Bool
forall a. Type -> Args a -> Bool
fullyApplied (DataCon -> Type
dcType DataCon
dc) [] =
      DataCon -> Args Value -> LocalEnv -> Value
VData DataCon
dc [] (LocalEnv -> Value) -> Eval LocalEnv -> Eval Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval LocalEnv
getLocalEnv

  | Bool
otherwise =
      Term -> Eval Term
etaExpand (DataCon -> Term
Data DataCon
dc) Eval Term -> (Term -> Eval Value) -> Eval Value
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> Eval Value
eval

evalPrim :: PrimInfo -> Eval Value
evalPrim :: PrimInfo -> Eval Value
evalPrim PrimInfo
pr
  | Type -> Args Any -> Bool
forall a. Type -> Args a -> Bool
fullyApplied (PrimInfo -> Type
primType PrimInfo
pr) [] =
      PrimInfo -> Args Value -> Eval Value
evalPrimOp PrimInfo
pr []

  | Bool
otherwise =
      Term -> Eval Term
etaExpand (PrimInfo -> Term
Prim PrimInfo
pr) Eval Term -> (Term -> Eval Value) -> Eval Value
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> Eval Value
eval

-- TODO Hook up to primitive evaluation skeleton
evalPrimOp :: PrimInfo -> Args Value -> Eval Value
evalPrimOp :: PrimInfo -> Args Value -> Eval Value
evalPrimOp PrimInfo
pr Args Value
args = Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (PrimInfo -> Args Value -> Neutral Value
forall a. PrimInfo -> Args a -> Neutral a
NePrim PrimInfo
pr Args Value
args))

fullyApplied :: Type -> Args a -> Bool
fullyApplied :: Type -> Args a -> Bool
fullyApplied Type
ty Args a
args =
  [Either TyVar Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (([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 Type
ty) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Args a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length Args a
args

etaExpand :: Term -> Eval Term
etaExpand :: Term -> Eval Term
etaExpand Term
term = do
  TyConMap
tcm <- Eval TyConMap
getTyConMap

  case Term -> (Term, Args Term)
collectArgs Term
term of
    x :: (Term, Args Term)
x@(Data DataCon
dc, Args Term
_) -> TyConMap -> Type -> (Term, Args Term) -> Eval Term
expand TyConMap
tcm (DataCon -> Type
dcType DataCon
dc) (Term, Args Term)
x
    x :: (Term, Args Term)
x@(Prim PrimInfo
pr, Args Term
_) -> TyConMap -> Type -> (Term, Args Term) -> Eval Term
expand TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
pr) (Term, Args Term)
x
    (Term, Args Term)
_ -> Term -> Eval Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
term
 where
  etaNameOf :: Either b Type -> Eval (Either Id b)
etaNameOf =
    (b -> Eval (Either Id b))
-> (Type -> Eval (Either Id b))
-> Either b Type
-> Eval (Either Id b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Id b -> Eval (Either Id b)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either Id b -> Eval (Either Id b))
-> (b -> Either Id b) -> b -> Eval (Either Id b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either Id b
forall a b. b -> Either a b
Right) ((Id -> Either Id b) -> Eval Id -> Eval (Either Id b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Either Id b
forall a b. a -> Either a b
Left (Eval Id -> Eval (Either Id b))
-> (Type -> Eval Id) -> Type -> Eval (Either Id b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Type -> Eval Id
getUniqueId OccName
"eta")

  expand :: TyConMap -> Type -> (Term, Args Term) -> Eval Term
expand TyConMap
tcm Type
ty (Term
tm, Args Term
args) = do
    let ([Either TyVar Type]
missingTys, Type
_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy (Term -> TyConMap -> Type -> Args Term -> Type
applyTypeToArgs Term
tm TyConMap
tcm Type
ty Args Term
args)
    [Either Id TyVar]
missingArgs <- (Either TyVar Type -> Eval (Either Id TyVar))
-> [Either TyVar Type] -> Eval [Either Id TyVar]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Either TyVar Type -> Eval (Either Id TyVar)
forall b. Either b Type -> Eval (Either Id b)
etaNameOf [Either TyVar Type]
missingTys

    Term -> Eval Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term -> Eval Term) -> Term -> Eval Term
forall a b. (a -> b) -> a -> b
$ Term -> [Either Id TyVar] -> Term
mkAbstraction
      (Term -> Args Term -> Term
mkApps Term
term ((Either Id TyVar -> Arg Term) -> [Either Id TyVar] -> Args Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Id -> Term) -> (TyVar -> Type) -> Either Id TyVar -> Arg Term
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Id -> Term
Var TyVar -> Type
VarTy) [Either Id TyVar]
missingArgs))
      [Either Id TyVar]
missingArgs

evalLam :: Id -> Term -> Eval Value
evalLam :: Id -> Term -> Eval Value
evalLam Id
i Term
x = do
  Type
varTy <- Type -> Eval Type
evalType (Id -> Type
forall a. Var a -> Type
varType Id
i)
  let i' :: Id
i' = Id
i { varType :: Type
varType = Type
varTy }
  LocalEnv
env <- Eval LocalEnv
getLocalEnv

  Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id -> Term -> LocalEnv -> Value
VLam Id
i' Term
x LocalEnv
env)

evalTyLam :: TyVar -> Term -> Eval Value
evalTyLam :: TyVar -> Term -> Eval Value
evalTyLam TyVar
i Term
x = do
  Type
varTy <- Type -> Eval Type
evalType (TyVar -> Type
forall a. Var a -> Type
varType TyVar
i)
  let i' :: TyVar
i' = TyVar
i { varType :: Type
varType = Type
varTy }
  LocalEnv
env <- Eval LocalEnv
getLocalEnv

  Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TyVar -> Term -> LocalEnv -> Value
VTyLam TyVar
i' Term
x LocalEnv
env)

evalApp :: Term -> Arg Term -> Eval Value
evalApp :: Term -> Arg Term -> Eval Value
evalApp Term
x Arg Term
y
  | Data DataCon
dc <- Term
f
  = if Type -> Args Term -> Bool
forall a. Type -> Args a -> Bool
fullyApplied (DataCon -> Type
dcType DataCon
dc) Args Term
args
      then do
        Args Value
argThunks <- Args Term -> Eval (Args Value)
delayArgs Args Term
args
        DataCon -> Args Value -> LocalEnv -> Value
VData DataCon
dc Args Value
argThunks (LocalEnv -> Value) -> Eval LocalEnv -> Eval Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval LocalEnv
getLocalEnv

      else Term -> Eval Term
etaExpand Term
term Eval Term -> (Term -> Eval Value) -> Eval Value
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> Eval Value
eval

  | Prim PrimInfo
pr <- Term
f
  , [Either TyVar Type]
prArgs  <- ([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
pr)
  , Int
numArgs <- [Either TyVar Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either TyVar Type]
prArgs
  = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Args Term -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length Args Term
args) Int
numArgs of
      Ordering
LT ->
        Term -> Eval Term
etaExpand Term
term Eval Term -> (Term -> Eval Value) -> Eval Value
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> Eval Value
eval

      Ordering
EQ -> do
        Args Value
argThunks <- Args Term -> Eval (Args Value)
delayArgs Args Term
args
        let tyVars :: [TyVar]
tyVars = [Either TyVar Type] -> [TyVar]
forall a b. [Either a b] -> [a]
lefts [Either TyVar Type]
prArgs
            tyArgs :: [Type]
tyArgs = Args Term -> [Type]
forall a b. [Either a b] -> [b]
rights Args Term
args

        [(TyVar, Type)] -> Eval Value -> Eval Value
forall a. [(TyVar, Type)] -> Eval a -> Eval a
withTyVars ([TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tyVars [Type]
tyArgs) (PrimInfo -> Args Value -> Eval Value
evalPrimOp PrimInfo
pr Args Value
argThunks)

      Ordering
GT -> do
        let (Args Term
pArgs, Args Term
rArgs) = Int -> Args Term -> (Args Term, Args Term)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
numArgs Args Term
args
        Args Value
pArgThunks <- Args Term -> Eval (Args Value)
delayArgs Args Term
pArgs
        Value
primRes <- PrimInfo -> Args Value -> Eval Value
evalPrimOp PrimInfo
pr Args Value
pArgThunks
        Args Value
rArgThunks <- Args Term -> Eval (Args Value)
delayArgs Args Term
rArgs

        (Value -> Arg Value -> Eval Value)
-> Value -> Args Value -> Eval Value
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Value -> Arg Value -> Eval Value
applyArg Value
primRes Args Value
rArgThunks

  | Bool
otherwise
  = Eval Value -> Eval Value
forall a. Eval a -> Eval a
preserveFuel (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ do
      Value
evalF <- Term -> Eval Value
eval Term
f
      Args Value
argThunks <- Args Term -> Eval (Args Value)
delayArgs Args Term
args
      (Value -> Arg Value -> Eval Value)
-> Value -> Args Value -> Eval Value
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Value -> Arg Value -> Eval Value
applyArg Value
evalF Args Value
argThunks
 where
  term :: Term
term = (Term -> Term) -> (Type -> Term) -> Arg Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Term -> Term -> Term
App Term
x) (Term -> Type -> Term
TyApp Term
x) Arg Term
y
  (Term
f, Args Term
args, [TickInfo]
_ticks) = Term -> (Term, Args Term, [TickInfo])
collectArgsTicks Term
term

evalLetrec :: [LetBinding] -> Term -> Eval Value
evalLetrec :: [LetBinding] -> Term -> Eval Value
evalLetrec [LetBinding]
bs Term
x = do
  -- Determine if a binding should be kept in a letrec or inlined. We keep
  -- bindings which perform work to prevent duplication of registers etc.
  ([(Id, Value)]
keep, [(Id, Value)]
inline) <- (([(Id, Value)], [(Id, Value)])
 -> SCC LetBinding -> Eval ([(Id, Value)], [(Id, Value)]))
-> ([(Id, Value)], [(Id, Value)])
-> [SCC LetBinding]
-> Eval ([(Id, Value)], [(Id, Value)])
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Id, Value)], [(Id, Value)])
-> SCC LetBinding -> Eval ([(Id, Value)], [(Id, Value)])
forall a.
([(Var a, Value)], [(Var a, Value)])
-> SCC (Var a, Term) -> Eval ([(Var a, Value)], [(Var a, Value)])
evalScc ([], []) (HasCallStack => [LetBinding] -> [SCC LetBinding]
[LetBinding] -> [SCC LetBinding]
Util.sccLetBindings [LetBinding]
bs)
  Value
eX <- [(Id, Value)] -> Eval Value -> Eval Value
forall a. [(Id, Value)] -> Eval a -> Eval a
withIds ([(Id, Value)]
keep [(Id, Value)] -> [(Id, Value)] -> [(Id, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Id, Value)]
inline) (Term -> Eval Value
eval Term
x)

  case [(Id, Value)]
keep of
    [] -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Value
eX
    [(Id, Value)]
_  -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec [(Id, Value)]
keep Value
eX))
 where
  evalBind :: (Var a, Term) -> Eval (Var a, Value)
evalBind (Var a
i, Term
y) = do
    Type
iTy <- Type -> Eval Type
evalType (Var a -> Type
forall a. Var a -> Type
varType Var a
i)
    Value
eY <- Term -> Eval Value
delayEval Term
y

    (Var a, Value) -> Eval (Var a, Value)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Var a
i { varType :: Type
varType = Type
iTy }, Value
eY)

  evalScc :: ([(Var a, Value)], [(Var a, Value)])
-> SCC (Var a, Term) -> Eval ([(Var a, Value)], [(Var a, Value)])
evalScc ([(Var a, Value)]
k, [(Var a, Value)]
i) = \case
    AcyclicSCC (Var a, Term)
y -> do
      (Var a, Value)
eY <- (Var a, Term) -> Eval (Var a, Value)
forall a. (Var a, Term) -> Eval (Var a, Value)
evalBind (Var a, Term)
y
      Bool
workFree <- Value -> Eval Bool
workFreeValue ((Var a, Value) -> Value
forall a b. (a, b) -> b
snd (Var a, Value)
eY)

      if Bool
workFree then ([(Var a, Value)], [(Var a, Value)])
-> Eval ([(Var a, Value)], [(Var a, Value)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Var a, Value)]
k, (Var a, Value)
eY(Var a, Value) -> [(Var a, Value)] -> [(Var a, Value)]
forall a. a -> [a] -> [a]
:[(Var a, Value)]
i) else ([(Var a, Value)], [(Var a, Value)])
-> Eval ([(Var a, Value)], [(Var a, Value)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Var a, Value)
eY(Var a, Value) -> [(Var a, Value)] -> [(Var a, Value)]
forall a. a -> [a] -> [a]
:[(Var a, Value)]
k, [(Var a, Value)]
i)

    CyclicSCC [(Var a, Term)]
ys -> do
      [(Var a, Value)]
eYs <- ((Var a, Term) -> Eval (Var a, Value))
-> [(Var a, Term)] -> Eval [(Var a, Value)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Var a, Term) -> Eval (Var a, Value)
forall a. (Var a, Term) -> Eval (Var a, Value)
evalBind [(Var a, Term)]
ys
      ([(Var a, Value)], [(Var a, Value)])
-> Eval ([(Var a, Value)], [(Var a, Value)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Var a, Value)]
eYs [(Var a, Value)] -> [(Var a, Value)] -> [(Var a, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Var a, Value)]
k, [(Var a, Value)]
i)

evalCase :: Term -> Type -> [Alt] -> Eval Value
evalCase :: Term -> Type -> [Alt] -> Eval Value
evalCase Term
term Type
ty [Alt]
as = do
  Value
subject <- Term -> Eval Value
delayEval Term
term
  Type
resTy <- Type -> Eval Type
evalType Type
ty
  [(Pat, Value)]
alts <- [Alt] -> Eval [(Pat, Value)]
delayAlts [Alt]
as

  Value -> Type -> [(Pat, Value)] -> Eval Value
caseCon Value
subject Type
resTy [(Pat, Value)]
alts

-- | Attempt to apply the case-of-known-constructor transformation on a case
-- expression. If no suitable alternative can be chosen, attempt to transform
-- the case expression to try and expose more opportunities.
--
caseCon :: Value -> Type -> [(Pat, Value)] -> Eval Value
caseCon :: Value -> Type -> [(Pat, Value)] -> Eval Value
caseCon Value
subject Type
ty [(Pat, Value)]
alts = do
  Value
forcedSubject <- Eval Value -> Eval Value
forall a. Eval a -> Eval a
keepLifted (Value -> Eval Value
forceEval Value
subject)

  -- If the subject is undefined, the whole expression is undefined.
  case Value -> Bool
isUndefined Value
forcedSubject of
    Bool
True -> Term -> Eval Value
eval (Type -> Term
Util.undefinedTm Type
ty)
    Bool
False ->
      case Value -> Value
stripValue Value
forcedSubject of
        -- Known literal: attempt to match or throw an error.
        VLiteral Literal
lit -> do
          let def :: a
def = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"caseCon: No pattern matched " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Literal -> [Char]
forall a. Show a => a -> [Char]
show Literal
lit [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Pat, Value)] -> [Char]
forall a. Show a => a -> [Char]
show [(Pat, Value)]
alts)
          PatResult
match <- ((Pat, Value) -> Eval PatResult)
-> [(Pat, Value)] -> Eval PatResult
findBestAlt (Literal -> (Pat, Value) -> Eval PatResult
matchLiteral Literal
lit) [(Pat, Value)]
alts
          Value -> PatResult -> Eval Value
evalAlt Value
forall a. a
def PatResult
match

        -- Known data constructor: attempt to match or throw an error.
        -- The environment here is the same as the current environment.
        VData DataCon
dc Args Value
args LocalEnv
_env -> do
          let def :: a
def = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"caseCon: No pattern matched " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> DataCon -> [Char]
forall a. Show a => a -> [Char]
show DataCon
dc [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Pat, Value)] -> [Char]
forall a. Show a => a -> [Char]
show [(Pat, Value)]
alts)
          PatResult
match <- ((Pat, Value) -> Eval PatResult)
-> [(Pat, Value)] -> Eval PatResult
findBestAlt (DataCon -> Args Value -> (Pat, Value) -> Eval PatResult
matchData DataCon
dc Args Value
args) [(Pat, Value)]
alts
          Value -> PatResult -> Eval Value
evalAlt Value
forall a. a
def PatResult
match

        -- Neutral primitives may be clash primitives which are treated as
        -- values, like fromInteger# for various types in clash-prelude.
        VNeutral (NePrim PrimInfo
pr Args Value
args) -> do
          let def :: Value
def = Neutral Value -> Value
VNeutral (Value -> Type -> [(Pat, Value)] -> Neutral Value
forall a. a -> Type -> [(Pat, a)] -> Neutral a
NeCase Value
forcedSubject Type
ty [(Pat, Value)]
alts)
          PatResult
match <- ((Pat, Value) -> Eval PatResult)
-> [(Pat, Value)] -> Eval PatResult
findBestAlt (PrimInfo -> Args Value -> (Pat, Value) -> Eval PatResult
matchClashPrim PrimInfo
pr Args Value
args) [(Pat, Value)]
alts
          Value -> PatResult -> Eval Value
evalAlt Value
def PatResult
match

        -- We know nothing: attempt case-of-case / case-of-let.
        Value
_ -> Value -> Type -> [(Pat, Value)] -> Eval Value
tryTransformCase Value
forcedSubject Type
ty [(Pat, Value)]
alts

-- | Attempt to apply a transformation to a case expression to expose more
-- opportunities for caseCon. If no transformations can be applied the
-- case expression can only be neutral.
--
tryTransformCase :: Value -> Type -> [(Pat, Value)] -> Eval Value
tryTransformCase :: Value -> Type -> [(Pat, Value)] -> Eval Value
tryTransformCase Value
subject Type
ty [(Pat, Value)]
alts =
  case Value -> Value
stripValue Value
subject of
    -- A case of case: pull out the inner case expression if possible and
    -- attempt caseCon on the new case expression.
    VNeutral (NeCase Value
innerSubject Type
_ [(Pat, Value)]
innerAlts) -> do
      [(Pat, Value)]
forcedAlts <- [(Pat, Value)] -> Eval [(Pat, Value)]
forceAlts [(Pat, Value)]
innerAlts

      if ((Pat, Value) -> Bool) -> [(Pat, Value)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (Value -> Bool
isKnown (Value -> Bool) -> ((Pat, Value) -> Value) -> (Pat, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat, Value) -> Value
forall a b. (a, b) -> b
snd) [(Pat, Value)]
forcedAlts
       then let asCase :: Value -> Value
asCase Value
v = Neutral Value -> Value
VNeutral (Value -> Type -> [(Pat, Value)] -> Neutral Value
forall a. a -> Type -> [(Pat, a)] -> Neutral a
NeCase Value
v Type
ty [(Pat, Value)]
alts)
                newAlts :: [(Pat, Value)]
newAlts  = (Value -> Value) -> (Pat, Value) -> (Pat, Value)
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Value -> Value
asCase ((Pat, Value) -> (Pat, Value)) -> [(Pat, Value)] -> [(Pat, Value)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Pat, Value)]
innerAlts
             in Value -> Type -> [(Pat, Value)] -> Eval Value
caseCon Value
innerSubject Type
ty [(Pat, Value)]
newAlts

        else Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Value -> Type -> [(Pat, Value)] -> Neutral Value
forall a. a -> Type -> [(Pat, a)] -> Neutral a
NeCase Value
subject Type
ty [(Pat, Value)]
alts))

    -- A case of let: Pull out the let expression if possible and attempt
    -- caseCon on the new case expression.
    VNeutral (NeLetrec [(Id, Value)]
bindings Value
innerSubject) -> do
      Value
newCase <- Value -> Type -> [(Pat, Value)] -> Eval Value
caseCon Value
innerSubject Type
ty [(Pat, Value)]
alts
      Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec [(Id, Value)]
bindings Value
newCase))

    -- There is no way to continue evaluating the case, do nothing.
    -- TODO elimExistentials here.
    Value
_ -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Value -> Type -> [(Pat, Value)] -> Neutral Value
forall a. a -> Type -> [(Pat, a)] -> Neutral a
NeCase Value
subject Type
ty [(Pat, Value)]
alts))
 where
  -- We only care about case of case if alternatives of the inner case
  -- expression correspond to something we can do caseCon on.
  --
  -- TODO We may also care if it is another case of case?
  --
  isKnown :: Value -> Bool
isKnown = \case
    VNeutral (NePrim PrimInfo
pr Args Value
_) ->
      PrimInfo -> OccName
primName PrimInfo
pr OccName -> [OccName] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem`
        [ OccName
"Clash.Sized.Internal.BitVector.fromInteger##"
        , OccName
"Clash.Sized.Internal.BitVector.fromInteger#"
        , OccName
"Clash.Sized.Internal.Index.fromInteger#"
        , OccName
"Clash.Sized.Internal.Signed.fromInteger#"
        , OccName
"Clash.Sized.Internal.Unsigned.fromInteger#"
        ]

    VLiteral{} -> Bool
True
    VData{} -> Bool
True
    Value
_ -> Bool
False

delayAlts :: [Alt] -> Eval [(Pat, Value)]
delayAlts :: [Alt] -> Eval [(Pat, Value)]
delayAlts = (Alt -> Eval (Pat, Value)) -> [Alt] -> Eval [(Pat, Value)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Pat -> Eval Pat)
-> (Term -> Eval Value) -> Alt -> Eval (Pat, Value)
forall (t :: Type -> Type -> Type) (f :: Type -> Type) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Pat -> Eval Pat
delayPat Term -> Eval Value
delayEval)
 where
  delayPat :: Pat -> Eval Pat
delayPat = \case
    DataPat DataCon
dc [TyVar]
tvs [Id]
ids -> do
      [Type]
tvsTys <- (Type -> Eval Type) -> [Type] -> Eval [Type]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Eval Type
evalType ((TyVar -> Type) -> [TyVar] -> [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVar -> Type
forall a. Var a -> Type
varType [TyVar]
tvs)
      [Type]
idsTys <- (Type -> Eval Type) -> [Type] -> Eval [Type]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Eval Type
evalType ((Id -> Type) -> [Id] -> [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Type
forall a. Var a -> Type
varType [Id]
ids)

      let setTy :: Var a -> Type -> Var a
setTy Var a
v Type
ty = Var a
v { varType :: Type
varType = Type
ty }
          tvs' :: [TyVar]
tvs' = (TyVar -> Type -> TyVar) -> [TyVar] -> [Type] -> [TyVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyVar -> Type -> TyVar
forall a. Var a -> Type -> Var a
setTy [TyVar]
tvs [Type]
tvsTys
          ids' :: [Id]
ids' = (Id -> Type -> Id) -> [Id] -> [Type] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> Type -> Id
forall a. Var a -> Type -> Var a
setTy [Id]
ids [Type]
idsTys

      Pat -> Eval Pat
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DataCon -> [TyVar] -> [Id] -> Pat
DataPat DataCon
dc [TyVar]
tvs' [Id]
ids')

    Pat
pat -> Pat -> Eval Pat
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Pat
pat

forceAlts :: [(Pat, Value)] -> Eval [(Pat, Value)]
forceAlts :: [(Pat, Value)] -> Eval [(Pat, Value)]
forceAlts = ((Pat, Value) -> Eval (Pat, Value))
-> [(Pat, Value)] -> Eval [(Pat, Value)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Eval Value) -> (Pat, Value) -> Eval (Pat, Value)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Eval Value
forceEval)

data PatResult
  = Match   (Pat, Value) [(TyVar, Type)] [(Id, Value)]
  | NoMatch

evalAlt :: Value -> PatResult -> Eval Value
evalAlt :: Value -> PatResult -> Eval Value
evalAlt Value
def = \case
  Match (Pat
_, Value
val) [(TyVar, Type)]
tvs [(Id, Value)]
ids ->
    [(TyVar, Type)] -> [(Id, Value)] -> Value -> Eval Value
forceEvalWith [(TyVar, Type)]
tvs [(Id, Value)]
ids Value
val

  PatResult
NoMatch -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Value
def

matchLiteral :: Literal -> (Pat, Value) -> Eval PatResult
matchLiteral :: Literal -> (Pat, Value) -> Eval PatResult
matchLiteral Literal
lit alt :: (Pat, Value)
alt@(Pat
pat, Value
_) =
  case Pat
pat of
    DataPat DataCon
dc [] [Id
i]
      |  IntegerLiteral Integer
n <- Literal
lit
      -> case Integer
n of
#if MIN_VERSION_base(4,15,0)
           IS _
#else
           S# Int#
_
#endif
             | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PatResult -> Eval PatResult) -> PatResult -> Eval PatResult
forall a b. (a -> b) -> a -> b
$ (Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [(Id
i, Literal -> Value
VLiteral (Integer -> Literal
IntLiteral Integer
n))]

#if MIN_VERSION_base(4,15,0)
           IP bn
#else
           Jp# BigNat
bn
#endif
             | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> Id -> BigNat -> Eval PatResult
matchBigNat Id
i BigNat
bn

#if MIN_VERSION_base(4,15,0)
           IN bn
#else
           Jn# BigNat
bn
#endif
             | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> Id -> BigNat -> Eval PatResult
matchBigNat Id
i BigNat
bn

           Integer
_ -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

      |  NaturalLiteral Integer
n <- Literal
lit
      -> case Integer
n of
#if MIN_VERSION_base(4,15,0)
           IS _
#else
           S# Int#
_
#endif
             | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PatResult -> Eval PatResult) -> PatResult -> Eval PatResult
forall a b. (a -> b) -> a -> b
$ (Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [(Id
i, Literal -> Value
VLiteral (Integer -> Literal
WordLiteral Integer
n))]

#if MIN_VERSION_base(4,15,0)
           IP bn
#else
           Jp# BigNat
bn
#endif
             | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> Id -> BigNat -> Eval PatResult
matchBigNat Id
i BigNat
bn

           Integer
_ -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

    LitPat Literal
n
      | Literal
lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
n -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PatResult -> Eval PatResult) -> PatResult -> Eval PatResult
forall a b. (a -> b) -> a -> b
$ (Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] []

    Pat
DefaultPat -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PatResult -> Eval PatResult) -> PatResult -> Eval PatResult
forall a b. (a -> b) -> a -> b
$ (Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] []

    Pat
_ -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch
 where
  -- Somewhat of a hack: We find the constructor for BigNat and apply a
  -- ByteArray literal made from the given ByteArray to it.
#if MIN_VERSION_base(4,15,0)
  matchBigNat i ba = do
#else
  matchBigNat :: Id -> BigNat -> Eval PatResult
matchBigNat Id
i (BN# ByteArray#
ba) = do
#endif
    TyConMap
tcm <- Eval TyConMap
getTyConMap
    let Just TyConName
integerTcName = ((TyConName, [Type]) -> TyConName)
-> Maybe (TyConName, [Type]) -> Maybe TyConName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyConName, [Type]) -> TyConName
forall a b. (a, b) -> a
fst (Type -> Maybe (TyConName, [Type])
splitTyConAppM Type
integerPrimTy)
        [DataCon
_, DataCon
jpDc, DataCon
_] = TyCon -> [DataCon]
tyConDataCons (TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
lookupUniqMap' TyConMap
tcm TyConName
integerTcName)
        ([Type
bnTy], Type
_) = TyConMap -> Type -> ([Type], Type)
splitFunTys TyConMap
tcm (DataCon -> Type
dcType DataCon
jpDc)
        Just TyConName
bnTcName = ((TyConName, [Type]) -> TyConName)
-> Maybe (TyConName, [Type]) -> Maybe TyConName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyConName, [Type]) -> TyConName
forall a b. (a, b) -> a
fst (Type -> Maybe (TyConName, [Type])
splitTyConAppM Type
bnTy)
        [DataCon
bnDc] = TyCon -> [DataCon]
tyConDataCons (TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
lookupUniqMap' TyConMap
tcm TyConName
bnTcName)

    let arr :: Literal
arr = ByteArray -> Literal
ByteArrayLiteral (ByteArray# -> ByteArray
ByteArray ByteArray#
ba)
    Value
val <- DataCon -> Args Value -> LocalEnv -> Value
VData DataCon
bnDc [Value -> Arg Value
forall a b. a -> Either a b
Left (Literal -> Value
VLiteral Literal
arr)] (LocalEnv -> Value) -> Eval LocalEnv -> Eval Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval LocalEnv
getLocalEnv

    PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [(Id
i, Value
val)])

matchData :: DataCon -> Args Value -> (Pat, Value) -> Eval PatResult
matchData :: DataCon -> Args Value -> (Pat, Value) -> Eval PatResult
matchData DataCon
dc Args Value
args alt :: (Pat, Value)
alt@(Pat
pat, Value
_) =
  case Pat
pat of
    DataPat DataCon
c [TyVar]
tvs [Id]
ids
      |  DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
c
      -> do let ([(Id, Value)]
tms, [(TyVar, Type)]
tys) = ([Value] -> [(Id, Value)])
-> ([Type] -> [(TyVar, Type)])
-> ([Value], [Type])
-> ([(Id, Value)], [(TyVar, Type)])
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ([Id] -> [Value] -> [(Id, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
ids) ([TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tvs) (Args Value -> ([Value], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers Args Value
args)
            PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [(TyVar, Type)]
tys [(Id, Value)]
tms)

    Pat
DefaultPat -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [])
    Pat
_ -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

-- TODO Should this also consider DataPat and data constructors?
-- The old evaluator did not, but matchData wouldn't cover it.
--
matchClashPrim :: PrimInfo -> Args Value -> (Pat, Value) -> Eval PatResult
matchClashPrim :: PrimInfo -> Args Value -> (Pat, Value) -> Eval PatResult
matchClashPrim PrimInfo
pr Args Value
args alt :: (Pat, Value)
alt@(Pat
pat, Value
_) =
  case Pat
pat of
    LitPat Literal
lit
      -- Bit literals
      |  PrimInfo -> OccName
primName PrimInfo
pr OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"Clash.Sized.BitVector.fromInteger##"
      ,  [Left Value
mask, Left Value
val] <- Args Value
args
      -> do VLiteral (WordLiteral Integer
m) <- Value -> Eval Value
forceEval Value
mask
            VLiteral Literal
l <- Value -> Eval Value
forceEval Value
val

            if Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit
              then PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [])
              else PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

      -- BitVector literals
      |  PrimInfo -> OccName
primName PrimInfo
pr OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"Clash.Sized.BitVector.fromInteger#"
      ,  [Right Type
_n, Left Value
_knN, Left Value
mask, Left Value
val] <- Args Value
args
      -> do VLiteral (NaturalLiteral Integer
m) <- Value -> Eval Value
forceEval Value
mask
            VLiteral Literal
l <- Value -> Eval Value
forceEval Value
val

            if Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit
              then PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [])
              else PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

      -- Sized integer / natural literals
      |  PrimInfo -> OccName
primName PrimInfo
pr OccName -> [OccName] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [OccName]
clashSizedNumbers
      ,  [Right Type
_n, Left Value
_knN, Left Value
val] <- Args Value
args
      -> do VLiteral Literal
l <- Value -> Eval Value
forceEval Value
val

            if Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit
              then PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Pat, Value) -> [(TyVar, Type)] -> [(Id, Value)] -> PatResult
Match (Pat, Value)
alt [] [])
              else PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch

    -- The primitive is not a literal from clash-prelude
    Pat
_ -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
NoMatch
 where
  clashSizedNumbers :: [OccName]
clashSizedNumbers =
    [ OccName
"Clash.Sized.Internal.Index.fromInteger#"
    , OccName
"Clash.Sized.Internal.Signed.fromInteger#"
    , OccName
"Clash.Sized.Internal.Unsigned.fromInteger#"
    ]

-- | Given a predicate to check if an alternative is a match, find the best
-- alternative that matches the predicate. Best is defined as being the most
-- specific matching pattern (meaning DefaultPat is only used if no other
-- pattern tried matches).
--
findBestAlt
  :: ((Pat, Value) -> Eval PatResult)
  -> [(Pat, Value)]
  -> Eval PatResult
findBestAlt :: ((Pat, Value) -> Eval PatResult)
-> [(Pat, Value)] -> Eval PatResult
findBestAlt (Pat, Value) -> Eval PatResult
checkAlt =
  PatResult -> [(Pat, Value)] -> Eval PatResult
go PatResult
NoMatch
 where
  go :: PatResult -> [(Pat, Value)] -> Eval PatResult
go !PatResult
acc [] = PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
acc
  go !PatResult
acc ((Pat, Value)
a:[(Pat, Value)]
as) = do
    PatResult
match <- (Pat, Value) -> Eval PatResult
checkAlt (Pat, Value)
a
    case PatResult
match of
      Match (Pat
pat, Value
_term) [(TyVar, Type)]
_tvs [(Id, Value)]
_ids
        | Pat
pat Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Pat
DefaultPat -> PatResult -> [(Pat, Value)] -> Eval PatResult
go PatResult
match [(Pat, Value)]
as
        | Bool
otherwise -> PatResult -> Eval PatResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PatResult
match

      PatResult
NoMatch -> PatResult -> [(Pat, Value)] -> Eval PatResult
go PatResult
acc [(Pat, Value)]
as

evalCast :: Term -> Type -> Type -> Eval Value
evalCast :: Term -> Type -> Type -> Eval Value
evalCast Term
x Type
a Type
b = Value -> Type -> Type -> Value
VCast (Value -> Type -> Type -> Value)
-> Eval Value -> Eval (Type -> Type -> Value)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Eval Value
eval Term
x Eval (Type -> Type -> Value) -> Eval Type -> Eval (Type -> Value)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> Eval Type
evalType Type
a Eval (Type -> Value) -> Eval Type -> Eval Value
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> Eval Type
evalType Type
b

evalTick :: TickInfo -> Term -> Eval Value
evalTick :: TickInfo -> Term -> Eval Value
evalTick TickInfo
tick Term
x = Value -> TickInfo -> Value
VTick (Value -> TickInfo -> Value)
-> Eval Value -> Eval (TickInfo -> Value)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Eval Value
eval Term
x Eval (TickInfo -> Value) -> Eval TickInfo -> Eval Value
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TickInfo -> Eval TickInfo
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TickInfo
tick

applyArg :: Value -> Arg Value -> Eval Value
applyArg :: Value -> Arg Value -> Eval Value
applyArg Value
val =
  (Value -> Eval Value)
-> (Type -> Eval Value) -> Arg Value -> Eval Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Value -> Value -> Eval Value
apply Value
val) (Value -> Type -> Eval Value
applyTy Value
val)

apply :: Value -> Value -> Eval Value
apply :: Value -> Value -> Eval Value
apply Value
val Value
arg = do
  TyConMap
tcm <- Eval TyConMap
getTyConMap
  Value
forced <- Value -> Eval Value
forceEval Value
val
  Bool
canApply <- Value -> Eval Bool
workFreeValue Value
arg

  case Value -> Value
stripValue Value
forced of
    -- If the LHS of application evaluates to a letrec, then add any bindings
    -- that do work to this letrec instead of creating a new one.
    VNeutral (NeLetrec [(Id, Value)]
bs Value
x)
      | Bool
canApply  -> do
          Value
inner <- Value -> Value -> Eval Value
apply Value
x Value
arg
          Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec [(Id, Value)]
bs Value
inner))

      | Bool
otherwise -> do
          Type
varTy <- Type -> Eval Type
evalType (TyConMap -> Value -> Type
forall a. AsTerm a => TyConMap -> a -> Type
valueType TyConMap
tcm Value
arg)
          Id
var <- OccName -> Type -> Eval Id
getUniqueId OccName
"workArg" Type
varTy
          Value
inner <- Value -> Value -> Eval Value
apply Value
x (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
var))
          Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec ((Id
var, Value
arg) (Id, Value) -> [(Id, Value)] -> [(Id, Value)]
forall a. a -> [a] -> [a]
: [(Id, Value)]
bs) Value
inner))

    -- If the LHS of application is neutral, make a letrec around the neutral
    -- application if the argument performs work.
    VNeutral Neutral Value
neu
      | Bool
canApply  -> Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Neutral Value -> Value -> Neutral Value
forall a. Neutral a -> a -> Neutral a
NeApp Neutral Value
neu Value
arg))
      | Bool
otherwise -> do
          Type
varTy <- Type -> Eval Type
evalType (TyConMap -> Value -> Type
forall a. AsTerm a => TyConMap -> a -> Type
valueType TyConMap
tcm Value
arg)
          Id
var <- OccName -> Type -> Eval Id
getUniqueId OccName
"workArg" Type
varTy
          let inner :: Value
inner = Neutral Value -> Value
VNeutral (Neutral Value -> Value -> Neutral Value
forall a. Neutral a -> a -> Neutral a
NeApp Neutral Value
neu (Neutral Value -> Value
VNeutral (Id -> Neutral Value
forall a. Id -> Neutral a
NeVar Id
var)))
          Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec [(Id
var, Value
arg)] Value
inner))

    -- If the LHS of application is a lambda, make a letrec with the name of
    -- the argument around the result of evaluation if it performs work.
    VLam Id
i Term
x LocalEnv
env
      | Bool
canApply  -> LocalEnv -> Eval Value -> Eval Value
forall a. LocalEnv -> Eval a -> Eval a
setLocalEnv LocalEnv
env (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Id -> Value -> Eval Value -> Eval Value
forall a. Id -> Value -> Eval a -> Eval a
withId Id
i Value
arg (Term -> Eval Value
eval Term
x)
      | Bool
otherwise -> LocalEnv -> Eval Value -> Eval Value
forall a. LocalEnv -> Eval a -> Eval a
setLocalEnv LocalEnv
env (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ do
          Value
inner <- Id -> Value -> Eval Value -> Eval Value
forall a. Id -> Value -> Eval a -> Eval a
withId Id
i Value
arg (Term -> Eval Value
eval Term
x)
          Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral ([(Id, Value)] -> Value -> Neutral Value
forall a. [(Id, a)] -> a -> Neutral a
NeLetrec [(Id
i, Value
arg)] Value
inner))

    Value
f ->
      [Char] -> Eval Value
forall a. HasCallStack => [Char] -> a
error ([Char]
"apply: Cannot apply " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
arg [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
f)
 where
  -- Somewhat of a cheat, but very quick to implement.
  valueType :: TyConMap -> a -> Type
valueType TyConMap
tcm = TyConMap -> Term -> Type
termType TyConMap
tcm (Term -> Type) -> (a -> Term) -> a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Term
forall a. AsTerm a => a -> Term
asTerm

applyTy :: Value -> Type -> Eval Value
applyTy :: Value -> Type -> Eval Value
applyTy Value
val Type
ty = do
  Value
forcedVal <- Value -> Eval Value
forceEval Value
val
  Type
argTy <- Type -> Eval Type
evalType Type
ty

  case Value -> Value
stripValue Value
forcedVal of
    VNeutral Neutral Value
n ->
      Value -> Eval Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Neutral Value -> Value
VNeutral (Neutral Value -> Type -> Neutral Value
forall a. Neutral a -> Type -> Neutral a
NeTyApp Neutral Value
n Type
argTy))

    VTyLam TyVar
i Term
x LocalEnv
env ->
      LocalEnv -> Eval Value -> Eval Value
forall a. LocalEnv -> Eval a -> Eval a
setLocalEnv LocalEnv
env (Eval Value -> Eval Value) -> Eval Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ TyVar -> Type -> Eval Value -> Eval Value
forall a. TyVar -> Type -> Eval a -> Eval a
withTyVar TyVar
i Type
argTy (Term -> Eval Value
eval Term
x)

    Value
f ->
      [Char] -> Eval Value
forall a. HasCallStack => [Char] -> a
error ([Char]
"applyTy: Cannot apply " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall a. Show a => a -> [Char]
show Type
argTy [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
f)