{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module GHC.StgToJS.Closure
  ( closureInfoStat
  , closure
  , conClosure
  , Closure (..)
  , newClosure
  , assignClosure
  , CopyCC (..)
  , copyClosure
  )
where

import GHC.Prelude
import GHC.Data.FastString

import GHC.StgToJS.Heap
import GHC.StgToJS.Types
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Regs (stack,sp)

import GHC.JS.Make
import GHC.JS.Syntax

import Data.Monoid
import qualified Data.Bits as Bits

closureInfoStat :: Bool -> ClosureInfo -> JStat
closureInfoStat :: Bool -> ClosureInfo -> JStat
closureInfoStat Bool
debug (ClosureInfo Ident
obj CIRegs
rs FastString
name CILayout
layout CIType
ctype CIStatic
srefs)
  = Bool
-> Ident
-> CIRegs
-> CILayout
-> ClosureType
-> FastString
-> Int
-> CIStatic
-> JStat
setObjInfoL Bool
debug Ident
obj CIRegs
rs CILayout
layout ClosureType
ty FastString
name Int
tag CIStatic
srefs
      where
        !ty :: ClosureType
ty = case CIType
ctype of
          CIType
CIThunk      -> ClosureType
Thunk
          CIFun {}     -> ClosureType
Fun
          CICon {}     -> ClosureType
Con
          CIType
CIBlackhole  -> ClosureType
Blackhole
          CIType
CIPap        -> ClosureType
Pap
          CIType
CIStackFrame -> ClosureType
StackFrame
        !tag :: Int
tag = case CIType
ctype of
          CIType
CIThunk           -> Int
0
          CIFun Int
arity Int
nregs -> Int -> Int -> Int
mkArityTag Int
arity Int
nregs
          CICon Int
con         -> Int
con
          CIType
CIBlackhole       -> Int
0
          CIType
CIPap             -> Int
0
          CIType
CIStackFrame      -> Int
0


setObjInfoL :: Bool        -- ^ debug: output symbol names
            -> Ident       -- ^ the object name
            -> CIRegs      -- ^ things in registers
            -> CILayout    -- ^ layout of the object
            -> ClosureType -- ^ closure type
            -> FastString  -- ^ object name, for printing
            -> Int         -- ^ `a' argument, depends on type (arity, conid)
            -> CIStatic    -- ^ static refs
            -> JStat
setObjInfoL :: Bool
-> Ident
-> CIRegs
-> CILayout
-> ClosureType
-> FastString
-> Int
-> CIStatic
-> JStat
setObjInfoL Bool
debug Ident
obj CIRegs
rs CILayout
layout ClosureType
t FastString
n Int
a
  = Bool
-> Ident
-> ClosureType
-> FastString
-> [Int]
-> Int
-> Int
-> CIRegs
-> CIStatic
-> JStat
setObjInfo Bool
debug Ident
obj ClosureType
t FastString
n [Int]
field_types Int
a Int
size CIRegs
rs
      where
        size :: Int
size = case CILayout
layout of
          CILayout
CILayoutVariable   -> (-Int
1)
          CILayoutUnknown Int
sz -> Int
sz
          CILayoutFixed Int
sz [VarType]
_ -> Int
sz
        field_types :: [Int]
field_types = case CILayout
layout of
          CILayout
CILayoutVariable     -> []
          CILayoutUnknown Int
size -> [VarType] -> [Int]
toTypeList (Int -> VarType -> [VarType]
forall a. Int -> a -> [a]
replicate Int
size VarType
ObjV)
          CILayoutFixed Int
_ [VarType]
fs   -> [VarType] -> [Int]
toTypeList [VarType]
fs

setObjInfo :: Bool        -- ^ debug: output all symbol names
           -> Ident       -- ^ the thing to modify
           -> ClosureType -- ^ closure type
           -> FastString  -- ^ object name, for printing
           -> [Int]       -- ^ list of item types in the object, if known (free variables, datacon fields)
           -> Int         -- ^ extra 'a' parameter, for constructor tag or arity
           -> Int         -- ^ object size, -1 (number of vars) for unknown
           -> CIRegs      -- ^ things in registers
           -> CIStatic    -- ^ static refs
           -> JStat
setObjInfo :: Bool
-> Ident
-> ClosureType
-> FastString
-> [Int]
-> Int
-> Int
-> CIRegs
-> CIStatic
-> JStat
setObjInfo Bool
debug Ident
obj ClosureType
t FastString
name [Int]
fields Int
a Int
size CIRegs
regs CIStatic
static
   | Bool
debug     = FastString -> [JExpr] -> JStat
appS FastString
"h$setObjInfo" [ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
obj
                                     , ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
t
                                     , FastString -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr FastString
name
                                     , [Int] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Int]
fields
                                     , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
a
                                     , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
size
                                     , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (CIRegs -> Int
regTag CIRegs
regs)
                                     , CIStatic -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr CIStatic
static
                                     ]
   | Bool
otherwise = FastString -> [JExpr] -> JStat
appS FastString
"h$o" [ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
obj
                            , ClosureType -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ClosureType
t
                            , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
a
                            , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
size
                            , Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (CIRegs -> Int
regTag CIRegs
regs)
                            , CIStatic -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr CIStatic
static
                            ]
  where
    regTag :: CIRegs -> Int
regTag CIRegs
CIRegsUnknown       = -Int
1
    regTag (CIRegs Int
skip [VarType]
types) =
      let nregs :: Int
nregs = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (VarType -> Int) -> [VarType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize [VarType]
types
      in  Int
skip Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
nregs Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8)

closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
        -> JStat       -- ^ rhs
        -> JStat
closure :: ClosureInfo -> JStat -> JStat
closure ClosureInfo
ci JStat
body = (ClosureInfo -> Ident
ciVar ClosureInfo
ci Ident -> JExpr -> JStat
||= JStat -> JExpr
forall a. ToSat a => a -> JExpr
jLam JStat
body) JStat -> JStat -> JStat
forall a. Monoid a => a -> a -> a
`mappend` Bool -> ClosureInfo -> JStat
closureInfoStat Bool
False ClosureInfo
ci

conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
conClosure Ident
symbol FastString
name CILayout
layout Int
constr =
  ClosureInfo -> JStat -> JStat
closure (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
symbol (Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV]) FastString
name CILayout
layout (Int -> CIType
CICon Int
constr) CIStatic
forall a. Monoid a => a
mempty)
          (JExpr -> JStat
returnS (JExpr
stack JExpr -> JExpr -> JExpr
.! JExpr
sp))

-- | Used to pass arguments to newClosure with some safety
data Closure = Closure
  { Closure -> JExpr
clEntry  :: JExpr
  , Closure -> JExpr
clField1 :: JExpr
  , Closure -> JExpr
clField2 :: JExpr
  , Closure -> JExpr
clMeta   :: JExpr
  , Closure -> Maybe JExpr
clCC     :: Maybe JExpr
  }

newClosure :: Closure -> JExpr
newClosure :: Closure -> JExpr
newClosure Closure{Maybe JExpr
JExpr
clEntry :: Closure -> JExpr
clField1 :: Closure -> JExpr
clField2 :: Closure -> JExpr
clMeta :: Closure -> JExpr
clCC :: Closure -> Maybe JExpr
clEntry :: JExpr
clField1 :: JExpr
clField2 :: JExpr
clMeta :: JExpr
clCC :: Maybe JExpr
..} =
  let xs :: [(FastString, JExpr)]
xs = [ (FastString
closureEntry_ , JExpr
clEntry)
           , (FastString
closureField1_, JExpr
clField1)
           , (FastString
closureField2_, JExpr
clField2)
           , (FastString
closureMeta_  , JExpr
clMeta)
           ]
  in case Maybe JExpr
clCC of
    -- CC field is optional (probably to minimize code size as we could assign
    -- null_, but we get the same effect implicitly)
    Maybe JExpr
Nothing -> JVal -> JExpr
ValExpr ([(FastString, JExpr)] -> JVal
jhFromList [(FastString, JExpr)]
xs)
    Just JExpr
cc -> JVal -> JExpr
ValExpr ([(FastString, JExpr)] -> JVal
jhFromList ([(FastString, JExpr)] -> JVal) -> [(FastString, JExpr)] -> JVal
forall a b. (a -> b) -> a -> b
$ (FastString
closureCC_,JExpr
cc) (FastString, JExpr)
-> [(FastString, JExpr)] -> [(FastString, JExpr)]
forall a. a -> [a] -> [a]
: [(FastString, JExpr)]
xs)

assignClosure :: JExpr -> Closure -> JStat
assignClosure :: JExpr -> Closure -> JStat
assignClosure JExpr
t Closure{Maybe JExpr
JExpr
clEntry :: Closure -> JExpr
clField1 :: Closure -> JExpr
clField2 :: Closure -> JExpr
clMeta :: Closure -> JExpr
clCC :: Closure -> Maybe JExpr
clEntry :: JExpr
clField1 :: JExpr
clField2 :: JExpr
clMeta :: JExpr
clCC :: Maybe JExpr
..} = [JStat] -> JStat
BlockStat
  [ JExpr -> JExpr
closureEntry  JExpr
t JExpr -> JExpr -> JStat
|= JExpr
clEntry
  , JExpr -> JExpr
closureField1 JExpr
t JExpr -> JExpr -> JStat
|= JExpr
clField1
  , JExpr -> JExpr
closureField2 JExpr
t JExpr -> JExpr -> JStat
|= JExpr
clField2
  , JExpr -> JExpr
closureMeta   JExpr
t JExpr -> JExpr -> JStat
|= JExpr
clMeta
  ] JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> case Maybe JExpr
clCC of
      Maybe JExpr
Nothing -> JStat
forall a. Monoid a => a
mempty
      Just JExpr
cc -> JExpr -> JExpr
closureCC JExpr
t JExpr -> JExpr -> JStat
|= JExpr
cc

data CopyCC = CopyCC | DontCopyCC

copyClosure :: CopyCC -> JExpr -> JExpr -> JStat
copyClosure :: CopyCC -> JExpr -> JExpr -> JStat
copyClosure CopyCC
copy_cc JExpr
t JExpr
s = [JStat] -> JStat
BlockStat
  [ JExpr -> JExpr
closureEntry  JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureEntry  JExpr
s
  , JExpr -> JExpr
closureField1 JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField1 JExpr
s
  , JExpr -> JExpr
closureField2 JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureField2 JExpr
s
  , JExpr -> JExpr
closureMeta   JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureMeta   JExpr
s
  ] JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> case CopyCC
copy_cc of
      CopyCC
DontCopyCC -> JStat
forall a. Monoid a => a
mempty
      CopyCC
CopyCC     -> JExpr -> JExpr
closureCC JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> JExpr
closureCC JExpr
s