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

module GHC.StgToJS.Closure
  ( closureInfoStat
  , closure
  , conClosure
  , Closure (..)
  , newClosure
  , assignClosure
  , CopyCC (..)
  , copyClosure
  , mkClosure
  -- $names
  , allocData
  , allocClsA
  , dataName
  , clsName
  , dataFieldName
  , varName
  , jsClosureCount
  )
where

import GHC.Prelude
import GHC.Data.FastString

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

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

import GHC.Types.Unique.Map

import Data.Array
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 = (Ident -> JStat -> JStat
forall a. ToSat a => Ident -> a -> JStat
jFun (ClosureInfo -> Ident
ciVar ClosureInfo
ci) 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

mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure
mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure
mkClosure JExpr
entry [JExpr]
fields JExpr
meta Maybe JExpr
cc = Closure
  { clEntry :: JExpr
clEntry  = JExpr
entry
  , clField1 :: JExpr
clField1 = JExpr
x1
  , clField2 :: JExpr
clField2 = JExpr
x2
  , clMeta :: JExpr
clMeta   = JExpr
meta
  , clCC :: Maybe JExpr
clCC     = Maybe JExpr
cc
  }
  where
    x1 :: JExpr
x1 = case [JExpr]
fields of
           []  -> JExpr
null_
           JExpr
x:[JExpr]
_ -> JExpr
x
    x2 :: JExpr
x2 = case [JExpr]
fields of
           []     -> JExpr
null_
           [JExpr
_]    -> JExpr
null_
           [JExpr
_,JExpr
x]  -> JExpr
x
           JExpr
_:JExpr
x:[JExpr]
xs -> JVal -> JExpr
ValExpr (JVal -> JExpr)
-> ([(FastString, JExpr)] -> JVal)
-> [(FastString, JExpr)]
-> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap FastString JExpr -> JVal
JHash (UniqMap FastString JExpr -> JVal)
-> ([(FastString, JExpr)] -> UniqMap FastString JExpr)
-> [(FastString, JExpr)]
-> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, JExpr)] -> UniqMap FastString JExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(FastString, JExpr)] -> JExpr) -> [(FastString, JExpr)] -> JExpr
forall a b. (a -> b) -> a -> b
$ [FastString] -> [JExpr] -> [(FastString, JExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FastString
dataFieldName [Int
1..]) (JExpr
xJExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[JExpr]
xs)


-------------------------------------------------------------------------------
--                             Name Caches
-------------------------------------------------------------------------------
-- $names

-- | Cache "dXXX" field names
dataFieldCache :: Array Int FastString
dataFieldCache :: Array Int FastString
dataFieldCache = (Int, Int) -> [FastString] -> Array Int FastString
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
nFieldCache) ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'd'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
0::Int)..Int
nFieldCache])

-- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see.
nFieldCache :: Int
nFieldCache :: Int
nFieldCache  = Int
255

-- | We use this in the RTS to determine the number of generated closures. These closures use the names
-- cached here, so we bind them to the same number.
jsClosureCount :: Int
jsClosureCount :: Int
jsClosureCount  = Int
24

dataFieldName :: Int -> FastString
dataFieldName :: Int -> FastString
dataFieldName Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nFieldCache = [Char] -> FastString
mkFastString (Char
'd' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
  | Bool
otherwise                = Array Int FastString
dataFieldCache Array Int FastString -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Int
i

-- | Cache "h$dXXX" names
dataCache :: Array Int FastString
dataCache :: Array Int FastString
dataCache = (Int, Int) -> [FastString] -> Array Int FastString
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
jsClosureCount) ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$d"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
0::Int)..Int
jsClosureCount])

dataName :: Int -> FastString
dataName :: Int -> FastString
dataName Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nFieldCache = [Char] -> FastString
mkFastString ([Char]
"h$d" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
  | Bool
otherwise                = Array Int FastString
dataCache Array Int FastString -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Int
i

allocData :: Int -> JExpr
allocData :: Int -> JExpr
allocData Int
i = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> Ident
TxtI (Int -> FastString
dataName Int
i))

-- | Cache "h$cXXX" names
clsCache :: Array Int FastString
clsCache :: Array Int FastString
clsCache = (Int, Int) -> [FastString] -> Array Int FastString
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
jsClosureCount) ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$c"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
0::Int)..Int
jsClosureCount])

clsName :: Int -> FastString
clsName :: Int -> FastString
clsName Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
jsClosureCount = [Char] -> FastString
mkFastString ([Char]
"h$c" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
  | Bool
otherwise                   = Array Int FastString
clsCache Array Int FastString -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Int
i

allocClsA :: Int -> JExpr
allocClsA :: Int -> JExpr
allocClsA Int
i = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> Ident
TxtI (Int -> FastString
clsName Int
i))

-- | Cache "xXXX" names
varCache :: Array Int Ident
varCache :: Array Int Ident
varCache = (Int, Int) -> [Ident] -> Array Int Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
jsClosureCount) ((Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
0::Int)..Int
jsClosureCount])

varName :: Int -> Ident
varName :: Int -> Ident
varName Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
jsClosureCount = FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString (Char
'x' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
  | Bool
otherwise                   = Array Int Ident
varCache Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! Int
i