{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Args
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
--  Code generation of application arguments
-----------------------------------------------------------------------------

module GHC.StgToJS.Arg
  ( genArg
  , genIdArg
  , genIdArgI
  , genIdStackArgI
  , allocConStatic
  , allocUnboxedConStatic
  , allocateStaticList
  , jsStaticArg
  , jsStaticArgs
  )
where

import GHC.Prelude

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

import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Literal
import GHC.StgToJS.Utils
import GHC.StgToJS.Profiling
import GHC.StgToJS.Ids

import GHC.Builtin.Types
import GHC.Stg.Syntax
import GHC.Core.DataCon

import GHC.Types.CostCentre
import GHC.Types.Unique.FM
import GHC.Types.Id

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified Control.Monad.Trans.State.Strict as State

{-
Note [ Unboxable Literals Optimization ]
~~~~~~~~~~~~~~~~~~

Boxable types in the JS backend are represented as heap objects. See Note
[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8
do not benefit from not being wrapped in an object in the JS runtime. This optimization
detects such types and changes the code generator to generate a more efficient
representation. The change is minor and saves one level on indirection. Instead
of generating a wrapper object with a field for the value's payload, such as:

// a JS object for an Int8
var anInt8 = { d1 = <Int8# payload>
             , f  : entry function which would scrutinize the payload
             }

we instead generate:

// notice, no wrapper object. This representation is essentially an Int8# in the JS backend
var anInt8 = <Int8# payload>

This optimization fires when the follow invariants hold:
  1. The value in question has a Type which has a single data constructor
  2. The data constructor holds a single field that is monomorphic
  3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator.

From the haskell perspective this means that:
  1. An Int8# is always a JavaScript 'number', never a JavaScript object.
  2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on
     its use case and this optimization.

How is this sound?
~~~~~~~~~~~~~~~~~~

Normally this optimization would violate the guarantees of call-by-need, however
we are able to statically detect whether the type in question will be a THUNK or
not during code gen because the JS backend is consuming STG and we can check
during runtime with the typeof operator. Similarly we can check at runtime using
JavaScript's introspection operator `typeof`. Thus, when we know the value in
question will not be a THUNK we can safely elide the wrapping object, which
unboxes the value in the JS runtime. For example, an Int8 contains an Int8#
which has the JavaScript type 'number'. A THUNK of type Int8 would have a
JavaScript type 'object', so using 'typeof' allows us to check if we have
something that is definitely evaluated (i.e., a 'number') or something else. If
it is an 'object' then we may need to enter it to begin its evaluation. Consider
a type which has a 'ThreadId#' field; such as type would not be subject to this
optimization because it has to be represented as a JavaScript 'object' and thus
cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is
similarly not unboxable in this way because Int64# does not fit in one
JavaScript variable and thus requires an 'object' for its representation in the
JavaScript runtime.

-}

-- | Generate JS code for static arguments
genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg StgArg
a = case StgArg
a of
  StgLitArg Literal
l -> (StaticLit -> StaticArg) -> [StaticLit] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg ([StaticLit] -> [StaticArg])
-> StateT GenState IO [StaticLit] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> StateT GenState IO [StaticLit]
genStaticLit Literal
l
  StgVarArg Id
i -> do
    UniqFM Id CgStgExpr
unFloat <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
    case UniqFM Id CgStgExpr -> Id -> Maybe CgStgExpr
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Id CgStgExpr
unFloat Id
i of
      Maybe CgStgExpr
Nothing -> G [StaticArg]
reg
      Just CgStgExpr
expr -> CgStgExpr -> G [StaticArg]
unfloated CgStgExpr
expr
     where
       r :: VarType
r = HasDebugCallStack => UnaryType -> VarType
UnaryType -> VarType
uTypeVt (UnaryType -> VarType)
-> (StgArg -> UnaryType) -> StgArg -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> UnaryType
stgArgType (StgArg -> VarType) -> StgArg -> VarType
forall a b. (a -> b) -> a -> b
$ StgArg
a
       reg :: G [StaticArg]
reg
         | VarType -> Bool
isVoid VarType
r            =
             [StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
         | Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
trueDataConId  =
             [StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
True)]
         | Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
falseDataConId =
             [StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
False)]
         | VarType -> Bool
isMultiVar VarType
r        =
             (Ident -> StaticArg) -> [Ident] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxtI FastString
t) -> FastString -> StaticArg
StaticObjArg FastString
t) ([Ident] -> [StaticArg])
-> StateT GenState IO [Ident] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConTag -> StateT GenState IO Ident)
-> [ConTag] -> StateT GenState IO [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> ConTag -> StateT GenState IO Ident
identForIdN Id
i) [ConTag
1..VarType -> ConTag
varSize VarType
r] -- this seems wrong, not an obj?
         | Bool
otherwise           = (\(TxtI FastString
it) -> [FastString -> StaticArg
StaticObjArg FastString
it]) (Ident -> [StaticArg]) -> StateT GenState IO Ident -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i

       unfloated :: CgStgExpr -> G [StaticArg]
       unfloated :: CgStgExpr -> G [StaticArg]
unfloated (StgLit Literal
l) = (StaticLit -> StaticArg) -> [StaticLit] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg ([StaticLit] -> [StaticArg])
-> StateT GenState IO [StaticLit] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> StateT GenState IO [StaticLit]
genStaticLit Literal
l
       unfloated (StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [UnaryType]
_)
         | DataCon -> Bool
isBoolDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
dc =
             (StaticArg -> [StaticArg] -> [StaticArg]
forall a. a -> [a] -> [a]
:[]) (StaticArg -> [StaticArg])
-> ([[StaticArg]] -> StaticArg) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic DataCon
dc ([StaticArg] -> StaticArg)
-> ([[StaticArg]] -> [StaticArg]) -> [[StaticArg]] -> StaticArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args -- fixme what is allocunboxedcon?
         | [StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args = (\(TxtI FastString
t) -> [FastString -> StaticArg
StaticObjArg FastString
t]) (Ident -> [StaticArg]) -> StateT GenState IO Ident -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId (DataCon -> Id
dataConWorkId DataCon
dc)
         | Bool
otherwise = do
             [StaticArg]
as       <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
             (TxtI FastString
e) <- DataCon -> StateT GenState IO Ident
identForDataConWorker DataCon
dc
             [StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FastString -> [StaticArg] -> StaticArg
StaticConArg FastString
e [StaticArg]
as]
       unfloated CgStgExpr
x = String -> SDoc -> G [StaticArg]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (StgPprOpts -> CgStgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
x)

-- | Generate JS code for an StgArg
genArg :: HasDebugCallStack => StgArg -> G [JExpr]
genArg :: HasDebugCallStack => StgArg -> G [JExpr]
genArg StgArg
a = case StgArg
a of
  StgLitArg Literal
l -> HasDebugCallStack => Literal -> G [JExpr]
Literal -> G [JExpr]
genLit Literal
l
  StgVarArg Id
i -> do
    UniqFM Id CgStgExpr
unFloat <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
    case UniqFM Id CgStgExpr -> Id -> Maybe CgStgExpr
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Id CgStgExpr
unFloat Id
i of
      Just CgStgExpr
expr -> HasDebugCallStack => CgStgExpr -> G [JExpr]
CgStgExpr -> G [JExpr]
unfloated CgStgExpr
expr
      Maybe CgStgExpr
Nothing
       | VarType -> Bool
isVoid VarType
HasDebugCallStack => VarType
r            -> [JExpr] -> G [JExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
       | Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
trueDataConId  -> [JExpr] -> G [JExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [JExpr
true_]
       | Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
falseDataConId -> [JExpr] -> G [JExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [JExpr
false_]
       | VarType -> Bool
isMultiVar VarType
HasDebugCallStack => VarType
r        -> (ConTag -> StateT GenState IO JExpr) -> [ConTag] -> G [JExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> ConTag -> StateT GenState IO JExpr
varForIdN Id
i) [ConTag
1..VarType -> ConTag
varSize VarType
HasDebugCallStack => VarType
r]
       | Bool
otherwise           -> (JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[]) (JExpr -> [JExpr]) -> StateT GenState IO JExpr -> G [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JExpr
varForId Id
i

   where
     -- if our argument is a joinid, it can be an unboxed tuple
     r :: HasDebugCallStack => VarType
     r :: HasDebugCallStack => VarType
r = HasDebugCallStack => UnaryType -> VarType
UnaryType -> VarType
uTypeVt (UnaryType -> VarType)
-> (StgArg -> UnaryType) -> StgArg -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> UnaryType
stgArgType (StgArg -> VarType) -> StgArg -> VarType
forall a b. (a -> b) -> a -> b
$ StgArg
a

     unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
     unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
unfloated = \case
      StgLit Literal
l -> HasDebugCallStack => Literal -> G [JExpr]
Literal -> G [JExpr]
genLit Literal
l
      StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [UnaryType]
_
       | DataCon -> Bool
isBoolDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
dc
       -> (JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[]) (JExpr -> [JExpr]) -> ([[JExpr]] -> JExpr) -> [[JExpr]] -> [JExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [JExpr] -> JExpr
allocUnboxedCon DataCon
dc ([JExpr] -> JExpr) -> ([[JExpr]] -> [JExpr]) -> [[JExpr]] -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JExpr]] -> [JExpr]) -> StateT GenState IO [[JExpr]] -> G [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [JExpr]) -> [StgArg] -> StateT GenState IO [[JExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
args
       | [StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args -> (JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[]) (JExpr -> [JExpr]) -> StateT GenState IO JExpr -> G [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JExpr
varForId (DataCon -> Id
dataConWorkId DataCon
dc)
       | Bool
otherwise -> do
           [JExpr]
as <- [[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JExpr]] -> [JExpr]) -> StateT GenState IO [[JExpr]] -> G [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [JExpr]) -> [StgArg] -> StateT GenState IO [[JExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
args
           JExpr
e  <- DataCon -> StateT GenState IO JExpr
varForDataConWorker DataCon
dc
           Bool
inl_alloc <- StgToJSConfig -> Bool
csInlineAlloc (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
           [JExpr] -> G [JExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE Bool
inl_alloc JExpr
e [JExpr]
as Maybe JExpr
forall a. Maybe a
Nothing]
      CgStgExpr
x -> String -> SDoc -> G [JExpr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (StgPprOpts -> CgStgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
x)

-- | Generate a Var as JExpr
genIdArg :: HasDebugCallStack => Id -> G [JExpr]
genIdArg :: HasDebugCallStack => Id -> G [JExpr]
genIdArg Id
i = HasDebugCallStack => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg (Id -> StgArg
StgVarArg Id
i)

-- | Generate an Id as an Ident
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI :: HasDebugCallStack => Id -> StateT GenState IO [Ident]
genIdArgI Id
i
  | VarType -> Bool
isVoid VarType
r     = [Ident] -> StateT GenState IO [Ident]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | VarType -> Bool
isMultiVar VarType
r = (ConTag -> StateT GenState IO Ident)
-> [ConTag] -> StateT GenState IO [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> ConTag -> StateT GenState IO Ident
identForIdN Id
i) [ConTag
1..VarType -> ConTag
varSize VarType
r]
  | Bool
otherwise    = (Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[]) (Ident -> [Ident])
-> StateT GenState IO Ident -> StateT GenState IO [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
  where
    r :: VarType
r = HasDebugCallStack => UnaryType -> VarType
UnaryType -> VarType
uTypeVt (UnaryType -> VarType) -> (Id -> UnaryType) -> Id -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> UnaryType
idType (Id -> VarType) -> Id -> VarType
forall a b. (a -> b) -> a -> b
$ Id
i

-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident, StackSlot)]
genIdStackArgI Id
i = (ConTag -> Ident -> (Ident, StackSlot))
-> [ConTag] -> [Ident] -> [(Ident, StackSlot)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ConTag -> Ident -> (Ident, StackSlot)
f [ConTag
1..] ([Ident] -> [(Ident, StackSlot)])
-> StateT GenState IO [Ident] -> G [(Ident, StackSlot)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> StateT GenState IO [Ident]
Id -> StateT GenState IO [Ident]
genIdArgI Id
i
  where
    f :: Int -> Ident -> (Ident,StackSlot)
    f :: ConTag -> Ident -> (Ident, StackSlot)
f ConTag
n Ident
ident = (Ident
ident, Id -> ConTag -> StackSlot
SlotId Id
i ConTag
n)

-- | Allocate Static Constructors
allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic :: HasDebugCallStack =>
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic (TxtI FastString
to) CostCentreStack
cc DataCon
con [StgArg]
args = do
  [[StaticArg]]
as <- (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
  Maybe Ident
cc' <- CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
cc
  Maybe Ident -> [StaticArg] -> G ()
HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
allocConStatic' Maybe Ident
cc' ([[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[StaticArg]]
as)
  where
    -- see Note [ Unboxable Literals Optimization ] for the purpose of these
    -- checks
    allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
    allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
allocConStatic' Maybe Ident
cc' []
      | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
1 =
           FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
False) Maybe Ident
cc'
      | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
2 =
           FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
True) Maybe Ident
cc'
      | Bool
otherwise = do
           (TxtI FastString
e) <- DataCon -> StateT GenState IO Ident
identForDataConWorker DataCon
con
           FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (FastString -> [StaticArg] -> StaticVal
StaticData FastString
e []) Maybe Ident
cc'
    allocConStatic' Maybe Ident
cc' [StaticArg
x]
      | DataCon -> Bool
isUnboxableCon DataCon
con =
        case StaticArg
x of
          StaticLitArg (IntLit Integer
i)    ->
            FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Integer -> StaticUnboxed
StaticUnboxedInt Integer
i) Maybe Ident
cc'
          StaticLitArg (BoolLit Bool
b)   ->
            FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
b) Maybe Ident
cc'
          StaticLitArg (DoubleLit SaneDouble
d) ->
            FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ SaneDouble -> StaticUnboxed
StaticUnboxedDouble SaneDouble
d) Maybe Ident
cc'
          StaticArg
_                          ->
            String -> SDoc -> G ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocConStatic: invalid unboxed literal" (StaticArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StaticArg
x)
    allocConStatic' Maybe Ident
cc' [StaticArg]
xs =
           if DataCon
con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
              then case [StgArg]
args of
                (StgArg
a0:StgArg
a1:[StgArg]
_) -> (StaticVal -> Maybe Ident -> G ())
-> Maybe Ident -> StaticVal -> G ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to) Maybe Ident
cc' (StaticVal -> G ()) -> StateT GenState IO StaticVal -> G ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList [StgArg
a0] StgArg
a1
                [StgArg]
_         -> String -> G ()
forall a. HasCallStack => String -> a
panic String
"allocConStatic: invalid args for consDataCon"
              else do
                (TxtI FastString
e) <- DataCon -> StateT GenState IO Ident
identForDataConWorker DataCon
con
                FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (FastString -> [StaticArg] -> StaticVal
StaticData FastString
e [StaticArg]
xs) Maybe Ident
cc'

-- | Allocate unboxed constructors
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic DataCon
con = \case
  []
    | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
1
    -> StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
False)
    | DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
2
    -> StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
True)
  [a :: StaticArg
a@(StaticLitArg (IntLit Integer
_i))]    -> StaticArg
a
  [a :: StaticArg
a@(StaticLitArg (DoubleLit SaneDouble
_d))] -> StaticArg
a
  [StaticArg]
_ -> String -> SDoc -> StaticArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocUnboxedConStatic: not an unboxed constructor" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)


-- | Allocate Static list
allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList :: [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList [StgArg]
xs a :: StgArg
a@(StgVarArg Id
i)
  | Id -> Maybe DataCon
isDataConId_maybe Id
i Maybe DataCon -> Maybe DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
nilDataCon = [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs Maybe StgArg
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      UniqFM Id CgStgExpr
unFloat <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
      case UniqFM Id CgStgExpr -> Id -> Maybe CgStgExpr
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Id CgStgExpr
unFloat Id
i of
        Just (StgConApp DataCon
dc ConstructorNumber
_n [StgArg
h,StgArg
t] [UnaryType]
_)
          | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon -> [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList (StgArg
hStgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
:[StgArg]
xs) StgArg
t
        Maybe CgStgExpr
_ -> [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs (StgArg -> Maybe StgArg
forall a. a -> Maybe a
Just StgArg
a)
  where
    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
    listAlloc :: [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs Maybe StgArg
Nothing  = do
      [StaticArg]
as <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> ([[StaticArg]] -> [[StaticArg]]) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [[StaticArg]]
forall a. [a] -> [a]
reverse ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
      StaticVal -> StateT GenState IO StaticVal
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StaticArg] -> Maybe FastString -> StaticVal
StaticList [StaticArg]
as Maybe FastString
forall a. Maybe a
Nothing)
    listAlloc [StgArg]
xs (Just StgArg
r) = do
      [StaticArg]
as <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> ([[StaticArg]] -> [[StaticArg]]) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [[StaticArg]]
forall a. [a] -> [a]
reverse ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
      [StaticArg]
r' <- HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg StgArg
r
      case [StaticArg]
r' of
        [StaticObjArg FastString
ri] -> StaticVal -> StateT GenState IO StaticVal
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StaticArg] -> Maybe FastString -> StaticVal
StaticList [StaticArg]
as (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
ri))
        [StaticArg]
_                 ->
          String -> SDoc -> StateT GenState IO StaticVal
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocateStaticList: invalid argument (tail)" (([StgArg], StgArg) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([StgArg]
xs, StgArg
r))
allocateStaticList [StgArg]
_ StgArg
_ = String -> StateT GenState IO StaticVal
forall a. HasCallStack => String -> a
panic String
"allocateStaticList: unexpected literal in list"

-- | Generate JS code corresponding to a static arg
jsStaticArg :: StaticArg -> JExpr
jsStaticArg :: StaticArg -> JExpr
jsStaticArg = \case
  StaticLitArg StaticLit
l      -> StaticLit -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StaticLit
l
  StaticObjArg FastString
t      -> JVal -> JExpr
ValExpr (Ident -> JVal
JVar (FastString -> Ident
TxtI FastString
t))
  StaticConArg FastString
c [StaticArg]
args ->
    Bool -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE Bool
False (JVal -> JExpr
ValExpr (JVal -> JExpr) -> (FastString -> JVal) -> FastString -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar (Ident -> JVal) -> (FastString -> Ident) -> FastString -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI (FastString -> JExpr) -> FastString -> JExpr
forall a b. (a -> b) -> a -> b
$ FastString
c) ((StaticArg -> JExpr) -> [StaticArg] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JExpr
jsStaticArg [StaticArg]
args) Maybe JExpr
forall a. Maybe a
Nothing

-- | Generate JS code corresponding to a list of static args
jsStaticArgs :: [StaticArg] -> JExpr
jsStaticArgs :: [StaticArg] -> JExpr
jsStaticArgs = JVal -> JExpr
ValExpr (JVal -> JExpr) -> ([StaticArg] -> JVal) -> [StaticArg] -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JExpr] -> JVal
JList ([JExpr] -> JVal)
-> ([StaticArg] -> [JExpr]) -> [StaticArg] -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StaticArg -> JExpr) -> [StaticArg] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JExpr
jsStaticArg