{-# 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.Syntax
import GHC.JS.Make

import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Literal
import GHC.StgToJS.CoreUtils
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 -> forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> G [StaticLit]
genStaticLit Literal
l
  StgVarArg Id
i -> do
    UniqFM Id CgStgExpr
unFloat <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
    case 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
uTypeVt forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> UnaryType
stgArgType forall a b. (a -> b) -> a -> b
$ StgArg
a
       reg :: G [StaticArg]
reg
         | VarType -> Bool
isVoid VarType
r            =
             forall (m :: * -> *) a. Monad m => a -> m a
return []
         | Id
i forall a. Eq a => a -> a -> Bool
== Id
trueDataConId  =
             forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
True)]
         | Id
i forall a. Eq a => a -> a -> Bool
== Id
falseDataConId =
             forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
False)]
         | VarType -> Bool
isMultiVar VarType
r        =
             forall a b. (a -> b) -> [a] -> [b]
map (\(TxtI FastString
t) -> FastString -> StaticArg
StaticObjArg FastString
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> ConTag -> G 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]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i

       unfloated :: CgStgExpr -> G [StaticArg]
       unfloated :: CgStgExpr -> G [StaticArg]
unfloated (StgLit Literal
l) = forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> G [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 =
             (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic DataCon
dc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg [StgArg]
args -- fixme what is allocunboxedcon?
         | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args = (\(TxtI FastString
t) -> [FastString -> StaticArg
StaticObjArg FastString
t]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId (DataCon -> Id
dataConWorkId DataCon
dc)
         | Bool
otherwise = do
             [StaticArg]
as       <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
             (TxtI FastString
e) <- DataCon -> G Ident
identForDataConWorker DataCon
dc
             forall (m :: * -> *) a. Monad m => a -> m a
return [FastString -> [StaticArg] -> StaticArg
StaticConArg FastString
e [StaticArg]
as]
       unfloated CgStgExpr
x = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (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]
genLit Literal
l
  StgVarArg Id
i -> do
    UniqFM Id CgStgExpr
unFloat <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
    case 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]
unfloated CgStgExpr
expr
      Maybe CgStgExpr
Nothing
       | VarType -> Bool
isVoid HasDebugCallStack => VarType
r            -> forall (m :: * -> *) a. Monad m => a -> m a
return []
       | Id
i forall a. Eq a => a -> a -> Bool
== Id
trueDataConId  -> forall (m :: * -> *) a. Monad m => a -> m a
return [JExpr
true_]
       | Id
i forall a. Eq a => a -> a -> Bool
== Id
falseDataConId -> forall (m :: * -> *) a. Monad m => a -> m a
return [JExpr
false_]
       | VarType -> Bool
isMultiVar HasDebugCallStack => VarType
r        -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> ConTag -> G JExpr
varForIdN Id
i) [ConTag
1..VarType -> ConTag
varSize HasDebugCallStack => VarType
r]
       | Bool
otherwise           -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G 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
uTypeVt forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> UnaryType
stgArgType 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]
genLit Literal
l
      StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [UnaryType]
_
       | DataCon -> Bool
isBoolDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
dc
       -> (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [JExpr] -> JExpr
allocUnboxedCon DataCon
dc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
       | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JExpr
varForId (DataCon -> Id
dataConWorkId DataCon
dc)
       | Bool
otherwise -> do
           [JExpr]
as <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
           JExpr
e  <- DataCon -> G JExpr
varForDataConWorker DataCon
dc
           Bool
inl_alloc <- StgToJSConfig -> Bool
csInlineAlloc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
           forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr
allocDynamicE Bool
inl_alloc JExpr
e [JExpr]
as forall a. Maybe a
Nothing]
      CgStgExpr
x -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (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]
genArg (Id -> StgArg
StgVarArg Id
i)

-- | Generate an Id as an Ident
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI Id
i
  | VarType -> Bool
isVoid VarType
r     = forall (m :: * -> *) a. Monad m => a -> m a
return []
  | VarType -> Bool
isMultiVar VarType
r = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> ConTag -> G Ident
identForIdN Id
i) [ConTag
1..VarType -> ConTag
varSize VarType
r]
  | Bool
otherwise    = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
  where
    r :: VarType
r = HasDebugCallStack => UnaryType -> VarType
uTypeVt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> UnaryType
idType 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ConTag -> Ident -> (Ident, StackSlot)
f [ConTag
1..] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> G [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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
  Maybe Ident
cc' <- CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
cc
  HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
allocConStatic' Maybe Ident
cc' (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 forall a. Eq a => a -> a -> Bool
== ConTag
1 =
           FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed 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 forall a. Eq a => a -> a -> Bool
== ConTag
2 =
           FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
True) Maybe Ident
cc'
      | Bool
otherwise = do
           (TxtI FastString
e) <- DataCon -> G 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 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 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 forall a b. (a -> b) -> a -> b
$ SaneDouble -> StaticUnboxed
StaticUnboxedDouble SaneDouble
d) Maybe Ident
cc'
          StaticArg
_                          ->
            forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocConStatic: invalid unboxed literal" (forall a. Outputable a => a -> SDoc
ppr StaticArg
x)
    allocConStatic' Maybe Ident
cc' [StaticArg]
xs =
           if DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
              then case [StgArg]
args of
                (StgArg
a0:StgArg
a1:[StgArg]
_) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to) Maybe Ident
cc' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [StgArg] -> StgArg -> G StaticVal
allocateStaticList [StgArg
a0] StgArg
a1
                [StgArg]
_         -> forall a. HasCallStack => String -> a
panic String
"allocConStatic: invalid args for consDataCon"
              else do
                (TxtI FastString
e) <- DataCon -> G 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 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 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]
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocUnboxedConStatic: not an unboxed constructor" (forall a. Outputable a => a -> SDoc
ppr DataCon
con)


-- | Allocate Static list
allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList [StgArg]
xs a :: StgArg
a@(StgVarArg Id
i)
  | Id -> Maybe DataCon
isDataConId_maybe Id
i forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just DataCon
nilDataCon = [StgArg] -> Maybe StgArg -> G StaticVal
listAlloc [StgArg]
xs forall a. Maybe a
Nothing
  | Bool
otherwise = do
      UniqFM Id CgStgExpr
unFloat <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
      case 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 forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon -> [StgArg] -> StgArg -> G StaticVal
allocateStaticList (StgArg
hforall a. a -> [a] -> [a]
:[StgArg]
xs) StgArg
t
        Maybe CgStgExpr
_ -> [StgArg] -> Maybe StgArg -> G StaticVal
listAlloc [StgArg]
xs (forall a. a -> Maybe a
Just StgArg
a)
  where
    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
listAlloc [StgArg]
xs Maybe StgArg
Nothing  = do
      [StaticArg]
as <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
      forall (m :: * -> *) a. Monad m => a -> m a
return ([StaticArg] -> Maybe FastString -> StaticVal
StaticList [StaticArg]
as forall a. Maybe a
Nothing)
    listAlloc [StgArg]
xs (Just StgArg
r) = do
      [StaticArg]
as <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
      [StaticArg]
r' <- HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg StgArg
r
      case [StaticArg]
r' of
        [StaticObjArg FastString
ri] -> forall (m :: * -> *) a. Monad m => a -> m a
return ([StaticArg] -> Maybe FastString -> StaticVal
StaticList [StaticArg]
as (forall a. a -> Maybe a
Just FastString
ri))
        [StaticArg]
_                 ->
          forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocateStaticList: invalid argument (tail)" (forall a. Outputable a => a -> SDoc
ppr ([StgArg]
xs, StgArg
r))
allocateStaticList [StgArg]
_ StgArg
_ = 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      -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI forall a b. (a -> b) -> a -> b
$ FastString
c) (forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JExpr
jsStaticArg [StaticArg]
args) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JExpr] -> JVal
JList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JExpr
jsStaticArg