{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Expr
-- 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 Expressions
-----------------------------------------------------------------------------

module GHC.StgToJS.Expr
  ( genExpr
  , genEntryType
  , loadLiveFun
  , genStaticRefsRhs
  , genStaticRefs
  , genBody
  )
where

import GHC.Prelude

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

import GHC.StgToJS.Apply
import GHC.StgToJS.Arg
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.FFI
import GHC.StgToJS.Heap
import GHC.StgToJS.Monad
import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Literal
import GHC.StgToJS.Prim
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.StgUtils
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Utils
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids

import GHC.Types.Basic
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Unique.FM
import GHC.Types.RepType

import GHC.Stg.Syntax
import GHC.Stg.Utils

import GHC.Builtin.PrimOps

import GHC.Core
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.Arity (isOneShotBndr)
import GHC.Core.Type hiding (typeSize)

import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified GHC.Data.List.SetOps as ListSetOps

import Data.Monoid
import Data.Maybe
import Data.Function
import Data.Either
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Map as M
import Control.Monad
import Control.Arrow ((&&&))

-- | Evaluate an expression in the given expression context (continuation)
genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
stg = case CgStgExpr
stg of
  StgApp Id
f [StgArg]
args -> HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStat, ExprResult)
genApp ExprCtx
ctx Id
f [StgArg]
args
  StgLit Literal
l      -> do
    [JExpr]
ls <- HasDebugCallStack => Literal -> G [JExpr]
genLit Literal
l
    let r :: JStat
r = HasDebugCallStack => ExprCtx -> [JExpr] -> JStat
assignToExprCtx ExprCtx
ctx [JExpr]
ls
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat
r,Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
  StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [Type]
_ -> do
    [JExpr]
as <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
    JStat
c <- ExprCtx -> DataCon -> [JExpr] -> G JStat
genCon ExprCtx
ctx DataCon
con [JExpr]
as
    forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
c, Maybe [JExpr] -> ExprResult
ExprInline (forall a. a -> Maybe a
Just [JExpr]
as))
  StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
args Type
t
    -> HasDebugCallStack =>
ExprCtx
-> ForeignCall
-> Type
-> [JExpr]
-> [StgArg]
-> G (JStat, ExprResult)
genForeignCall ExprCtx
ctx ForeignCall
f Type
t (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
  StgOpApp (StgPrimOp PrimOp
op) [StgArg]
args Type
t
    -> ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t
  StgOpApp (StgPrimCallOp PrimCall
c) [StgArg]
args Type
t
    -> ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimCall ExprCtx
ctx PrimCall
c [StgArg]
args Type
t
  StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
at [GenStgAlt 'CodeGen]
alts
    -> HasDebugCallStack =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStat, ExprResult)
genCase ExprCtx
ctx BinderP 'CodeGen
b CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts (LiveVars -> LiveVars
liveVars forall a b. (a -> b) -> a -> b
$ Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
False CgStgExpr
stg)
  StgLet XLet 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
    (JStat
b',ExprCtx
ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
b
    (JStat
s,ExprResult
r)     <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
    forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
b' forall a. Semigroup a => a -> a -> a
<> JStat
s, ExprResult
r)
  StgLetNoEscape XLetNoEscape 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
    (JStat
b', ExprCtx
ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
b
    (JStat
s, ExprResult
r)     <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
    forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
b' forall a. Semigroup a => a -> a -> a
<> JStat
s, ExprResult
r)
  StgTick (ProfNote CostCentre
cc Bool
count Bool
scope) CgStgExpr
e -> do
    JStat
setSCCstats <- forall m. Monoid m => G m -> G m
ifProfilingM forall a b. (a -> b) -> a -> b
$ CostCentre -> Bool -> Bool -> G JStat
setCC CostCentre
cc Bool
count Bool
scope
    (JStat
stats, ExprResult
result) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e
    forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
setSCCstats forall a. Semigroup a => a -> a -> a
<> JStat
stats, ExprResult
result)
  StgTick (SourceNote RealSrcSpan
span String
_sname) CgStgExpr
e
    -> HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr (RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan RealSrcSpan
span ExprCtx
ctx) CgStgExpr
e
  StgTick GenTickish 'TickishPassStg
_m CgStgExpr
e
    -> HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e

-- | regular let binding: allocate heap object
genBind :: HasDebugCallStack
        => ExprCtx
        -> CgStgBinding
        -> G (JStat, ExprCtx)
genBind :: HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
bndr =
  case GenStgBinding 'CodeGen
bndr of
    StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
r -> do
       JStat
j <- Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign BinderP 'CodeGen
b GenStgRhs 'CodeGen
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         Just JStat
ja -> forall (m :: * -> *) a. Monad m => a -> m a
return JStat
ja
         Maybe JStat
Nothing -> Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls forall a. Maybe a
Nothing [(BinderP 'CodeGen
b,GenStgRhs 'CodeGen
r)]
       forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, forall {pass :: StgPass}.
ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
ctx [(BinderP 'CodeGen
b,GenStgRhs 'CodeGen
r)])
    StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs     -> do
       [Maybe JStat]
jas <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign) [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -- fixme these might depend on parts initialized by allocCls
       let m :: Maybe JStat
m = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe JStat]
jas then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe JStat]
jas)
       JStat
j <- Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls Maybe JStat
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe JStat]
jas [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
       forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, forall {pass :: StgPass}.
ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
ctx [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs)
   where
     ctx' :: ExprCtx
ctx' = ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx

     assign :: Id -> CgStgRhs -> G (Maybe JStat)
     assign :: Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ccs {-[the_fv]-} UpdateFlag
_upd [] CgStgExpr
expr)
       | let strip :: GenStgExpr p -> GenStgExpr p
strip = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: StgPass).
(GenTickish 'TickishPassStg -> Bool)
-> GenStgExpr p -> ([GenTickish 'TickishPassStg], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode)
       , StgCase (StgApp Id
scrutinee []) BinderP 'CodeGen
_ (AlgAlt TyCon
_) [GenStgAlt (DataAlt DataCon
_) [BinderP 'CodeGen]
params CgStgExpr
sel_expr] <- forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
expr
       , StgApp Id
selectee [] <- forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
sel_expr
       , let params_w_offsets :: [(Id, Int)]
params_w_offsets = forall a b. [a] -> [b] -> [(a, b)]
zip [BinderP 'CodeGen]
params (forall b a. (b -> a -> b) -> b -> [a] -> [b]
L.scanl' forall a. Num a => a -> a -> a
(+) Int
1 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Type -> Int
typeSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [BinderP 'CodeGen]
params)
       , let total_size :: Int
total_size = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Type -> Int
typeSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [BinderP 'CodeGen]
params)
       -- , the_fv == scrutinee -- fixme check
       , Just Int
the_offset <- forall a b. Eq a => Assoc a b -> a -> Maybe b
ListSetOps.assocMaybe [(Id, Int)]
params_w_offsets Id
selectee
       , Int
the_offset forall a. Ord a => a -> a -> Bool
<= Int
16 -- fixme make this some configurable constant
       = do
           let the_fv :: Id
the_fv = Id
scrutinee -- error "the_fv" -- fixme
           let sel_tag :: String
sel_tag | Int
the_offset forall a. Eq a => a -> a -> Bool
== Int
2 = if Int
total_size forall a. Eq a => a -> a -> Bool
== Int
2 then String
"2a"
                                                              else String
"2b"
                       | Bool
otherwise       = forall a. Show a => a -> String
show Int
the_offset
           [Ident]
tgts <- Id -> G [Ident]
identsForId Id
b
           [JExpr]
the_fvjs <- Id -> G [JExpr]
varsForId Id
the_fv
           case ([Ident]
tgts, [JExpr]
the_fvjs) of
             ([Ident
tgt], [JExpr
the_fvj]) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
               (Ident
tgt Ident -> JExpr -> JStat
||= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var (FastString
"h$c_sel_" forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString String
sel_tag)) [JExpr
the_fvj])
             ([Ident], [JExpr])
_ -> forall a. HasCallStack => String -> a
panic String
"genBind.assign: invalid size"
     assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
_ccs UpdateFlag
_upd [] CgStgExpr
expr)
       | forall a b. (a, b) -> b
snd (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx) CgStgExpr
expr) = do
           JStat
d   <- Id -> G JStat
declVarsForId Id
b
           [JExpr]
tgt <- Id -> G [JExpr]
varsForId Id
b
           let ctx' :: ExprCtx
ctx' = ExprCtx
ctx { ctxTarget :: [TypedExpr]
ctxTarget = Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
b [JExpr]
tgt }
           (JStat
j, ExprResult
_) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
expr
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (JStat
d forall a. Semigroup a => a -> a -> a
<> JStat
j))
     assign Id
_b StgRhsCon{} = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     assign  Id
b GenStgRhs 'CodeGen
r           = HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntry ExprCtx
ctx' Id
b GenStgRhs 'CodeGen
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

     addEvalRhs :: ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
c [] = ExprCtx
c
     addEvalRhs ExprCtx
c ((Id
b,GenStgRhs pass
r):[(Id, GenStgRhs pass)]
xs)
       | StgRhsCon{} <- GenStgRhs pass
r                       = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
b ExprCtx
c) [(Id, GenStgRhs pass)]
xs
       | (StgRhsClosure XRhsClosure pass
_ CostCentreStack
_ UpdateFlag
ReEntrant [BinderP pass]
_ GenStgExpr pass
_) <- GenStgRhs pass
r = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
b ExprCtx
c) [(Id, GenStgRhs pass)]
xs
       | Bool
otherwise                              = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
c [(Id, GenStgRhs pass)]
xs

genBindLne :: HasDebugCallStack
           => ExprCtx
           -> CgStgBinding
           -> G (JStat, ExprCtx)
genBindLne :: HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
bndr = do
  -- compute live variables and the offsets where they will be stored in the
  -- stack
  [(Id, Int)]
vis  <- forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
y,Bool
_) -> (Id
x,Int
y)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            HasDebugCallStack => Int -> [Id] -> G [(Id, Int, Bool)]
optimizeFree Int
oldFrameSize ([Id]
newLvsforall a. [a] -> [a] -> [a]
++forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
updBinds)
  -- initialize updatable bindings to null_
  JStat
declUpds <- forall a. Monoid a => [a] -> a
mconcat 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ident -> JExpr -> JStat
||= JExpr
null_) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> StateT GenState IO Ident
identForId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Id, GenStgRhs 'CodeGen)]
updBinds
  -- update expression context to include the updated LNE frame
  let ctx' :: ExprCtx
ctx' = [(Id, Int)] -> [Id] -> ExprCtx -> ExprCtx
ctxUpdateLneFrame [(Id, Int)]
vis [Id]
bound ExprCtx
ctx
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntryLne ExprCtx
ctx') [(Id, GenStgRhs 'CodeGen)]
binds
  forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
declUpds, ExprCtx
ctx')
  where
    oldFrameSize :: Int
oldFrameSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
    isOldLv :: Id -> Bool
isOldLv Id
i    = ExprCtx -> Id -> Bool
ctxIsLneBinding ExprCtx
ctx Id
i Bool -> Bool -> Bool
||
                   ExprCtx -> Id -> Bool
ctxIsLneLiveVar ExprCtx
ctx Id
i
    live :: LiveVars
live         = LiveVars -> LiveVars
liveVars forall a b. (a -> b) -> a -> b
$ [Id] -> LiveVars
mkDVarSet forall a b. (a -> b) -> a -> b
$ GenStgBinding 'CodeGen -> [Id]
stgLneLive' GenStgBinding 'CodeGen
bndr
    newLvs :: [Id]
newLvs       = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isOldLv) (LiveVars -> [Id]
dVarSetElems LiveVars
live)
    binds :: [(Id, GenStgRhs 'CodeGen)]
binds = case GenStgBinding 'CodeGen
bndr of
              StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
e -> [(BinderP 'CodeGen
b,GenStgRhs 'CodeGen
e)]
              StgRec    [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs  -> [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
    bound :: [Id]
bound = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
binds
    ([(Id, GenStgRhs 'CodeGen)]
updBinds, [(Id, GenStgRhs 'CodeGen)]
_nonUpdBinds) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (GenStgRhs 'CodeGen -> Bool
isUpdatableRhs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
binds

-- | Generate let-no-escape entry
--
-- Let-no-escape entries live on the stack. There is no heap object associated with them.
--
-- A let-no-escape entry is called like a normal stack frame, although as an optimization,
-- `Stack`[`Sp`] is not set when making the call. This is done later if the
-- thread needs to be suspended.
--
-- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot
-- is initially set to null, changed to h$blackhole when the thunk is being evaluated.
--
genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntryLne ExprCtx
ctx Id
i rhs :: GenStgRhs 'CodeGen
rhs@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
_cc UpdateFlag
update [BinderP 'CodeGen]
args CgStgExpr
body) =
  forall a. G a -> G a
resetSlots forall a b. (a -> b) -> a -> b
$ do
  let payloadSize :: Int
payloadSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
      vars :: [(Id, Int)]
vars        = ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx
      myOffset :: Int
myOffset    =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
panic String
"genEntryLne: updatable binder not found in let-no-escape frame")
              ((Int
payloadSizeforall a. Num a => a -> a -> a
-) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
              (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((forall a. Eq a => a -> a -> Bool
==Id
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Id, Int)]
vars))
      bh :: JStat
bh | UpdateFlag -> Bool
isUpdatable UpdateFlag
update =
             forall a. ToSat a => a -> JStat
jVar (\JExpr
x -> forall a. Monoid a => [a] -> a
mconcat
              [ JExpr
x JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$bh_lne") [JExpr -> JExpr -> JExpr
Sub JExpr
sp (forall a. ToJExpr a => a -> JExpr
toJExpr Int
myOffset), forall a. ToJExpr a => a -> JExpr
toJExpr (Int
payloadSizeforall a. Num a => a -> a -> a
+Int
1)]
              , JExpr -> JStat -> JStat -> JStat
IfStat JExpr
x (JExpr -> JStat
ReturnStat JExpr
x) forall a. Monoid a => a
mempty
              ])
         | Bool
otherwise = forall a. Monoid a => a
mempty
  JStat
lvs  <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
  JStat
body <- HasDebugCallStack =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
ctx Id
i StgReg
R1 [BinderP 'CodeGen]
args CgStgExpr
body
  ei :: Ident
ei@(TxtI FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  CIStatic
sr   <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
  let f :: JVal
f = [Ident] -> JStat -> JVal
JFunc [] (JStat
bh forall a. Semigroup a => a -> a -> a
<> JStat
lvs forall a. Semigroup a => a -> a -> a
<> JStat
body)
  ClosureInfo -> G ()
emitClosureInfo forall a b. (a -> b) -> a -> b
$
    Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
                (Int -> [VarType] -> CIRegs
CIRegs Int
0 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [VarType]
idVt [BinderP 'CodeGen]
args)
                (FastString
eii forall a. Semigroup a => a -> a -> a
<> FastString
", " forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr Id
i)))
                ([VarType] -> CILayout
fixedLayout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
                    forall a b. (a -> b) -> [a] -> [b]
map (Id -> VarType
stackSlotType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx))
                CIType
CIStackFrame
                CIStatic
sr
  JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr JVal
f)
genEntryLne ExprCtx
ctx Id
i (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
args) = forall a. G a -> G a
resetSlots forall a b. (a -> b) -> a -> b
$ do
  let payloadSize :: Int
payloadSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
  ei :: Ident
ei@(TxtI FastString
_eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  -- di <- varForDataConWorker con
  Ident
ii <- StateT GenState IO Ident
freshIdent
  JStat
p  <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
  [JExpr]
args' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
  JStat
ac    <- Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
ii DataCon
con CostCentreStack
cc [JExpr]
args'
  JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc []
    (forall a. Monoid a => [a] -> a
mconcat [Ident -> JStat
decl Ident
ii, JStat
p, JStat
ac, JExpr
r1 JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ii, JStat
returnStack])))

-- | Generate the entry function for a local closure
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntry :: HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntry ExprCtx
_ Id
_i StgRhsCon {} = forall (m :: * -> *) a. Monad m => a -> m a
return ()
genEntry ExprCtx
ctx Id
i rhs :: GenStgRhs 'CodeGen
rhs@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc {-_bi live-} UpdateFlag
upd_flag [BinderP 'CodeGen]
args CgStgExpr
body) = forall a. G a -> G a
resetSlots forall a b. (a -> b) -> a -> b
$ do
  let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
rhs -- error "fixme" -- probably find live vars in body
  JStat
ll    <- [Id] -> G JStat
loadLiveFun [Id]
live
  JStat
llv   <- HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps [Id]
live
  JStat
upd   <- UpdateFlag -> Id -> G JStat
genUpdFrame UpdateFlag
upd_flag Id
i
  JStat
body  <- HasDebugCallStack =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
entryCtx Id
i StgReg
R2 [BinderP 'CodeGen]
args CgStgExpr
body
  ei :: Ident
ei@(TxtI FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  CIType
et    <- HasDebugCallStack => [Id] -> G CIType
genEntryType [BinderP 'CodeGen]
args
  JStat
setcc <- forall m. Monoid m => m -> G m
ifProfiling forall a b. (a -> b) -> a -> b
$
             if CIType
et forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
               then JStat
enterCostCentreThunk
               else CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
cc
  CIStatic
sr <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
  ClosureInfo -> G ()
emitClosureInfo forall a b. (a -> b) -> a -> b
$ Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
                                (Int -> [VarType] -> CIRegs
CIRegs Int
0 forall a b. (a -> b) -> a -> b
$ VarType
PtrV forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [VarType]
idVt [BinderP 'CodeGen]
args)
                                (FastString
eii forall a. Semigroup a => a -> a -> a
<> FastString
", " forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr Id
i)))
                                ([VarType] -> CILayout
fixedLayout forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Type -> VarType
uTypeVt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
live)
                                CIType
et
                                CIStatic
sr
  JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] (forall a. Monoid a => [a] -> a
mconcat [JStat
ll, JStat
llv, JStat
upd, JStat
setcc, JStat
body])))
  where
    entryCtx :: ExprCtx
entryCtx = [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget [] (ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx)

-- | Generate the entry function types for identifiers. Note that this only
-- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is
-- filtered as not a RuntimeRepKinded type.
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType []   = forall (m :: * -> *) a. Monad m => a -> m a
return CIType
CIThunk
genEntryType [Id]
args0 = do
  [[JExpr]]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => Id -> G [JExpr]
genIdArg [Id]
args
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> CIType
CIFun (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
args')
  where
    args :: [Id]
args = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isRuntimeRepKindedTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
args0

-- | Generate the body of an object
genBody :: HasDebugCallStack
         => ExprCtx
         -> Id
         -> StgReg
         -> [Id]
         -> CgStgExpr
         -> G JStat
genBody :: HasDebugCallStack =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
ctx Id
i StgReg
startReg [Id]
args CgStgExpr
e = do
  -- load arguments into local variables
  JStat
la <- do
    [Ident]
args' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => Id -> G [Ident]
genIdArgI [Id]
args
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Ident] -> [JExpr] -> JStat
declAssignAll [Ident]
args' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
startReg..]))

  -- assert that arguments have valid runtime reps
  JStat
lav <- HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps [Id]
args

  -- compute PrimReps and their number of slots required to return the result of
  -- i applied to args.
  let res_vars :: [(PrimRep, Int)]
res_vars = HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
resultSize [Id]
args Id
i

  -- compute typed expressions for each slot and assign registers
  let go_var :: [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
regs = \case
        []              -> []
        ((PrimRep
rep,Int
size):[(PrimRep, Int)]
rs) ->
          let !([JExpr]
regs0,[JExpr]
regs1) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
size [JExpr]
regs
              !ts :: [TypedExpr]
ts = [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
regs1 [(PrimRep, Int)]
rs
          in PrimRep -> [JExpr] -> TypedExpr
TypedExpr PrimRep
rep [JExpr]
regs0 forall a. a -> [a] -> [a]
: [TypedExpr]
ts

  let tgt :: [TypedExpr]
tgt  = [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
jsRegsFromR1 [(PrimRep, Int)]
res_vars
  let !ctx' :: ExprCtx
ctx' = ExprCtx
ctx { ctxTarget :: [TypedExpr]
ctxTarget = [TypedExpr]
tgt }

  -- generate code for the expression
  (JStat
e, ExprResult
_r) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JStat
la forall a. Semigroup a => a -> a -> a
<> JStat
lav forall a. Semigroup a => a -> a -> a
<> JStat
e forall a. Semigroup a => a -> a -> a
<> JStat
returnStack

-- | Find the result type after applying the function to the arguments
--
-- It's trickier than it looks because:
--
-- 1. we don't have the Arity of the Id. The following functions return
-- different values in some cases:
--    - idArity
--    - typeArity . idType
--    - idFunRepArity
--    - typeArity . unwrapType . idType
-- Moreover the number of args may be different than all of these arities
--
-- 2. sometimes the type is Any, perhaps after some unwrapping. For example
-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a).
--
-- Se we're left to use the applied arguments to peel the type (unwrapped) one
-- arg at a time. But passed args are args after unarisation so we need to
-- unarise every argument type that we peel (using typePrimRepArgs) to get the
-- number of passed args consumed by each type arg.
--
-- In case of failure to determine the type, we default to LiftedRep as it's
-- probably what it is.
--
resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
resultSize [Id]
args Id
i = [(PrimRep, Int)]
result
  where
    result :: [(PrimRep, Int)]
result       = [PrimRep]
result_reps forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int]
result_slots
    result_slots :: [Int]
result_slots = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotCount -> Int
slotCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> SlotCount
primRepSize) [PrimRep]
result_reps
    result_reps :: [PrimRep]
result_reps  = Type -> Int -> [PrimRep]
trim_args (Type -> Type
unwrapType (Id -> Type
idType Id
i)) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args)

    trim_args :: Type -> Int -> [PrimRep]
trim_args Type
t Int
0 = HasDebugCallStack => Type -> [PrimRep]
typePrimRep Type
t
    trim_args Type
t Int
n
      | Just (FunTyFlag
_af, Type
_mult, Type
arg, Type
res) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
t
      , Int
nargs <- forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => Type -> [PrimRep]
typePrimRepArgs Type
arg)
      , forall a. HasCallStack => Bool -> a -> a
assert (Int
n forall a. Ord a => a -> a -> Bool
>= Int
nargs) Bool
True
      = Type -> Int -> [PrimRep]
trim_args (Type -> Type
unwrapType Type
res) (Int
n forall a. Num a => a -> a -> a
- Int
nargs)
      | Bool
otherwise
      = forall a. String -> SDoc -> a -> a
pprTrace String
"result_type: not a function type, assume LiftedRep" (forall a. Outputable a => a -> SDoc
ppr Type
t)
          [PrimRep
LiftedRep]

-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function
-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False.
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps [Id]
xs = do
  Bool
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
  if Bool -> Bool
not Bool
runtime_assert
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    else forall a. Monoid a => [a] -> a
mconcat 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 -> G JStat
verifyRuntimeRep [Id]
xs
  where
    verifyRuntimeRep :: Id -> G JStat
verifyRuntimeRep Id
i = do
      [JExpr]
i' <- Id -> G [JExpr]
varsForId Id
i
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [JExpr] -> [VarType] -> JStat
go [JExpr]
i' (HasDebugCallStack => Id -> [VarType]
idVt Id
i)
    go :: [JExpr] -> [VarType] -> JStat
go [JExpr]
js         (VarType
VoidV:[VarType]
vs) = [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
    go (JExpr
j1:JExpr
j2:[JExpr]
js) (VarType
LongV:[VarType]
vs) = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_long" [JExpr
j1,JExpr
j2] forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
    go (JExpr
j1:JExpr
j2:[JExpr]
js) (VarType
AddrV:[VarType]
vs) = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_addr" [JExpr
j1,JExpr
j2] forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
    go (JExpr
j:[JExpr]
js)     (VarType
v:[VarType]
vs)     = JExpr -> VarType -> JStat
ver JExpr
j VarType
v                       forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
    go []         []         = forall a. Monoid a => a
mempty
    go [JExpr]
_          [VarType]
_          = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"verifyRuntimeReps: inconsistent sizes" (forall a. Outputable a => a -> SDoc
ppr [Id]
xs)
    ver :: JExpr -> VarType -> JStat
ver JExpr
j VarType
PtrV    = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_heapobj" [JExpr
j]
    ver JExpr
j VarType
IntV    = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_int"     [JExpr
j]
    ver JExpr
j VarType
RtsObjV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_rtsobj"  [JExpr
j]
    ver JExpr
j VarType
DoubleV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_double"  [JExpr
j]
    ver JExpr
j VarType
ArrV    = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_arr"     [JExpr
j]
    ver JExpr
_ VarType
_       = forall a. Monoid a => a
mempty
    v :: FastString -> [JExpr] -> JStat
v FastString
f [JExpr]
as = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
f) [JExpr]
as

-- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N
-- registers. This assumes these data fields have already been populated in the
-- registers. For the empty, singleton, and binary case use register 1, for any
-- more use as many registers as necessary.
loadLiveFun :: [Id] -> G JStat
loadLiveFun :: [Id] -> G JStat
loadLiveFun [Id]
l = do
   [Ident]
l' <- 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 Id -> G [Ident]
identsForId [Id]
l
   case [Ident]
l' of
     []  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
     -- set the ident to d1 field of register 1
     [Ident
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_)
     -- set the idents to d1 and d2 fields of register 1
     [Ident
v1,Ident
v2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                        [ Ident
v1 Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_
                        , Ident
v2 Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_
                        ]
     -- and so on
     (Ident
v:[Ident]
vs)  -> do
       Ident
d <- StateT GenState IO Ident
freshIdent
       let l'' :: JStat
l'' = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JExpr -> Int -> Ident -> JStat
loadLiveVar forall a b. (a -> b) -> a -> b
$ forall a. ToJExpr a => a -> JExpr
toJExpr Ident
d) [(Int
1::Int)..] forall a b. (a -> b) -> a -> b
$ [Ident]
vs
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
               [ Ident
v Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_
               , Ident
d Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_
               , JStat
l''
               ]
  where
        loadLiveVar :: JExpr -> Int -> Ident -> JStat
loadLiveVar JExpr
d Int
n Ident
v = let ident :: Ident
ident = FastString -> Ident
TxtI (Int -> FastString
dataFieldName Int
n)
                            in  Ident
v Ident -> JExpr -> JStat
||= JExpr -> Ident -> JExpr
SelExpr JExpr
d Ident
ident

-- | Pop a let-no-escape frame off the stack
popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
inEntry Int
size ExprCtx
ctx = do
  -- calculate the new stack size
  let ctx' :: ExprCtx
ctx' = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
size

  let gen_id_slot :: (Id, Int) -> StateT GenState IO (Ident, StackSlot)
gen_id_slot (Id
i,Int
n) = do
        [Ident]
ids <- Id -> G [Ident]
identsForId Id
i
        let !id_n :: Ident
id_n = [Ident]
ids forall a. [a] -> Int -> a
!! (Int
nforall a. Num a => a -> a -> a
-Int
1)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ident
id_n, Id -> Int -> StackSlot
SlotId Id
i Int
n)

  [(Ident, StackSlot)]
is <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, Int) -> StateT GenState IO (Ident, StackSlot)
gen_id_slot (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx')

  let skip :: Int
skip = if Bool
inEntry then Int
1 else Int
0 -- pop the frame header
  Int -> [(Ident, StackSlot)] -> G JStat
popSkipI Int
skip [(Ident, StackSlot)]
is

-- | Generate an updated given an 'Id'
genUpdFrame :: UpdateFlag -> Id -> G JStat
genUpdFrame :: UpdateFlag -> Id -> G JStat
genUpdFrame UpdateFlag
u Id
i
  | UpdateFlag -> Bool
isReEntrant UpdateFlag
u   = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  | Id -> Bool
isOneShotBndr Id
i = G JStat
maybeBh
  | UpdateFlag -> Bool
isUpdatable UpdateFlag
u   = G JStat
updateThunk
  | Bool
otherwise       = G JStat
maybeBh
  where
    isReEntrant :: UpdateFlag -> Bool
isReEntrant UpdateFlag
ReEntrant = Bool
True
    isReEntrant UpdateFlag
_         = Bool
False
    maybeBh :: G JStat
maybeBh = do
      StgToJSConfig
settings <- G StgToJSConfig
getSettings
      G JStat -> G JStat
assertRtsStat (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> JStat
bhSingleEntry StgToJSConfig
settings)

-- | Blackhole single entry
--
-- Overwrite a single entry object with a special thunk that behaves like a
-- black hole (throws a JS exception when entered) but pretends to be a thunk.
-- Useful for making sure that the object is not accidentally entered multiple
-- times
--
bhSingleEntry :: StgToJSConfig -> JStat
bhSingleEntry :: StgToJSConfig -> JStat
bhSingleEntry StgToJSConfig
_settings = forall a. Monoid a => [a] -> a
mconcat
  [ JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureEntry_  JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$blackholeTrap"
  , JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
undefined_
  , JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr
undefined_
  ]

genStaticRefsRhs :: CgStgRhs -> G CIStatic
genStaticRefsRhs :: GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
lv = LiveVars -> G CIStatic
genStaticRefs (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
lv)

-- fixme, update to new way to compute static refs dynamically
genStaticRefs :: LiveVars -> G CIStatic
genStaticRefs :: LiveVars -> G CIStatic
genStaticRefs LiveVars
lv
  | LiveVars -> Bool
isEmptyDVarSet LiveVars
sv = forall (m :: * -> *) a. Monad m => a -> m a
return ([FastString] -> CIStatic
CIStaticRefs [])
  | Bool
otherwise         = do
      UniqFM Id CgStgExpr
unfloated <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
      let xs :: [Id]
xs = forall a. (a -> Bool) -> [a] -> [a]
filter (\Id
x -> Bool -> Bool
not (forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Id
x UniqFM Id CgStgExpr
unfloated Bool -> Bool -> Bool
||
                                  HasDebugCallStack => Type -> Maybe Levity
typeLevity_maybe (Id -> Type
idType Id
x) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Levity
Unlifted))
                      (LiveVars -> [Id]
dVarSetElems LiveVars
sv)
      [FastString] -> CIStatic
CIStaticRefs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes 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 -> G (Maybe FastString)
getStaticRef [Id]
xs
  where
    sv :: LiveVars
sv = LiveVars -> LiveVars
liveStatic LiveVars
lv

    getStaticRef :: Id -> G (Maybe FastString)
    getStaticRef :: Id -> G (Maybe FastString)
getStaticRef = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> FastString
itxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> G [Ident]
identsForId

-- | Reorder the things we need to push to reuse existing stack values as much
-- as possible True if already on the stack at that location
optimizeFree
  :: HasDebugCallStack
  => Int
  -> [Id]
  -> G [(Id,Int,Bool)] -- ^ A list of stack slots.
                       -- -- Id: stored on the slot
                       -- -- Int: the part of the value that is stored
                       -- -- Bool: True when the slot already contains a value
optimizeFree :: HasDebugCallStack => Int -> [Id] -> G [(Id, Int, Bool)]
optimizeFree Int
offset [Id]
ids = do
  -- this line goes wrong                               vvvvvvv
  let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids
      idSize :: Id -> Int
      idSize :: Id -> Int
idSize Id
i = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize (HasDebugCallStack => Type -> [VarType]
typeVt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType forall a b. (a -> b) -> a -> b
$ Id
i)
      ids' :: [(Id, Int)]
ids' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Id
i -> forall a b. (a -> b) -> [a] -> [b]
map (Id
i,) [Int
1..Id -> Int
idSize Id
i]) [Id]
ids
      -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids)
      l :: Int
l    = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, Int)]
ids'
  [StackSlot]
slots <- forall a. Int -> [a] -> [a]
drop Int
offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++forall a. a -> [a]
repeat StackSlot
SlotUnknown) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO [StackSlot]
getSlots
  let slm :: Map StackSlot Int
slm                = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [StackSlot]
slots [Int
0..])
      ([(Id, Int)]
remaining, [(Id, Int, Int, Bool)]
fixed) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> [a] -> [b]
map (\inp :: (Id, Int)
inp@(Id
i,Int
n) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left (Id, Int)
inp) (\Int
j -> forall a b. b -> Either a b
Right (Id
i,Int
n,Int
j,Bool
True))
            (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Id -> Int -> StackSlot
SlotId Id
i Int
n) Map StackSlot Int
slm)) [(Id, Int)]
ids'
      takenSlots :: Set Int
takenSlots         = forall a. Ord a => [a] -> Set a
S.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Id
_,Int
_,Int
x,Bool
_) -> Int
x) [(Id, Int, Int, Bool)]
fixed)
      freeSlots :: [Int]
freeSlots          = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Int
takenSlots) [Int
0..Int
lforall a. Num a => a -> a -> a
-Int
1]
      remaining' :: [(Id, Int, Int, Bool)]
remaining'         = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Id
i,Int
n) Int
j -> (Id
i,Int
n,Int
j,Bool
False)) [(Id, Int)]
remaining [Int]
freeSlots
      allSlots :: [(Id, Int, Int, Bool)]
allSlots           = forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \(Id
_,Int
_,Int
x,Bool
_) -> Int
x) ([(Id, Int, Int, Bool)]
fixed forall a. [a] -> [a] -> [a]
++ [(Id, Int, Int, Bool)]
remaining')
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Id
i,Int
n,Int
_,Bool
b) -> (Id
i,Int
n,Bool
b)) [(Id, Int, Int, Bool)]
allSlots

-- | Allocate local closures
allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
allocCls :: Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls Maybe JStat
dynMiddle [(Id, GenStgRhs 'CodeGen)]
xs = do
   ([JStat]
stat, [(Ident, JExpr, [JExpr], CostCentreStack)]
dyn) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers 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, GenStgRhs 'CodeGen)
-> G (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
toCl [(Id, GenStgRhs 'CodeGen)]
xs
   JStat
ac <- Bool
-> Maybe JStat
-> [(Ident, JExpr, [JExpr], CostCentreStack)]
-> G JStat
allocDynAll Bool
True Maybe JStat
dynMiddle [(Ident, JExpr, [JExpr], CostCentreStack)]
dyn
   forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => [a] -> a
mconcat [JStat]
stat forall a. Semigroup a => a -> a -> a
<> JStat
ac)
  where
    -- left = static, right = dynamic
    toCl :: (Id, CgStgRhs)
         -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack))
    -- statics
    {- making zero-arg constructors static is problematic, see #646
       proper candidates for this optimization should have been floated
       already
      toCl (i, StgRhsCon cc con []) = do
      ii <- identForId i
      Left <$> (return (decl ii) <> allocCon ii con cc []) -}
    toCl :: (Id, GenStgRhs 'CodeGen)
-> G (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mui [GenTickish 'TickishPassStg]
_ticjs [StgArg
a]) | DataCon -> Bool
isUnboxableCon DataCon
con = do
      Ident
ii <- Id -> StateT GenState IO Ident
identForId Id
i
      JStat
ac <- Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
ii DataCon
con CostCentreStack
cc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasDebugCallStack => StgArg -> G [JExpr]
genArg StgArg
a
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Ident -> JStat
decl Ident
ii forall a. Semigroup a => a -> a -> a
<> JStat
ac))

    -- dynamics
    toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
ar) =
      -- fixme do we need to handle unboxed?
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DataCon -> G JExpr
varForDataConWorker DataCon
con
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
ar
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CostCentreStack
cc)
    toCl (Id
i, cl :: GenStgRhs 'CodeGen
cl@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
_args CgStgExpr
_body)) =
      let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
cl
      in  forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> G JExpr
varForEntryId Id
i
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JExpr]
varsForId [Id]
live
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CostCentreStack
cc)

-- fixme CgCase has a reps_compatible check here
-- | Consume Stg case statement and generate a case statement. See also
-- 'genAlts'
genCase :: HasDebugCallStack
        => ExprCtx
        -> Id
        -> CgStgExpr
        -> AltType
        -> [CgStgAlt]
        -> LiveVars
        -> G (JStat, ExprResult)
genCase :: HasDebugCallStack =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStat, ExprResult)
genCase ExprCtx
ctx Id
bnd CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
  | forall a b. (a, b) -> b
snd (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx) CgStgExpr
e) = do
      [Ident]
bndi <- Id -> G [Ident]
identsForId Id
bnd
      let ctx' :: ExprCtx
ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
                  forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
bnd (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr [Ident]
bndi))
                  forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
      (JStat
ej, ExprResult
r) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
      let d :: Maybe [JExpr]
d = case ExprResult
r of
                ExprInline Maybe [JExpr]
d0 -> Maybe [JExpr]
d0
                ExprResult
ExprCont -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCase: expression was not inline"
                                     (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
e)

      (JStat
aj, ExprResult
ar) <- HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
bnd ExprCtx
ctx) Id
bnd AltType
at Maybe [JExpr]
d [GenStgAlt 'CodeGen]
alts
      (JStat
saveCCS,JStat
restoreCCS) <- forall m. Monoid m => G m -> G m
ifProfilingM forall a b. (a -> b) -> a -> b
$ do
        Ident
ccsVar <- StateT GenState IO Ident
freshIdent
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Ident
ccsVar Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
jCurrentCCS
             , forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
jCurrentCCS JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccsVar
             )
      forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => [a] -> a
mconcat
          [ forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStat
decl [Ident]
bndi)
          , JStat
saveCCS
          , JStat
ej
          , JStat
restoreCCS
          , JStat
aj
          ]
        , ExprResult
ar
         )
  | Bool
otherwise = do
      JStat
rj       <- HasDebugCallStack =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStat
genRet (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
bnd ExprCtx
ctx) Id
bnd AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
      let ctx' :: ExprCtx
ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
                  forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
bnd (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
R1 ..]))
                  forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
      (JStat
ej, ExprResult
_r) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
rj forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
ExprCont)

genRet :: HasDebugCallStack
       => ExprCtx
       -> Id
       -> AltType
       -> [CgStgAlt]
       -> LiveVars
       -> G JStat
genRet :: HasDebugCallStack =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStat
genRet ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
as LiveVars
l = StateT GenState IO Ident
freshIdent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ident -> G JStat
f
  where
    allRefs :: [Id]
    allRefs :: [Id]
allRefs =  forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs forall key elt. UniqFM key elt
emptyUFM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs) [GenStgAlt 'CodeGen]
as
    lneLive :: Int
    lneLive :: Int
lneLive    = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Int
0 forall a. a -> [a] -> [a]
: forall a. [Maybe a] -> [a]
catMaybes (forall a b. (a -> b) -> [a] -> [b]
map (ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx) [Id]
allRefs)
    ctx' :: ExprCtx
ctx'       = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
lneLive
    lneVars :: [Id]
lneVars    = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx'
    isLne :: Id -> Bool
isLne Id
i    = ExprCtx -> Id -> Bool
ctxIsLneBinding ExprCtx
ctx Id
i Bool -> Bool -> Bool
|| ExprCtx -> Id -> Bool
ctxIsLneLiveVar ExprCtx
ctx' Id
i
    nonLne :: [Id]
nonLne     = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isLne) (LiveVars -> [Id]
dVarSetElems LiveVars
l)

    f :: Ident -> G JStat
    f :: Ident -> G JStat
f r :: Ident
r@(TxtI FastString
ri)    =  do
      JStat
pushLne  <- HasDebugCallStack => Int -> ExprCtx -> G JStat
pushLneFrame Int
lneLive ExprCtx
ctx
      JStat
saveCCS  <- forall m. Monoid m => G m -> G m
ifProfilingM forall a b. (a -> b) -> a -> b
$ [JExpr] -> G JStat
push [JExpr
jCurrentCCS]
      [(Id, Int, Bool)]
free     <- HasDebugCallStack => Int -> [Id] -> G [(Id, Int, Bool)]
optimizeFree Int
0 [Id]
nonLne
      JStat
pushRet  <- HasDebugCallStack => [(Id, Int, Bool)] -> JExpr -> G JStat
pushRetArgs [(Id, Int, Bool)]
free (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
r)
      JStat
fun'     <- [(Id, Int, Bool)] -> G JStat
fun [(Id, Int, Bool)]
free
      CIStatic
sr       <- LiveVars -> G CIStatic
genStaticRefs LiveVars
l -- srt
      Bool
prof     <- StateT GenState IO Bool
profiling
      ClosureInfo -> G ()
emitClosureInfo forall a b. (a -> b) -> a -> b
$
        Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
r
                    (Int -> [VarType] -> CIRegs
CIRegs Int
0 HasDebugCallStack => [VarType]
altRegs)
                    FastString
ri
                    ([VarType] -> CILayout
fixedLayout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
                       forall a b. (a -> b) -> [a] -> [b]
map (Id -> VarType
stackSlotType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Id, Int, Bool)]
free
                       forall a. [a] -> [a] -> [a]
++ if Bool
prof then [VarType
ObjV] else forall a b. (a -> b) -> [a] -> [b]
map Id -> VarType
stackSlotType [Id]
lneVars)
                    CIType
CIStackFrame
                    CIStatic
sr
      JStat -> G ()
emitToplevel forall a b. (a -> b) -> a -> b
$ Ident
r Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] JStat
fun')
      forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
pushLne forall a. Semigroup a => a -> a -> a
<> JStat
saveCCS forall a. Semigroup a => a -> a -> a
<> JStat
pushRet)
    fst3 :: (a, b, c) -> a
fst3 ~(a
x,b
_,c
_)  = a
x

    altRegs :: HasDebugCallStack => [VarType]
    altRegs :: HasDebugCallStack => [VarType]
altRegs = case AltType
at of
      PrimAlt PrimRep
ptc    -> [HasDebugCallStack => PrimRep -> VarType
primRepVt PrimRep
ptc]
      MultiValAlt Int
_n -> HasDebugCallStack => Id -> [VarType]
idVt Id
e
      AltType
_              -> [VarType
PtrV]

    -- special case for popping CCS but preserving stack size
    pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
    pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
pop_handle_CCS [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    pop_handle_CCS [(JExpr, StackSlot)]
xs = do
      -- grab the slots from 'xs' and push
      [StackSlot] -> G ()
addSlots (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(JExpr, StackSlot)]
xs)
      -- move the stack pointer into the stack by ''length xs + n'
      JStat
a <- Int -> G JStat
adjSpN (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JExpr, StackSlot)]
xs)
      -- now load from the top of the stack
      forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [JExpr] -> JStat
loadSkip Int
0 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(JExpr, StackSlot)]
xs) forall a. Semigroup a => a -> a -> a
<> JStat
a)

    fun :: [(Id, Int, Bool)] -> G JStat
fun [(Id, Int, Bool)]
free = forall a. G a -> G a
resetSlots forall a b. (a -> b) -> a -> b
$ do
      JStat
decs          <- Id -> G JStat
declVarsForId Id
e
      JStat
load          <- forall a b c. (a -> b -> c) -> b -> a -> c
flip [JExpr] -> [JExpr] -> JStat
assignAll (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
R1 ..]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJExpr a => a -> JExpr
toJExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
e
      JStat
loadv         <- HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps [Id
e]
      JStat
ras           <- HasDebugCallStack => [(Id, Int, Bool)] -> G JStat
loadRetArgs [(Id, Int, Bool)]
free
      JStat
rasv          <- HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps (forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
_,Bool
_)->Id
x) [(Id, Int, Bool)]
free)
      JStat
restoreCCS    <- forall m. Monoid m => G m -> G m
ifProfilingM forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JExpr, StackSlot)] -> G JStat
pop_handle_CCS forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (JExpr
jCurrentCCS, StackSlot
SlotUnknown)
      JStat
rlne          <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
False Int
lneLive ExprCtx
ctx'
      JStat
rlnev         <- HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps [Id]
lneVars
      (JStat
alts, ExprResult
_altr) <- HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts ExprCtx
ctx' Id
e AltType
at forall a. Maybe a
Nothing [GenStgAlt 'CodeGen]
as
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JStat
decs forall a. Semigroup a => a -> a -> a
<> JStat
load forall a. Semigroup a => a -> a -> a
<> JStat
loadv forall a. Semigroup a => a -> a -> a
<> JStat
ras forall a. Semigroup a => a -> a -> a
<> JStat
rasv forall a. Semigroup a => a -> a -> a
<> JStat
restoreCCS forall a. Semigroup a => a -> a -> a
<> JStat
rlne forall a. Semigroup a => a -> a -> a
<> JStat
rlnev forall a. Semigroup a => a -> a -> a
<> JStat
alts forall a. Semigroup a => a -> a -> a
<>
               JStat
returnStack

-- | Consume an Stg case alternative and generate the corresponding alternative
-- in JS land. If one alternative is a continuation then we must normalize the
-- other alternatives. See 'Branch' and 'normalizeBranches'.
genAlts :: HasDebugCallStack
        => ExprCtx        -- ^ lhs to assign expression result to
        -> Id             -- ^ id being matched
        -> AltType        -- ^ type
        -> Maybe [JExpr]  -- ^ if known, fields in datacon from earlier expression
        -> [CgStgAlt]     -- ^ the alternatives
        -> G (JStat, ExprResult)
genAlts :: HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts ExprCtx
ctx Id
e AltType
at Maybe [JExpr]
me [GenStgAlt 'CodeGen]
alts = do
  (JStat
st, ExprResult
er) <- case AltType
at of

    AltType
PolyAlt -> case [GenStgAlt 'CodeGen]
alts of
      [GenStgAlt 'CodeGen
alt] -> (forall a. Branch a -> JStat
branch_stat forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Branch a -> ExprResult
branch_result) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprCtx -> Id -> GenStgAlt 'CodeGen -> G (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
      [GenStgAlt 'CodeGen]
_     -> forall a. HasCallStack => String -> a
panic String
"genAlts: multiple polyalt"

    PrimAlt PrimRep
_tc
      | [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
      -> do
        [JExpr]
ie       <- Id -> G [JExpr]
varsForId Id
e
        JStat
dids     <- forall a. Monoid a => [a] -> a
mconcat 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 -> G JStat
declVarsForId [BinderP 'CodeGen]
bs
        [JExpr]
bss      <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JExpr]
varsForId [BinderP 'CodeGen]
bs
        (JStat
ej, ExprResult
er) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
        forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
dids forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
bss [JExpr]
ie forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)

    PrimAlt PrimRep
tc
      -> do
        [JExpr]
ie <- Id -> G [JExpr]
varsForId Id
e
        (ExprResult
r, [Branch (Maybe [JExpr])]
bss) <- forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx 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 (forall a. G a -> G a
isolateSlots forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> [VarType]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr]))
mkPrimIfBranch ExprCtx
ctx [HasDebugCallStack => PrimRep -> VarType
primRepVt PrimRep
tc]) [GenStgAlt 'CodeGen]
alts
        [StackSlot] -> G ()
setSlots []
        forall (m :: * -> *) a. Monad m => a -> m a
return ([JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw [JExpr]
ie [Branch (Maybe [JExpr])]
bss, ExprResult
r)

    MultiValAlt Int
n
      | [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
      -> do
        [JExpr]
eids     <- Id -> G [JExpr]
varsForId Id
e
        JStat
l        <- [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup [JExpr]
eids [BinderP 'CodeGen]
bs Int
n
        (JStat
ej, ExprResult
er) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
        forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
l forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)

    AlgAlt TyCon
tc
      | [GenStgAlt 'CodeGen
_alt] <- [GenStgAlt 'CodeGen]
alts
      , TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
      -> forall a. HasCallStack => String -> a
panic String
"genAlts: unexpected unboxed tuple"

    AlgAlt TyCon
_tc
      | Just [JExpr]
es <- Maybe [JExpr]
me
      , [GenStgAlt (DataAlt DataCon
dc) [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
      , Bool -> Bool
not (DataCon -> Bool
isUnboxableCon DataCon
dc)
      -> do
        [[Ident]]
bsi <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> G [Ident]
identsForId [BinderP 'CodeGen]
bs
        (JStat
ej, ExprResult
er) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Ident] -> [JExpr] -> JStat
declAssignAll (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ident]]
bsi) [JExpr]
es forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)

    AlgAlt TyCon
_tc
      | [GenStgAlt 'CodeGen
alt] <- [GenStgAlt 'CodeGen]
alts
      -> do
        Branch Maybe JExpr
_ JStat
s ExprResult
r <- ExprCtx -> Id -> GenStgAlt 'CodeGen -> G (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
        forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s, ExprResult
r)

    AlgAlt TyCon
_tc
      | [GenStgAlt 'CodeGen
alt,GenStgAlt 'CodeGen
_] <- [GenStgAlt 'CodeGen]
alts
      , DataAlt DataCon
dc <- forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt
      , DataCon -> Bool
isBoolDataCon DataCon
dc
      -> do
        JExpr
i <- Id -> G JExpr
varForId Id
e
        (ExprResult, [Branch (Maybe JExpr)])
nbs <- forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx 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 (forall a. G a -> G a
isolateSlots forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx -> Id -> GenStgAlt 'CodeGen -> G (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e) [GenStgAlt 'CodeGen]
alts
        case (ExprResult, [Branch (Maybe JExpr)])
nbs of
          (ExprResult
r, [Branch Maybe JExpr
_ JStat
s1 ExprResult
_, Branch Maybe JExpr
_ JStat
s2 ExprResult
_]) -> do
            let s :: JStat
s = if   DataCon -> Int
dataConTag DataCon
dc forall a. Eq a => a -> a -> Bool
== Int
2
                    then JExpr -> JStat -> JStat -> JStat
IfStat JExpr
i JStat
s1 JStat
s2
                    else JExpr -> JStat -> JStat -> JStat
IfStat JExpr
i JStat
s2 JStat
s1
            [StackSlot] -> G ()
setSlots []
            forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s, ExprResult
r)
          (ExprResult, [Branch (Maybe JExpr)])
_ -> forall a. HasCallStack => String -> a
error String
"genAlts: invalid branches for Bool"

    AlgAlt TyCon
_tc -> do
        JExpr
ei <- Id -> G JExpr
varForId Id
e
        (ExprResult
r, [Branch (Maybe JExpr)]
brs) <- forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx 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 (forall a. G a -> G a
isolateSlots forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx -> Id -> GenStgAlt 'CodeGen -> G (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e) [GenStgAlt 'CodeGen]
alts
        [StackSlot] -> G ()
setSlots []
        forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch (JExpr
ei JExpr -> FastString -> JExpr
.^ FastString
"f" JExpr -> FastString -> JExpr
.^ FastString
"a") [Branch (Maybe JExpr)]
brs, ExprResult
r)

    AltType
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genAlts: unhandled case variant" (forall a. Outputable a => a -> SDoc
ppr (AltType
at, forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenStgAlt 'CodeGen]
alts))

  JStat
ver <- HasDebugCallStack => Id -> AltType -> G JStat
verifyMatchRep Id
e AltType
at
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat
ver forall a. Semigroup a => a -> a -> a
<> JStat
st, ExprResult
er)

-- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that
-- asserts the pattern match is valid, e.g., the match is attempted on a
-- Boolean, a Data Constructor, or some number.
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat
verifyMatchRep Id
x AltType
alt = do
  Bool
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
  if Bool -> Bool
not Bool
runtime_assert
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    else case AltType
alt of
      AlgAlt TyCon
tc -> do
        [JExpr]
ix <- Id -> G [JExpr]
varsForId Id
x
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$verify_match_alg") (JVal -> JExpr
ValExpr(FastString -> JVal
JStr(String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr TyCon
tc))))forall a. a -> [a] -> [a]
:[JExpr]
ix)
      AltType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

-- | A 'Branch' represents a possible branching path of an Stg case statement,
-- i.e., a possible code path from an 'StgAlt'
data Branch a = Branch
  { forall a. Branch a -> a
branch_expr   :: a
  , forall a. Branch a -> JStat
branch_stat   :: JStat
  , forall a. Branch a -> ExprResult
branch_result :: ExprResult
  }
  deriving (Branch a -> Branch a -> Bool
forall a. Eq a => Branch a -> Branch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Branch a -> Branch a -> Bool
$c/= :: forall a. Eq a => Branch a -> Branch a -> Bool
== :: Branch a -> Branch a -> Bool
$c== :: forall a. Eq a => Branch a -> Branch a -> Bool
Eq,forall a b. a -> Branch b -> Branch a
forall a b. (a -> b) -> Branch a -> Branch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Branch b -> Branch a
$c<$ :: forall a b. a -> Branch b -> Branch a
fmap :: forall a b. (a -> b) -> Branch a -> Branch b
$cfmap :: forall a b. (a -> b) -> Branch a -> Branch b
Functor)

-- | If one branch ends in a continuation but another is inline, we need to
-- adjust the inline branch to use the continuation convention
normalizeBranches :: ExprCtx
                  -> [Branch a]
                  -> (ExprResult, [Branch a])
normalizeBranches :: forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx [Branch a]
brs
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==ExprResult
ExprCont) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) =
        (ExprResult
ExprCont, [Branch a]
brs)
    | HasDebugCallStack => [ExprResult] -> ExprResult
branchResult (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) forall a. Eq a => a -> a -> Bool
== ExprResult
ExprCont =
        (ExprResult
ExprCont, forall a b. (a -> b) -> [a] -> [b]
map Branch a -> Branch a
mkCont [Branch a]
brs)
    | Bool
otherwise =
        (Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing, [Branch a]
brs)
  where
    mkCont :: Branch a -> Branch a
mkCont Branch a
b = case forall a. Branch a -> ExprResult
branch_result Branch a
b of
      ExprInline{} -> Branch a
b { branch_stat :: JStat
branch_stat   = forall a. Branch a -> JStat
branch_stat Branch a
b forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
jsRegsFromR1
                                                                     (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
                        , branch_result :: ExprResult
branch_result = ExprResult
ExprCont
                        }
      ExprResult
_ -> Branch a
b

-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input
-- ID's, declaring them as variables in JS land and binding them, in order, to
-- 'es'.
loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup [JExpr]
es [Id]
bs Int
_n = do
  [Ident]
bs' <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [Ident]
identsForId [Id]
bs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Ident] -> [JExpr] -> JStat
declAssignAll [Ident]
bs' [JExpr]
es

mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw [JExpr
e] [Branch (Maybe [JExpr])]
cases = JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch JExpr
e (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head)) [Branch (Maybe [JExpr])]
cases)
mkSw [JExpr]
es [Branch (Maybe [JExpr])]
cases  = [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse [JExpr]
es [Branch (Maybe [JExpr])]
cases

-- | Switch for pattern matching on constructors or prims
mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch JExpr
e [Branch (Maybe JExpr)]
cases
  | [Branch (Just JExpr
c1) JStat
s1 ExprResult
_] <- [Branch (Maybe JExpr)]
n
  , [Branch Maybe JExpr
_ JStat
s2 ExprResult
_] <- [Branch (Maybe JExpr)]
d
  = JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp JExpr
e JExpr
c1) JStat
s1 JStat
s2

  | [Branch (Just JExpr
c1) JStat
s1 ExprResult
_, Branch Maybe JExpr
_ JStat
s2 ExprResult
_] <- [Branch (Maybe JExpr)]
n
  , forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JExpr)]
d
  = JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp JExpr
e JExpr
c1) JStat
s1 JStat
s2

  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JExpr)]
d
  = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
e (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Branch (Maybe a) -> (a, JStat)
addBreak (forall a. [a] -> [a]
init [Branch (Maybe JExpr)]
n)) (forall a. Branch a -> JStat
branch_stat (forall a. [a] -> a
last [Branch (Maybe JExpr)]
n))

  | [Branch Maybe JExpr
_ JStat
d0 ExprResult
_] <- [Branch (Maybe JExpr)]
d
  = JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
e (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Branch (Maybe a) -> (a, JStat)
addBreak [Branch (Maybe JExpr)]
n) JStat
d0

  | Bool
otherwise = forall a. HasCallStack => String -> a
panic String
"mkSwitch: multiple default cases"
  where
    addBreak :: Branch (Maybe a) -> (a, JStat)
addBreak (Branch (Just a
c) JStat
s ExprResult
_) = (a
c, forall a. Monoid a => [a] -> a
mconcat [JStat
s, Maybe JsLabel -> JStat
BreakStat forall a. Maybe a
Nothing])
    addBreak Branch (Maybe a)
_                     = forall a. HasCallStack => String -> a
panic String
"mkSwitch: addBreak"
    ([Branch (Maybe JExpr)]
n,[Branch (Maybe JExpr)]
d) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Branch a -> a
branch_expr) [Branch (Maybe JExpr)]
cases

-- | if/else for pattern matching on things that js cannot switch on
-- the list of branches is expected to have the default alternative
-- first, if it exists
mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse [JExpr]
e [Branch (Maybe [JExpr])]
s = [Branch (Maybe [JExpr])] -> JStat
go (forall a. [a] -> [a]
L.reverse [Branch (Maybe [JExpr])]
s)
    where
      go :: [Branch (Maybe [JExpr])] -> JStat
go = \case
        [Branch Maybe [JExpr]
_ JStat
s ExprResult
_]              -> JStat
s -- only one 'nothing' allowed
        (Branch (Just [JExpr]
e0) JStat
s ExprResult
_ : [Branch (Maybe [JExpr])]
xs) -> JExpr -> JStat -> JStat -> JStat
IfStat ([JExpr] -> [JExpr] -> JExpr
mkEq [JExpr]
e [JExpr]
e0) JStat
s ([Branch (Maybe [JExpr])] -> JStat
go [Branch (Maybe [JExpr])]
xs)
        [] -> forall a. HasCallStack => String -> a
panic String
"mkIfElse: empty expression list"
        [Branch (Maybe [JExpr])]
_  -> forall a. HasCallStack => String -> a
panic String
"mkIfElse: multiple DEFAULT cases"

-- | Wrapper to contruct sequences of (===), e.g.,
--
-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2)
--
mkEq :: [JExpr] -> [JExpr] -> JExpr
mkEq :: [JExpr] -> [JExpr] -> JExpr
mkEq [JExpr]
es1 [JExpr]
es2
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es2 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
LAndOp) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp) [JExpr]
es1 [JExpr]
es2)
  | Bool
otherwise                = forall a. HasCallStack => String -> a
panic String
"mkEq: incompatible expressions"

mkAlgBranch :: ExprCtx   -- ^ toplevel id for the result
            -> Id        -- ^ datacon to match
            -> CgStgAlt  -- ^ match alternative with binders
            -> G (Branch (Maybe JExpr))
mkAlgBranch :: ExprCtx -> Id -> GenStgAlt 'CodeGen -> G (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
top Id
d GenStgAlt 'CodeGen
alt
  | DataAlt DataCon
dc <- forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt
  , DataCon -> Bool
isUnboxableCon DataCon
dc
  , [BinderP 'CodeGen
b] <- forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt
  = do
    JExpr
idd  <- Id -> G JExpr
varForId Id
d
    [Ident]
fldx <- Id -> G [Ident]
identsForId BinderP 'CodeGen
b
    case [Ident]
fldx of
      [Ident
fld] -> do
        (JStat
ej, ExprResult
er) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> JStat -> ExprResult -> Branch a
Branch forall a. Maybe a
Nothing (forall a. Monoid a => [a] -> a
mconcat [Ident
fld Ident -> JExpr -> JStat
||= JExpr
idd, JStat
ej]) ExprResult
er)
      [Ident]
_ -> forall a. HasCallStack => String -> a
panic String
"mkAlgBranch: invalid size"

  | Bool
otherwise
  = do
    Maybe JExpr
cc       <- AltCon -> G (Maybe JExpr)
caseCond (forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt)
    JExpr
idd      <- Id -> G JExpr
varForId Id
d
    JStat
b        <- JExpr -> [Id] -> G JStat
loadParams JExpr
idd (forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt)
    (JStat
ej, ExprResult
er) <- HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> JStat -> ExprResult -> Branch a
Branch Maybe JExpr
cc (JStat
b forall a. Semigroup a => a -> a -> a
<> JStat
ej) ExprResult
er)

-- | Generate a primitive If-expression
mkPrimIfBranch :: ExprCtx
               -> [VarType]
               -> CgStgAlt
               -> G (Branch (Maybe [JExpr]))
mkPrimIfBranch :: ExprCtx
-> [VarType]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr]))
mkPrimIfBranch ExprCtx
top [VarType]
_vt GenStgAlt 'CodeGen
alt =
  (\Maybe [JExpr]
ic (JStat
ej,ExprResult
er) -> forall a. a -> JStat -> ExprResult -> Branch a
Branch Maybe [JExpr]
ic JStat
ej ExprResult
er) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AltCon -> G (Maybe [JExpr])
ifCond (forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)

-- fixme are bool things always checked correctly here?
ifCond :: AltCon -> G (Maybe [JExpr])
ifCond :: AltCon -> G (Maybe [JExpr])
ifCond = \case
  DataAlt DataCon
da -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [forall a. ToJExpr a => a -> JExpr
toJExpr (DataCon -> Int
dataConTag DataCon
da)]
  LitAlt Literal
l   -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Literal -> G [JExpr]
genLit Literal
l
  AltCon
DEFAULT    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

caseCond :: AltCon -> G (Maybe JExpr)
caseCond :: AltCon -> G (Maybe JExpr)
caseCond = \case
  AltCon
DEFAULT    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  DataAlt DataCon
da -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
da)
  LitAlt Literal
l   -> HasDebugCallStack => Literal -> G [JExpr]
genLit Literal
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [JExpr
e] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just JExpr
e)
    [JExpr]
es  -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseCond: expected single-variable literal" (forall a. Outputable a => a -> SDoc
ppr [JExpr]
es)

-- fixme use single tmp var for all branches
-- | Load parameters from constructor
loadParams :: JExpr -> [Id] -> G JStat
loadParams :: JExpr -> [Id] -> G JStat
loadParams JExpr
from [Id]
args = do
  [(Ident, Bool)]
as <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Id
a Bool
u -> forall a b. (a -> b) -> [a] -> [b]
map (,Bool
u) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
a) [Id]
args [Bool]
use
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [(Ident, Bool)]
as of
    []                 -> forall a. Monoid a => a
mempty
    [(Ident
x,Bool
u)]            -> JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x  Bool
u
    [(Ident
x1,Bool
u1),(Ident
x2,Bool
u2)]  -> forall a. Monoid a => [a] -> a
mconcat
                            [ JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x1 Bool
u1
                            , JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField2_) Ident
x2 Bool
u2
                            ]
    ((Ident
x,Bool
u):[(Ident, Bool)]
xs)         -> forall a. Monoid a => [a] -> a
mconcat
                            [ JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x Bool
u
                            , forall a. ToSat a => a -> JStat
jVar (\JExpr
d -> forall a. Monoid a => [a] -> a
mconcat [ JExpr
d JExpr -> JExpr -> JStat
|= JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField2_
                                                  , JExpr -> [(Ident, Bool)] -> JStat
loadConVarsIfUsed JExpr
d [(Ident, Bool)]
xs
                                                  ])
                            ]
  where
    use :: [Bool]
use = forall a. a -> [a]
repeat Bool
True -- fixme clean up
    loadIfUsed :: JExpr -> Ident -> Bool -> JStat
loadIfUsed JExpr
fr Ident
tgt Bool
True = Ident
tgt Ident -> JExpr -> JStat
||= JExpr
fr
    loadIfUsed  JExpr
_ Ident
_   Bool
_    = forall a. Monoid a => a
mempty

    loadConVarsIfUsed :: JExpr -> [(Ident, Bool)] -> JStat
loadConVarsIfUsed JExpr
fr [(Ident, Bool)]
cs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ident, Bool) -> Int -> JStat
f [(Ident, Bool)]
cs [(Int
1::Int)..]
      where f :: (Ident, Bool) -> Int -> JStat
f (Ident
x,Bool
u) Int
n = JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr -> Ident -> JExpr
SelExpr JExpr
fr (FastString -> Ident
TxtI (Int -> FastString
dataFieldName Int
n))) Ident
x Bool
u

-- | Determine if a branch will end in a continuation or not. If not the inline
-- branch must be normalized. See 'normalizeBranches'
-- NB. not a Monoid
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult = \case
  []                   -> forall a. HasCallStack => String -> a
panic String
"branchResult: empty list"
  [ExprResult
e]                  -> ExprResult
e
  (ExprResult
ExprCont:[ExprResult]
_)         -> ExprResult
ExprCont
  (ExprResult
_:[ExprResult]
es)
    | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExprResult
ExprCont [ExprResult]
es -> ExprResult
ExprCont
    | Bool
otherwise        -> Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing

-- | Push return arguments onto the stack. The 'Bool' tracks whether the value
-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'.
pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat
pushRetArgs :: HasDebugCallStack => [(Id, Int, Bool)] -> JExpr -> G JStat
pushRetArgs [(Id, Int, Bool)]
free JExpr
fun = do
  [(JExpr, Bool)]
rs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Id
i,Int
n,Bool
b) -> (\[JExpr]
es->([JExpr]
esforall a. [a] -> Int -> a
!!(Int
nforall a. Num a => a -> a -> a
-Int
1),Bool
b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> G [JExpr]
genIdArg Id
i) [(Id, Int, Bool)]
free
  [(JExpr, Bool)] -> G JStat
pushOptimized ([(JExpr, Bool)]
rsforall a. [a] -> [a] -> [a]
++[(JExpr
fun,Bool
False)])

-- | Load the return arguments then pop the stack frame
loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat
loadRetArgs :: HasDebugCallStack => [(Id, Int, Bool)] -> G JStat
loadRetArgs [(Id, Int, Bool)]
free = do
  [(Ident, StackSlot)]
ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Id
i,Int
n,Bool
_b) -> (forall a. [a] -> Int -> a
!! (Int
nforall a. Num a => a -> a -> a
-Int
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> G [(Ident, StackSlot)]
genIdStackArgI Id
i) [(Id, Int, Bool)]
free
  Int -> [(Ident, StackSlot)] -> G JStat
popSkipI Int
1 [(Ident, StackSlot)]
ids

-- | allocate multiple, possibly mutually recursive, closures
allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat
{-
XXX remove use of template and enable in-place init again
allocDynAll haveDecl middle [(to,entry,free,cc)]
  | isNothing middle && to `notElem` (free ^.. template) = do
      ccs <- ccsVarJ cc
      return $ allocDynamic s haveDecl to entry free ccs -}
allocDynAll :: Bool
-> Maybe JStat
-> [(Ident, JExpr, [JExpr], CostCentreStack)]
-> G JStat
allocDynAll Bool
haveDecl Maybe JStat
middle [(Ident, JExpr, [JExpr], CostCentreStack)]
cls = do
  StgToJSConfig
settings <- G StgToJSConfig
getSettings
  let
    middle' :: JStat
middle' = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe JStat
middle

    decl_maybe :: Ident -> JExpr -> JStat
decl_maybe Ident
i JExpr
e
      | Bool
haveDecl  = forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> JExpr -> JStat
|= JExpr
e
      | Bool
otherwise = Ident
i Ident -> JExpr -> JStat
||= JExpr
e

    makeObjs :: G JStat
    makeObjs :: G JStat
makeObjs =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Ident, JExpr, [JExpr], CostCentreStack)]
cls forall a b. (a -> b) -> a -> b
$ \(Ident
i,JExpr
f,[JExpr]
_,CostCentreStack
cc) -> do
      [Ident]
ccs <- forall a. Maybe a -> [a]
maybeToList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
cc
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ Ident -> JExpr -> JStat
decl_maybe Ident
i forall a b. (a -> b) -> a -> b
$ if StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
settings
            then JVal -> JExpr
ValExpr ([(FastString, JExpr)] -> JVal
jhFromList forall a b. (a -> b) -> a -> b
$ [ (FastString
closureEntry_ , JExpr
f)
                                       , (FastString
closureField1_, JExpr
null_)
                                       , (FastString
closureField2_, JExpr
null_)
                                       , (FastString
closureMeta_  , JExpr
zero_)
                                       ]
                             forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Ident
cid -> (FastString
"cc", JVal -> JExpr
ValExpr (Ident -> JVal
JVar Ident
cid))) [Ident]
ccs)
            else JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$c") (JExpr
f forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) [Ident]
ccs)
        ]

    fillObjs :: JStat
fillObjs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Ident, JExpr, [JExpr], CostCentreStack) -> JStat
fillObj [(Ident, JExpr, [JExpr], CostCentreStack)]
cls
    fillObj :: (Ident, JExpr, [JExpr], CostCentreStack) -> JStat
fillObj (Ident
i,JExpr
_,[JExpr]
es,CostCentreStack
_)
      | StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
settings Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es forall a. Ord a => a -> a -> Bool
> Int
24 =
          case [JExpr]
es of
            []      -> forall a. Monoid a => a
mempty
            [JExpr
ex]    -> forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
ex
            [JExpr
e1,JExpr
e2] -> forall a. Monoid a => [a] -> a
mconcat
                        [ forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e1
                        , forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e2
                        ]
            (JExpr
ex:[JExpr]
es)  -> forall a. Monoid a => [a] -> a
mconcat
                        [ forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
ex
                        , forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr ([(FastString, JExpr)] -> JVal
jhFromList (forall a b. [a] -> [b] -> [(a, b)]
zip [FastString]
dataFieldNames [JExpr]
es))
                        ]
      | Bool
otherwise = case [JExpr]
es of
            []      -> forall a. Monoid a => a
mempty
            [JExpr
ex]    -> forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
ex
            [JExpr
e1,JExpr
e2] -> forall a. Monoid a => [a] -> a
mconcat
                        [ forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
e1
                        , forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr
e2
                        ]
            (JExpr
ex:[JExpr]
es)  -> forall a. Monoid a => [a] -> a
mconcat
                        [ forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
ex
                        , forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= [JExpr] -> JExpr
fillFun [JExpr]
es
                        ]

    fillFun :: [JExpr] -> JExpr
fillFun [] = JExpr
null_
    fillFun [JExpr]
es = JExpr -> [JExpr] -> JExpr
ApplExpr (Int -> JExpr
allocData (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es)) [JExpr]
es

    checkObjs :: JStat
checkObjs | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings  = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> [a] -> [b]
map (\(Ident
i,JExpr
_,[JExpr]
_,CostCentreStack
_) -> JExpr -> [JExpr] -> JStat
ApplStat (JVal -> JExpr
ValExpr (Ident -> JVal
JVar (FastString -> Ident
TxtI FastString
"h$checkObj"))) [forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i]) [(Ident, JExpr, [JExpr], CostCentreStack)]
cls
              | Bool
otherwise = forall a. Monoid a => a
mempty

  JStat
objs <- G JStat
makeObjs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [JStat
objs, JStat
middle', JStat
fillObjs, JStat
checkObjs]

-- | Generate a primop. This function wraps around the real generator
-- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before
-- generating the primop.
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t = do
  [JExpr]
as <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JExpr]
genArg [StgArg]
args
  Bool
prof <- StgToJSConfig -> Bool
csProf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
  Bool
bound <- StgToJSConfig -> Bool
csBoundsCheck forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
  -- fixme: should we preserve/check the primreps?
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Bool -> Bool -> Type -> PrimOp -> [JExpr] -> [JExpr] -> PrimRes
genPrim Bool
prof Bool
bound Type
t PrimOp
op (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JExpr]
as of
             PrimInline JStat
s -> (JStat
s, Maybe [JExpr] -> ExprResult
ExprInline forall a. Maybe a
Nothing)
             PRPrimCall JStat
s -> (JStat
s, ExprResult
ExprCont)