{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2022, Google Inc.,
                     2017-2026, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>
-}

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

module Clash.GHC.Evaluator.Primitive
  ( ghcPrimStep
  , ghcPrimUnwind
  , isUndefinedPrimVal
  , isUndefinedXPrimVal
  ) where

import qualified Data.HashMap.Strict as HashMap
import           Data.Text.Extra     (showt)
import           GHC.Prim

import           Clash.Core.Evaluator.Types
import Clash.Core.HasType (applyTypeToArgs)
import           Clash.Core.Literal  (Literal (..))
import Clash.Core.Term (PrimInfo (..), Term (..))
import Clash.Core.Util (undefinedPrims, undefinedXPrims)
import Clash.Util (curLoc)

import qualified Clash.Normalize.Primitives as NP
import qualified Clash.Sized.Internal.BitVector as BitVector

import {-# SOURCE #-} Clash.GHC.Evaluator

import qualified Clash.Sized.Internal.BitVector
import qualified Clash.Sized.Internal.Index
import qualified Clash.Sized.Internal.Signed
import qualified Clash.Sized.Internal.Unsigned
import qualified Clash.Sized.Vector
import qualified GHC.Classes
import qualified GHC.CString

import Clash.GHC.Evaluator.Primitive.Util
import Clash.GHC.Evaluator.Primitives (ghcPrimStepImpls)

isUndefinedPrimVal :: Value -> Bool
isUndefinedPrimVal :: Value -> Bool
isUndefinedPrimVal (PrimVal (PrimInfo{Text
primName :: Text
primName :: PrimInfo -> Text
primName}) [Type]
_ [Value]
_) =
  Text
primName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text]
undefinedPrims
isUndefinedPrimVal Value
_ = Bool
False

isUndefinedXPrimVal :: Value -> Bool
isUndefinedXPrimVal :: Value -> Bool
isUndefinedXPrimVal (PrimVal (PrimInfo{Text
primName :: PrimInfo -> Text
primName :: Text
primName}) [Type]
_ [Value]
_) =
  Text
primName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text]
undefinedXPrims
isUndefinedXPrimVal Value
_ = Bool
False

-- | Evaluation of primitive operations.
ghcPrimUnwind :: PrimUnwind
ghcPrimUnwind :: PrimUnwind
ghcPrimUnwind TyConMap
tcm PrimInfo
p [Type]
tys [Value]
vs Value
v [] Machine
m
  | PrimInfo -> Text
primName PrimInfo
p Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Internal.Index.fromInteger#
                       , Name -> Text
forall a. Show a => a -> Text
showt 'GHC.CString.unpackCString#
                       , Name -> Text
forall a. Show a => a -> Text
showt 'NP.removedArg
                       , Name -> Text
forall a. Show a => a -> Text
showt ''MutableByteArray#
                       , Name -> Text
forall a. Show a => a -> Text
showt 'NP.undefined
                       , Name -> Text
forall a. Show a => a -> Text
showt 'NP.undefinedX
                       ]
              -- The above primitives are actually values, and not operations.
  = Unwind
ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v])) Machine
m TyConMap
tcm
  | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Internal.BitVector.fromInteger#
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just Integer
n,Value
mask], Value -> Maybe Integer
integerLiteral -> Just Integer
i) ->
      Unwind
ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n), Value
mask, Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned Integer
n Integer
i))]) Machine
m TyConMap
tcm
    ([Value], Value)
_ -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Internal error"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> [Char]
forall a. Show a => a -> [Char]
show ([Value]
vs,Value
v))
  | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Internal.BitVector.fromInteger##
  = case ([Value]
vs,Value
v) of
    ([Value
mask], Value -> Maybe Integer
integerLiteral -> Just Integer
i) ->
      Unwind
ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p [Type]
tys [Value
mask, Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned Integer
1 Integer
i))]) Machine
m TyConMap
tcm
    ([Value], Value)
_ -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Internal error"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> [Char]
forall a. Show a => a -> [Char]
show ([Value]
vs,Value
v))
  | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Internal.Signed.fromInteger#
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just Integer
n],Value -> Maybe Integer
integerLiteral -> Just Integer
i) ->
      Unwind
ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n), Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapSigned Integer
n Integer
i))]) Machine
m TyConMap
tcm
    ([Value], Value)
_ -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Internal error"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> [Char]
forall a. Show a => a -> [Char]
show ([Value]
vs,Value
v))
  | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Internal.Unsigned.fromInteger#
  = case ([Value]
vs,Value
v) of
    ([Value -> Maybe Integer
naturalLiteral -> Just Integer
n],Value -> Maybe Integer
integerLiteral -> Just Integer
i) ->
      Unwind
ghcUnwind (PrimInfo -> [Type] -> [Value] -> Value
PrimVal PrimInfo
p [Type]
tys [Literal -> Value
Lit (Integer -> Literal
NaturalLiteral Integer
n), Literal -> Value
Lit (Integer -> Literal
IntegerLiteral (Integer -> Integer -> Integer
wrapUnsigned Integer
n Integer
i))]) Machine
m TyConMap
tcm
    ([Value], Value)
_ -> [Char] -> Maybe Machine
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Internal error"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Value], Value) -> [Char]
forall a. Show a => a -> [Char]
show ([Value]
vs,Value
v))
  | Value -> Bool
isUndefinedPrimVal Value
v
  = let tyArgs :: [Either a Type]
tyArgs = (Type -> Either a Type) -> [Type] -> [Either a Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either a Type
forall a b. b -> Either a b
Right [Type]
tys
        tmArgs :: [Either Term b]
tmArgs = (Value -> Either Term b) -> [Value] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b)
-> (Value -> Term) -> Value -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valToTerm) ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v])
    in  Machine -> Maybe Machine
forall a. a -> Maybe a
Just (Machine -> Maybe Machine) -> Machine -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ (Term -> Machine -> Machine) -> Machine -> Term -> Machine
forall a b c. (a -> b -> c) -> b -> a -> c
flip Term -> Machine -> Machine
setTerm Machine
m (Term -> Machine) -> Term -> Machine
forall a b. (a -> b) -> a -> b
$ Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
NP.undefined) (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$
          Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs (PrimInfo -> Term
Prim PrimInfo
p) TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
p) ([Either Term Type]
forall {a}. [Either a Type]
tyArgs [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++ [Either Term Type]
forall {b}. [Either Term b]
tmArgs)
  | Value -> Bool
isUndefinedXPrimVal Value
v
  = let tyArgs :: [Either a Type]
tyArgs = (Type -> Either a Type) -> [Type] -> [Either a Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either a Type
forall a b. b -> Either a b
Right [Type]
tys
        tmArgs :: [Either Term b]
tmArgs = (Value -> Either Term b) -> [Value] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b)
-> (Value -> Term) -> Value -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valToTerm) ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v])
    in  Machine -> Maybe Machine
forall a. a -> Maybe a
Just (Machine -> Maybe Machine) -> Machine -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ (Term -> Machine -> Machine) -> Machine -> Term -> Machine
forall a b c. (a -> b -> c) -> b -> a -> c
flip Term -> Machine -> Machine
setTerm Machine
m (Term -> Machine) -> Term -> Machine
forall a b. (a -> b) -> a -> b
$ Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
NP.undefinedX) (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$
          Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs (PrimInfo -> Term
Prim PrimInfo
p) TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
p) ([Either Term Type]
forall {a}. [Either a Type]
tyArgs [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++ [Either Term Type]
forall {b}. [Either Term b]
tmArgs)
  | Bool
otherwise
  = PrimStep
ghcPrimStep TyConMap
tcm (Machine -> Bool
forcePrims Machine
m) PrimInfo
p [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v]) Machine
m

ghcPrimUnwind TyConMap
tcm PrimInfo
p [Type]
tys [Value]
vs Value
v [Term
e] Machine
m0
  -- Note [Lazy primitives]
  -- ~~~~~~~~~~~~~~~~~~~~~~
  --
  -- Primitives are usually considered undefined when one of their arguments is
  -- (unless they're unused). _Some_ primitives can still yield a result even
  -- though one of their arguments is undefined. It turns out that all primitives
  -- exhibiting this property happen to be "lazy" in their last argument. Thus,
  -- all the cases can be covered by a match on [e] and their names:
  | PrimInfo -> Text
primName PrimInfo
p Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [  Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Vector.lazyV
                       , Name -> Text
forall a. Show a => a -> Text
showt 'Clash.Sized.Vector.replicate
                       , Text
"Clash.Sized.Vector.replace_int"
                       , Name -> Text
forall a. Show a => a -> Text
showt '(GHC.Classes.&&)
                       , Name -> Text
forall a. Show a => a -> Text
showt '(GHC.Classes.||)
                       , Name -> Text
forall a. Show a => a -> Text
showt 'BitVector.xToBV
                       , Text
"Clash.Sized.Vector.imap_go"
                       ]
  = if Value -> Bool
isUndefinedPrimVal Value
v then
      let tyArgs :: [Either a Type]
tyArgs = (Type -> Either a Type) -> [Type] -> [Either a Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either a Type
forall a b. b -> Either a b
Right [Type]
tys
          tmArgs :: [Either Term b]
tmArgs = (Value -> Either Term b) -> [Value] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b)
-> (Value -> Term) -> Value -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valToTerm) ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v]) [Either Term b] -> [Either Term b] -> [Either Term b]
forall a. [a] -> [a] -> [a]
++ [Term -> Either Term b
forall a b. a -> Either a b
Left Term
e]
      in  Machine -> Maybe Machine
forall a. a -> Maybe a
Just (Machine -> Maybe Machine) -> Machine -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ (Term -> Machine -> Machine) -> Machine -> Term -> Machine
forall a b c. (a -> b -> c) -> b -> a -> c
flip Term -> Machine -> Machine
setTerm Machine
m0 (Term -> Machine) -> Term -> Machine
forall a b. (a -> b) -> a -> b
$ Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
NP.undefined) (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$
            Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs (PrimInfo -> Term
Prim PrimInfo
p) TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
p) ([Either Term Type]
forall {a}. [Either a Type]
tyArgs [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++ [Either Term Type]
forall {b}. [Either Term b]
tmArgs)
    else
      let (Machine
m1,Id
i) = TyConMap -> Machine -> Term -> (Machine, Id)
newLetBinding TyConMap
tcm Machine
m0 Term
e
      in  PrimStep
ghcPrimStep TyConMap
tcm (Machine -> Bool
forcePrims Machine
m0) PrimInfo
p [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v,Term -> Value
Suspend (Id -> Term
Var Id
i)]) Machine
m1

ghcPrimUnwind TyConMap
tcm PrimInfo
p [Type]
tys [Value]
vs (Value -> (Value, [TickInfo])
collectValueTicks -> (Value
v, [TickInfo]
ts)) (Term
e:[Term]
es) Machine
m
  | Value -> Bool
isUndefinedPrimVal Value
v
  = let tyArgs :: [Either a Type]
tyArgs = (Type -> Either a Type) -> [Type] -> [Either a Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either a Type
forall a b. b -> Either a b
Right [Type]
tys
        tmArgs :: [Either Term b]
tmArgs = (Value -> Either Term b) -> [Value] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b)
-> (Value -> Term) -> Value -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valToTerm) ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
v]) [Either Term b] -> [Either Term b] -> [Either Term b]
forall a. [a] -> [a] -> [a]
++ (Term -> Either Term b) -> [Term] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Either Term b
forall a b. a -> Either a b
Left (Term
eTerm -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
es)
    in  Machine -> Maybe Machine
forall a. a -> Maybe a
Just (Machine -> Maybe Machine) -> Machine -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ (Term -> Machine -> Machine) -> Machine -> Term -> Machine
forall a b c. (a -> b -> c) -> b -> a -> c
flip Term -> Machine -> Machine
setTerm Machine
m (Term -> Machine) -> Term -> Machine
forall a b. (a -> b) -> a -> b
$ Term -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
NP.undefined) (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$
          Term -> TyConMap -> Type -> [Either Term Type] -> Type
applyTypeToArgs (PrimInfo -> Term
Prim PrimInfo
p) TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
p) ([Either Term Type]
forall {a}. [Either a Type]
tyArgs [Either Term Type] -> [Either Term Type] -> [Either Term Type]
forall a. [a] -> [a] -> [a]
++ [Either Term Type]
forall {b}. [Either Term b]
tmArgs)
  | Bool
otherwise
  = Machine -> Maybe Machine
forall a. a -> Maybe a
Just (Machine -> Maybe Machine)
-> (Machine -> Machine) -> Machine -> Maybe Machine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Machine -> Machine
setTerm Term
e (Machine -> Maybe Machine) -> Machine -> Maybe Machine
forall a b. (a -> b) -> a -> b
$ StackFrame -> Machine -> Machine
stackPush (PrimInfo -> [Type] -> [Value] -> [Term] -> StackFrame
PrimApply PrimInfo
p [Type]
tys ([Value]
vs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [(TickInfo -> Value -> Value) -> Value -> [TickInfo] -> Value
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TickInfo -> Value -> Value
TickValue Value
v [TickInfo]
ts]) [Term]
es) Machine
m

ghcPrimStep :: PrimStep
ghcPrimStep :: PrimStep
ghcPrimStep TyConMap
tcm Bool
isSubj PrimInfo
pInfo [Type]
tys [Value]
args Machine
mach =
  case Text -> HashMap Text PrimStep -> Maybe PrimStep
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup (PrimInfo -> Text
primName PrimInfo
pInfo) HashMap Text PrimStep
ghcPrimStepImpls of
    Just PrimStep
impl -> PrimStep
impl TyConMap
tcm Bool
isSubj PrimInfo
pInfo [Type]
tys [Value]
args Machine
mach
    Maybe PrimStep
Nothing -> Maybe Machine
forall a. Maybe a
Nothing