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

-----------------------------------------------------------------------------
-- |
-- 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.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.JS.Transform
import GHC.JS.Make
import GHC.JS.Ident

import GHC.StgToJS.Apply
import GHC.StgToJS.Arg
import GHC.StgToJS.Closure
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.Utils
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids

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.Types.Literal

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

import GHC.Builtin.PrimOps
import GHC.Builtin.Names

import GHC.Core hiding (Var)
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.Encoding
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified GHC.Types.Unique.Map as UM

import qualified GHC.Data.List.SetOps as ListSetOps

import Data.Monoid
import Data.Maybe
import Data.Function
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 (JStgStat, ExprResult)
genExpr :: HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
stg = case CgStgExpr
stg of
  StgApp Id
f [StgArg]
args -> HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
genApp ExprCtx
ctx Id
f [StgArg]
args
  StgLit Literal
l      -> do
    [JStgExpr]
ls <- HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l
    let r :: JStgStat
r = ExprCtx -> [JStgExpr] -> JStgStat
assignToExprCtx ExprCtx
ctx [JStgExpr]
ls
    (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat
r,ExprResult
ExprInline)
  StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [[PrimRep]]
_ -> do
    [JStgExpr]
as <- (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
    JStgStat
c <- ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
genCon ExprCtx
ctx DataCon
con [JStgExpr]
as
    (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
c, ExprResult
ExprInline)
  StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
args Type
t
    -> HasDebugCallStack =>
ExprCtx
-> ForeignCall
-> Type
-> [JStgExpr]
-> [StgArg]
-> G (JStgStat, ExprResult)
ExprCtx
-> ForeignCall
-> Type
-> [JStgExpr]
-> [StgArg]
-> G (JStgStat, ExprResult)
genForeignCall ExprCtx
ctx ForeignCall
f Type
t ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
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 (JStgStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t
  StgOpApp (StgPrimCallOp PrimCall
c) [StgArg]
args Type
t
    -> ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, 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 (JStgStat, ExprResult)
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ExprCtx
ctx Id
BinderP 'CodeGen
b CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts (LiveVars -> LiveVars
liveVars (LiveVars -> 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
    (JStgStat
b',ExprCtx
ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
b
    (JStgStat
s,ExprResult
r)     <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
    (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
b' JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
s, ExprResult
r)
  StgLetNoEscape XLetNoEscape 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
    (JStgStat
b', ExprCtx
ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
b
    (JStgStat
s, ExprResult
r)     <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
    (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
b' JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
s, ExprResult
r)
  StgTick (ProfNote CostCentre
cc Bool
count Bool
scope) CgStgExpr
e -> do
    JStgStat
setSCCstats <- G JStgStat -> G JStgStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStgStat -> G JStgStat) -> G JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ CostCentre -> Bool -> Bool -> G JStgStat
setCC CostCentre
cc Bool
count Bool
scope
    (JStgStat
stats, ExprResult
result) <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e
    (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
setSCCstats JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
stats, ExprResult
result)
  StgTick (SourceNote RealSrcSpan
span LexicalFastString
_sname) CgStgExpr
e
    -> HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr (RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan RealSrcSpan
span ExprCtx
ctx) CgStgExpr
e
  StgTick GenTickish 'TickishPassStg
_m CgStgExpr
e
    -> HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e

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

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

genBindLne :: HasDebugCallStack
           => ExprCtx
           -> CgStgBinding
           -> G (JStgStat, ExprCtx)
genBindLne :: HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, 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  <- ((Id, Int, Bool) -> (Id, Int)) -> [(Id, Int, Bool)] -> [(Id, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
y,Bool
_) -> (Id
x,Int
y)) ([(Id, Int, Bool)] -> [(Id, Int)])
-> StateT GenState IO [(Id, Int, Bool)]
-> StateT GenState IO [(Id, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
HasDebugCallStack =>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
oldFrameSize ([Id]
newLvs[Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
updBinds)
  -- initialize updatable bindings to null_
  JStgStat
declUpds <- [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'CodeGen) -> G JStgStat)
-> [(Id, GenStgRhs 'CodeGen)] -> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Ident -> JStgStat) -> StateT GenState IO Ident -> G JStgStat
forall a b.
(a -> b) -> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ident -> JStgExpr -> JStgStat
||= JStgExpr
null_) (StateT GenState IO Ident -> G JStgStat)
-> ((Id, GenStgRhs 'CodeGen) -> StateT GenState IO Ident)
-> (Id, GenStgRhs 'CodeGen)
-> G JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> StateT GenState IO Ident
identForId (Id -> StateT GenState IO Ident)
-> ((Id, GenStgRhs 'CodeGen) -> Id)
-> (Id, GenStgRhs 'CodeGen)
-> StateT GenState IO Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> Id
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
  ((Id, GenStgRhs 'CodeGen) -> G ())
-> [(Id, GenStgRhs 'CodeGen)] -> G ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Id -> GenStgRhs 'CodeGen -> G ())
-> (Id, GenStgRhs 'CodeGen) -> G ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Id -> GenStgRhs 'CodeGen -> G ())
 -> (Id, GenStgRhs 'CodeGen) -> G ())
-> (Id -> GenStgRhs 'CodeGen -> G ())
-> (Id, GenStgRhs 'CodeGen)
-> G ()
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntryLne ExprCtx
ctx') [(Id, GenStgRhs 'CodeGen)]
binds
  (JStgStat, ExprCtx) -> G (JStgStat, ExprCtx)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
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 (LiveVars -> LiveVars) -> LiveVars -> LiveVars
forall a b. (a -> b) -> a -> b
$ [Id] -> LiveVars
mkDVarSet ([Id] -> LiveVars) -> [Id] -> LiveVars
forall a b. (a -> b) -> a -> b
$ GenStgBinding 'CodeGen -> [Id]
stgLneLive' GenStgBinding 'CodeGen
bndr
    newLvs :: [Id]
newLvs       = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
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 -> [(Id
BinderP 'CodeGen
b,GenStgRhs 'CodeGen
e)]
              StgRec    [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs  -> [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
    bound :: [Id]
bound = ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
binds
    ([(Id, GenStgRhs 'CodeGen)]
updBinds, [(Id, GenStgRhs 'CodeGen)]
_nonUpdBinds) = ((Id, GenStgRhs 'CodeGen) -> Bool)
-> [(Id, GenStgRhs 'CodeGen)]
-> ([(Id, GenStgRhs 'CodeGen)], [(Id, GenStgRhs 'CodeGen)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (GenStgRhs 'CodeGen -> Bool
isUpdatableRhs (GenStgRhs 'CodeGen -> Bool)
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
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 Type
typ) =
  G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
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    =
        Int -> ((Int, (Id, Int)) -> Int) -> Maybe (Int, (Id, Int)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int
forall a. HasCallStack => String -> a
panic String
"genEntryLne: updatable binder not found in let-no-escape frame")
              ((Int
payloadSize-) (Int -> Int)
-> ((Int, (Id, Int)) -> Int) -> (Int, (Id, Int)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Id, Int)) -> Int
forall a b. (a, b) -> a
fst)
              (((Int, (Id, Int)) -> Bool)
-> [(Int, (Id, Int))] -> Maybe (Int, (Id, Int))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
i) (Id -> Bool)
-> ((Int, (Id, Int)) -> Id) -> (Int, (Id, Int)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Int) -> Id
forall a b. (a, b) -> a
fst ((Id, Int) -> Id)
-> ((Int, (Id, Int)) -> (Id, Int)) -> (Int, (Id, Int)) -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Id, Int)) -> (Id, Int)
forall a b. (a, b) -> b
snd) ([Int] -> [(Id, Int)] -> [(Int, (Id, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Id, Int)]
vars))
      mk_bh :: G JStgStat
      mk_bh :: G JStgStat
mk_bh | UpdateFlag -> Bool
isUpdatable UpdateFlag
update =
              do Ident
x <- StateT GenState IO Ident
freshIdent
                 JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                   [ Ident
x Ident -> JStgExpr -> JStgStat
||= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (FastString -> JStgExpr
var FastString
"h$bh_lne") [JStgExpr -> JStgExpr -> JStgExpr
Sub JStgExpr
sp (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
myOffset), Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
payloadSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)]
                   , JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat (Ident -> JStgExpr
Var Ident
x) (JStgExpr -> JStgStat
ReturnStat (Ident -> JStgExpr
Var Ident
x)) JStgStat
forall a. Monoid a => a
mempty
                   ]
            | Bool
otherwise = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
  JStgStat
blk_hl <- G JStgStat
mk_bh
  JStgStat
locals <- Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
  JStgStat
body   <- HasDebugCallStack =>
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
genBody ExprCtx
ctx StgReg
R1 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body Type
typ
  ei :: Ident
ei@(Ident -> FastString
identFS -> FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  CIStatic
sr   <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
  let f :: JStgStat
f = (JStgStat
blk_hl JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
locals JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
body)
  ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$
    Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
                (Int -> [JSRep] -> CIRegs
CIRegs Int
0 ([JSRep] -> CIRegs) -> [JSRep] -> CIRegs
forall a b. (a -> b) -> a -> b
$ (Id -> [JSRep]) -> [Id] -> [JSRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep [Id]
[BinderP 'CodeGen]
args)
                (FastString
eii FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
", " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i)))
                ([JSRep] -> CILayout
fixedLayout ([JSRep] -> CILayout)
-> ([JSRep] -> [JSRep]) -> [JSRep] -> CILayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSRep] -> [JSRep]
forall a. [a] -> [a]
reverse ([JSRep] -> CILayout) -> [JSRep] -> CILayout
forall a b. (a -> b) -> a -> b
$
                    ((Id, Int) -> JSRep) -> [(Id, Int)] -> [JSRep]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> JSRep
stackSlotType (Id -> JSRep) -> ((Id, Int) -> Id) -> (Id, Int) -> JSRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Int) -> Id
forall a b. (a, b) -> a
fst) (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx))
                CIType
CIStackFrame
                CIStatic
sr
  JStgStat -> G ()
emitToplevel (Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
ei [] JStgStat
f)
genEntryLne ExprCtx
ctx Id
i (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
args Type
_typ) = G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
forall a b. (a -> b) -> a -> b
$ do
  let payloadSize :: Int
payloadSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
  Ident
ei <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  -- di <- varForDataConWorker con
  Ident
ii <- StateT GenState IO Ident
freshIdent
  JStgStat
p  <- Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
  [JStgExpr]
args' <- (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
  JStgStat
ac    <- Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon Ident
ii DataCon
con CostCentreStack
cc [JStgExpr]
args'
  JStgStat -> G ()
emitToplevel (Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
ei [] ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [Ident -> JStgStat
decl Ident
ii, JStgStat
p, JStgStat
ac, JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
ii, JStgStat
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 {} = () -> G ()
forall a. a -> StateT GenState IO a
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 Type
typ) = G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
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
  JStgStat
ll    <- [Id] -> G JStgStat
loadLiveFun [Id]
live
  JStgStat
llv   <- [Id] -> G JStgStat
HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps [Id]
live
  JStgStat
upd   <- UpdateFlag -> Id -> G JStgStat
genUpdFrame UpdateFlag
upd_flag Id
i
  JStgStat
body  <- HasDebugCallStack =>
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
genBody ExprCtx
entryCtx StgReg
R2 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body Type
typ
  ei :: Ident
ei@(Ident -> FastString
identFS -> FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
  CIType
et    <- [Id] -> G CIType
HasDebugCallStack => [Id] -> G CIType
genEntryType [Id]
[BinderP 'CodeGen]
args
  JStgStat
setcc <- JStgStat -> G JStgStat
forall m. Monoid m => m -> G m
ifProfiling (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$
             if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
               then JStgStat
enterCostCentreThunk
               else CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
cc
  CIStatic
sr <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
  ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$ Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
                                (Int -> [JSRep] -> CIRegs
CIRegs Int
0 ([JSRep] -> CIRegs) -> [JSRep] -> CIRegs
forall a b. (a -> b) -> a -> b
$ JSRep
PtrV JSRep -> [JSRep] -> [JSRep]
forall a. a -> [a] -> [a]
: (Id -> [JSRep]) -> [Id] -> [JSRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep [Id]
[BinderP 'CodeGen]
args)
                                (FastString
eii FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
", " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i)))
                                ([JSRep] -> CILayout
fixedLayout ([JSRep] -> CILayout) -> [JSRep] -> CILayout
forall a b. (a -> b) -> a -> b
$ (Id -> JSRep) -> [Id] -> [JSRep]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Type -> JSRep
Type -> JSRep
unaryTypeJSRep (Type -> JSRep) -> (Id -> Type) -> Id -> JSRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
live)
                                CIType
et
                                CIStatic
sr
  JStgStat -> G ()
emitToplevel (Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
ei [] ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat
ll, JStgStat
llv, JStgStat
upd, JStgStat
setcc, JStgStat
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'.
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType []   = CIType -> G CIType
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CIType
CIThunk
genEntryType [Id]
args = do
  [[JStgExpr]]
args' <- (Id -> G [JStgExpr]) -> [Id] -> StateT GenState IO [[JStgExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => Id -> G [JStgExpr]
Id -> G [JStgExpr]
genIdArg [Id]
args
  CIType -> G CIType
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CIType -> G CIType) -> CIType -> G CIType
forall a b. (a -> b) -> a -> b
$ Int -> Int -> CIType
CIFun ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JStgExpr] -> Int) -> [JStgExpr] -> Int
forall a b. (a -> b) -> a -> b
$ [[JStgExpr]] -> [JStgExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JStgExpr]]
args')

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

  -- assert that arguments have valid runtime reps
  JStgStat
lav <- [Id] -> G JStgStat
HasDebugCallStack => [Id] -> G JStgStat
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 => Type -> [(PrimRep, Int)]
Type -> [(PrimRep, Int)]
resultSize Type
typ

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

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

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

  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgStat
la JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
lav JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
e JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
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 typePrimRep) 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 => Type -> [(PrimRep, Int)]
resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)]
resultSize Type
ty = [(PrimRep, Int)]
result
  where
    result :: [(PrimRep, Int)]
result       = [PrimRep]
result_reps [PrimRep] -> [Int] -> [(PrimRep, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int]
result_slots
    result_slots :: [Int]
result_slots = (PrimRep -> Int) -> [PrimRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotCount -> Int
slotCount (SlotCount -> Int) -> (PrimRep -> SlotCount) -> PrimRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> SlotCount
primRepSize) [PrimRep]
result_reps
    result_reps :: [PrimRep]
result_reps  = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty

-- | 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 JStgStat
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps [Id]
xs = do
  Bool
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  if Bool -> Bool
not Bool
runtime_assert
    then JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
    else [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G JStgStat) -> [Id] -> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> G JStgStat
verifyRuntimeRep [Id]
xs
  where
    verifyRuntimeRep :: Id -> G JStgStat
verifyRuntimeRep Id
i = do
      [JStgExpr]
i' <- Id -> G [JStgExpr]
varsForId Id
i
      JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
i' (HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep Id
i)
    go :: [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js         (JSRep
VoidV:[JSRep]
vs) = [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
    go (JStgExpr
j1:JStgExpr
j2:[JStgExpr]
js) (JSRep
LongV:[JSRep]
vs) = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_long" [JStgExpr
j1,JStgExpr
j2] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
    go (JStgExpr
j1:JStgExpr
j2:[JStgExpr]
js) (JSRep
AddrV:[JSRep]
vs) = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_addr" [JStgExpr
j1,JStgExpr
j2] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
    go (JStgExpr
j:[JStgExpr]
js)     (JSRep
v:[JSRep]
vs)     = JStgExpr -> JSRep -> JStgStat
ver JStgExpr
j JSRep
v                       JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
    go []         []         = JStgStat
forall a. Monoid a => a
mempty
    go [JStgExpr]
_          [JSRep]
_          = String -> SDoc -> JStgStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"verifyRuntimeReps: inconsistent sizes" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
xs)
    ver :: JStgExpr -> JSRep -> JStgStat
ver JStgExpr
j JSRep
PtrV    = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_heapobj" [JStgExpr
j]
    ver JStgExpr
j JSRep
IntV    = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_int"     [JStgExpr
j]
    ver JStgExpr
j JSRep
DoubleV = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_double"  [JStgExpr
j]
    ver JStgExpr
j JSRep
ArrV    = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_arr"     [JStgExpr
j]
    ver JStgExpr
_ JSRep
_       = JStgStat
forall a. Monoid a => a
mempty
    v :: FastString -> [JStgExpr] -> JStgStat
v FastString
f [JStgExpr]
as = JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (FastString -> JStgExpr
var FastString
f) [JStgExpr]
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 JStgStat
loadLiveFun :: [Id] -> G JStgStat
loadLiveFun [Id]
l = do
   [Ident]
l' <- [[Ident]] -> [Ident]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Ident]] -> [Ident]) -> StateT GenState IO [[Ident]] -> G [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G [Ident]) -> [Id] -> StateT GenState IO [[Ident]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> G [Ident]
identsForId [Id]
l
   case [Ident]
l' of
     []  -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
     -- set the ident to d1 field of register 1
     [Ident
v] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_)
     -- set the idents to d1 and d2 fields of register 1
     [Ident
v1,Ident
v2] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                        [ Ident
v1 Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_
                        , Ident
v2 Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_
                        ]
     -- and so on
     (Ident
v:[Ident]
vs)  -> do
       Ident
d <- StateT GenState IO Ident
freshIdent
       let l'' :: JStgStat
l'' = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> ([Ident] -> [JStgStat]) -> [Ident] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Ident -> JStgStat) -> [Int] -> [Ident] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JStgExpr -> Int -> Ident -> JStgStat
loadLiveVar (JStgExpr -> Int -> Ident -> JStgStat)
-> JStgExpr -> Int -> Ident -> JStgStat
forall a b. (a -> b) -> a -> b
$ Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
d) [(Int
1::Int)..] ([Ident] -> JStgStat) -> [Ident] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [Ident]
vs
       JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
               [ Ident
v Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_
               , Ident
d Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_
               , JStgStat
l''
               ]
  where
        loadLiveVar :: JStgExpr -> Int -> Ident -> JStgStat
loadLiveVar JStgExpr
d Int
n Ident
v = let ident :: Ident
ident = FastString -> Ident
global (Int -> FastString
dataFieldName Int
n)
                            in  Ident
v Ident -> JStgExpr -> JStgStat
||= JStgExpr -> Ident -> JStgExpr
SelExpr JStgExpr
d Ident
ident

-- | Pop a let-no-escape frame off the stack
popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat
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 [Ident] -> Int -> Ident
forall a. HasCallStack => [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        (Ident, StackSlot) -> StateT GenState IO (Ident, StackSlot)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ident
id_n, Id -> Int -> StackSlot
SlotId Id
i Int
n)

  [(Ident, StackSlot)]
is <- ((Id, Int) -> StateT GenState IO (Ident, StackSlot))
-> [(Id, Int)] -> StateT GenState IO [(Ident, StackSlot)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, 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 JStgStat
popSkipI Int
skip [(Ident, StackSlot)]
is

-- | Generate an updated given an 'Id'
genUpdFrame :: UpdateFlag -> Id -> G JStgStat
genUpdFrame :: UpdateFlag -> Id -> G JStgStat
genUpdFrame UpdateFlag
u Id
i
  | UpdateFlag -> Bool
isReEntrant UpdateFlag
u   = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
  | Id -> Bool
isOneShotBndr Id
i = G JStgStat
maybeBh
  | UpdateFlag -> Bool
isUpdatable UpdateFlag
u   = G JStgStat
updateThunk
  | Bool
otherwise       = G JStgStat
maybeBh
  where
    isReEntrant :: UpdateFlag -> Bool
isReEntrant UpdateFlag
ReEntrant = Bool
True
    isReEntrant UpdateFlag
_         = Bool
False
    maybeBh :: G JStgStat
maybeBh = do
      StgToJSConfig
settings <- StateT GenState IO StgToJSConfig
getSettings
      G JStgStat -> G JStgStat
assertRtsStat (JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> JStgStat
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 -> JStgStat
bhSingleEntry :: StgToJSConfig -> JStgStat
bhSingleEntry StgToJSConfig
_settings = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
  [ JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureEntry_  JStgExpr -> JStgExpr -> JStgStat
|= FastString -> JStgExpr
var FastString
"h$blackholeTrap"
  , JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_ JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
undefined_
  , JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_ JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
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 = CIStatic -> G CIStatic
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FastString] -> CIStatic
CIStaticRefs [])
  | Bool
otherwise         = do
      UniqFM Id CgStgExpr
unfloated <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
      let xs :: [Id]
xs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Id
x -> Bool -> Bool
not (Id -> UniqFM Id CgStgExpr -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Id
x UniqFM Id CgStgExpr
unfloated Bool -> Bool -> Bool
||
                                  Type -> Bool
definitelyUnliftedType (Id -> Type
idType Id
x)))
                      (LiveVars -> [Id]
dVarSetElems LiveVars
sv)
      [FastString] -> CIStatic
CIStaticRefs ([FastString] -> CIStatic)
-> ([Maybe FastString] -> [FastString])
-> [Maybe FastString]
-> CIStatic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FastString] -> [FastString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FastString] -> CIStatic)
-> StateT GenState IO [Maybe FastString] -> G CIStatic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> StateT GenState IO (Maybe FastString))
-> [Id] -> StateT GenState IO [Maybe FastString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> StateT GenState IO (Maybe FastString)
getStaticRef [Id]
xs
  where
    sv :: LiveVars
sv = LiveVars -> LiveVars
liveStatic LiveVars
lv

    getStaticRef :: Id -> G (Maybe FastString)
    getStaticRef :: Id -> StateT GenState IO (Maybe FastString)
getStaticRef = ([Ident] -> Maybe FastString)
-> G [Ident] -> StateT GenState IO (Maybe FastString)
forall a b.
(a -> b) -> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ident -> FastString) -> Maybe Ident -> Maybe FastString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> FastString
identFS (Maybe Ident -> Maybe FastString)
-> ([Ident] -> Maybe Ident) -> [Ident] -> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Maybe Ident
forall a. [a] -> Maybe a
listToMaybe) (G [Ident] -> StateT GenState IO (Maybe FastString))
-> (Id -> G [Ident]) -> Id -> StateT GenState IO (Maybe FastString)
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] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
offset [Id]
ids = do
  -- this line goes wrong                               vvvvvvv
  let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids
      idSize :: Id -> Int
      idSize :: Id -> Int
idSize Id
i = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (JSRep -> Int) -> [JSRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map JSRep -> Int
varSize (HasDebugCallStack => Type -> [JSRep]
Type -> [JSRep]
typeJSRep (Type -> [JSRep]) -> (Id -> Type) -> Id -> [JSRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> [JSRep]) -> Id -> [JSRep]
forall a b. (a -> b) -> a -> b
$ Id
i)
      ids' :: [(Id, Int)]
ids' = (Id -> [(Id, Int)]) -> [Id] -> [(Id, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Id
i -> (Int -> (Id, Int)) -> [Int] -> [(Id, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Id
i,) [Int
1..Id -> Int
idSize Id
i]) [Id]
ids
      -- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids)
      l :: Int
l    = [(Id, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, Int)]
ids'
  [StackSlot]
slots <- Int -> [StackSlot] -> [StackSlot]
forall a. Int -> [a] -> [a]
drop Int
offset ([StackSlot] -> [StackSlot])
-> ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [StackSlot] -> [StackSlot]
forall a. Int -> [a] -> [a]
take Int
l ([StackSlot] -> [StackSlot])
-> ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++StackSlot -> [StackSlot]
forall a. a -> [a]
repeat StackSlot
SlotUnknown) ([StackSlot] -> [StackSlot])
-> StateT GenState IO [StackSlot] -> StateT GenState IO [StackSlot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO [StackSlot]
getSlots
  let slm :: Map StackSlot Int
slm                = [(StackSlot, Int)] -> Map StackSlot Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([StackSlot] -> [Int] -> [(StackSlot, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [StackSlot]
slots [Int
0..])
      ([(Id, Int)]
remaining, [(Id, Int, Int, Bool)]
fixed) = ((Id, Int) -> Either (Id, Int) (Id, Int, Int, Bool))
-> [(Id, Int)] -> ([(Id, Int)], [(Id, Int, Int, Bool)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (\inp :: (Id, Int)
inp@(Id
i,Int
n) -> Either (Id, Int) (Id, Int, Int, Bool)
-> (Int -> Either (Id, Int) (Id, Int, Int, Bool))
-> Maybe Int
-> Either (Id, Int) (Id, Int, Int, Bool)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Id, Int) -> Either (Id, Int) (Id, Int, Int, Bool)
forall a b. a -> Either a b
Left (Id, Int)
inp)
                                                              (\Int
j -> (Id, Int, Int, Bool) -> Either (Id, Int) (Id, Int, Int, Bool)
forall a b. b -> Either a b
Right (Id
i,Int
n,Int
j,Bool
True))
                                                              (StackSlot -> Map StackSlot Int -> Maybe Int
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         = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList (((Id, Int, Int, Bool) -> Int) -> [(Id, Int, Int, Bool)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
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          = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Int
takenSlots) [Int
0..Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
      remaining' :: [(Id, Int, Int, Bool)]
remaining'         = ((Id, Int) -> Int -> (Id, Int, Int, Bool))
-> [(Id, Int)] -> [Int] -> [(Id, Int, Int, Bool)]
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           = ((Id, Int, Int, Bool) -> (Id, Int, Int, Bool) -> Ordering)
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Int, Bool)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Id, Int, Int, Bool) -> Int)
-> (Id, Int, Int, Bool)
-> (Id, Int, Int, Bool)
-> Ordering
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 [(Id, Int, Int, Bool)]
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Int, Bool)]
forall a. [a] -> [a] -> [a]
++ [(Id, Int, Int, Bool)]
remaining')
  [(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)])
-> [(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)]
forall a b. (a -> b) -> a -> b
$ ((Id, Int, Int, Bool) -> (Id, Int, Bool))
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Bool)]
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 JStgStat -> [(Id, CgStgRhs)] -> G JStgStat
allocCls :: Maybe JStgStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStgStat
allocCls Maybe JStgStat
dynMiddle [(Id, GenStgRhs 'CodeGen)]
xs = do
   ([JStgStat]
stat, [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
dyn) <- ((Id, GenStgRhs 'CodeGen)
 -> StateT
      GenState
      IO
      (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)))
-> [(Id, GenStgRhs 'CodeGen)]
-> StateT
     GenState
     IO
     ([JStgStat], [(Ident, JStgExpr, [JStgExpr], CostCentreStack)])
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (Either b c)) -> [a] -> m ([b], [c])
partitionWithM (Id, GenStgRhs 'CodeGen)
-> StateT
     GenState
     IO
     (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
toCl [(Id, GenStgRhs 'CodeGen)]
xs
   JStgStat
ac <- Bool
-> Maybe JStgStat
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
-> G JStgStat
allocDynAll Bool
False Maybe JStgStat
dynMiddle [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
dyn
   JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat]
stat JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
ac)
  where
    -- left = static, right = dynamic
    toCl :: (Id, CgStgRhs)
         -> G (Either JStgStat (Ident,JStgExpr,[JStgExpr],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)
-> StateT
     GenState
     IO
     (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mui [GenTickish 'TickishPassStg]
_ticjs [StgArg
a] Type
_typ) | DataCon -> Bool
isUnboxableCon DataCon
con = do
      Ident
ii <- Id -> StateT GenState IO Ident
identForId Id
i
      JStgStat
ac <- Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon Ident
ii DataCon
con CostCentreStack
cc ([JStgExpr] -> G JStgStat) -> G [JStgExpr] -> G JStgStat
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg StgArg
a
      Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> StateT
     GenState
     IO
     (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b. a -> Either a b
Left (Ident -> JStgStat
decl Ident
ii JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
ac))

    -- dynamics
    toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
ar Type
_typ) =
      -- fixme do we need to handle unboxed?
      (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JStgExpr, [JStgExpr], CostCentreStack)
 -> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT
     GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> StateT
     GenState
     IO
     (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
 -> JStgExpr
 -> [JStgExpr]
 -> CostCentreStack
 -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
     GenState
     IO
     (JStgExpr
      -> [JStgExpr]
      -> CostCentreStack
      -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
                       StateT
  GenState
  IO
  (JStgExpr
   -> [JStgExpr]
   -> CostCentreStack
   -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO JStgExpr
-> StateT
     GenState
     IO
     ([JStgExpr]
      -> CostCentreStack
      -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DataCon -> StateT GenState IO JStgExpr
varForDataConWorker DataCon
con
                       StateT
  GenState
  IO
  ([JStgExpr]
   -> CostCentreStack
   -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> G [JStgExpr]
-> StateT
     GenState
     IO
     (CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
ar
                       StateT
  GenState
  IO
  (CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT
     GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CostCentreStack -> StateT GenState IO CostCentreStack
forall a. a -> StateT GenState IO a
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 Type
_typ)) =
      let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
cl
      in  (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JStgExpr, [JStgExpr], CostCentreStack)
 -> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT
     GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> StateT
     GenState
     IO
     (Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
 -> JStgExpr
 -> [JStgExpr]
 -> CostCentreStack
 -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
     GenState
     IO
     (JStgExpr
      -> [JStgExpr]
      -> CostCentreStack
      -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
                       StateT
  GenState
  IO
  (JStgExpr
   -> [JStgExpr]
   -> CostCentreStack
   -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO JStgExpr
-> StateT
     GenState
     IO
     ([JStgExpr]
      -> CostCentreStack
      -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> StateT GenState IO JStgExpr
varForEntryId Id
i
                       StateT
  GenState
  IO
  ([JStgExpr]
   -> CostCentreStack
   -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> G [JStgExpr]
-> StateT
     GenState
     IO
     (CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Id -> G [JStgExpr]) -> [Id] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JStgExpr]
varsForId [Id]
live
                       StateT
  GenState
  IO
  (CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT
     GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CostCentreStack -> StateT GenState IO CostCentreStack
forall a. a -> StateT GenState IO a
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 (JStgStat, ExprResult)
genCase :: HasDebugCallStack =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ExprCtx
ctx Id
bnd CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
  -- For:      unpackCStringAppend# "some string"# str
  -- Generate: h$appendToHsStringA(str, "some string")
  --
  -- The latter has a faster decoding loop.
  --
  -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we
  -- need to match the following instead:
  --
  --    case "some string"# of b {
  --      DEFAULT -> unpackCStringAppend# b str
  --    }
  --
  -- Wrinkle: it doesn't kick in when literals are floated out to the top level.
  --
  | StgLit (LitString ByteString
bs) <- CgStgExpr
e
  , [GenStgAlt AltCon
DEFAULT [BinderP 'CodeGen]
_ CgStgExpr
rhs] <- [GenStgAlt 'CodeGen]
alts
  , StgApp Id
i [StgArg]
args <- CgStgExpr
rhs
  , Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
  , [StgVarArg Id
b',StgArg
x] <- [StgArg]
args
  , Id
bnd Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b'
  , String
d <- ByteString -> String
utf8DecodeByteString ByteString
bs
  , [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
  = do
      Bool
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
      let profArg :: [JStgExpr]
profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
      [JStgExpr]
a <- HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg StgArg
x
      (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( JStgExpr
top JStgExpr -> JStgExpr -> JStgStat
|= FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$appendToHsStringA" (String -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr String
d JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr]
a [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a] -> [a]
++ [JStgExpr]
profArg)
             , ExprResult
ExprInline
             )

  | CgStgExpr -> Bool
isInlineExpr CgStgExpr
e = do
      [Ident]
bndi <- Id -> G [Ident]
identsForId Id
bnd
      let ctx' :: ExprCtx
ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
                  (ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JStgExpr] -> [TypedExpr]
assocIdExprs Id
bnd ((Ident -> JStgExpr) -> [Ident] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [Ident]
bndi))
                  (ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
      (JStgStat
ej, ExprResult
r) <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
      Bool -> G ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (ExprResult
r ExprResult -> ExprResult -> Bool
forall a. Eq a => a -> a -> Bool
== ExprResult
ExprInline)

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

genRet :: HasDebugCallStack
       => ExprCtx
       -> Id
       -> AltType
       -> [CgStgAlt]
       -> LiveVars
       -> G JStgStat
genRet :: HasDebugCallStack =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStgStat
genRet ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
as LiveVars
l = StateT GenState IO Ident
freshIdent StateT GenState IO Ident -> (Ident -> G JStgStat) -> G JStgStat
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ident -> G JStgStat
f
  where
    allRefs :: [Id]
    allRefs :: [Id]
allRefs =  Set Id -> [Id]
forall a. Set a -> [a]
S.toList (Set Id -> [Id]) -> ([Set Id] -> Set Id) -> [Set Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Id] -> Set Id
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Id] -> [Id]) -> [Set Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ (GenStgAlt 'CodeGen -> Set Id) -> [GenStgAlt 'CodeGen] -> [Set Id]
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 UniqFM Id CgStgExpr
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM (CgStgExpr -> Set Id)
-> (GenStgAlt 'CodeGen -> CgStgExpr)
-> GenStgAlt 'CodeGen
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs) [GenStgAlt 'CodeGen]
as
    lneLive :: Int
    lneLive :: Int
lneLive    = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ((Id -> Maybe Int) -> [Id] -> [Maybe Int]
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    = ((Id, Int) -> Id) -> [(Id, Int)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Int) -> Id
forall a b. (a, b) -> a
fst ([(Id, Int)] -> [Id]) -> [(Id, Int)] -> [Id]
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     = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isLne) (LiveVars -> [Id]
dVarSetElems LiveVars
l)

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

    altRegs :: HasDebugCallStack => [JSRep]
    altRegs :: HasDebugCallStack => [JSRep]
altRegs = case AltType
at of
      PrimAlt PrimRep
ptc    -> [HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep PrimRep
ptc]
      MultiValAlt Int
_n -> HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep Id
e
      AltType
_              -> [JSRep
PtrV]

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

    fun :: [(Id, Int, Bool)] -> G JStgStat
fun [(Id, Int, Bool)]
free = G JStgStat -> G JStgStat
forall a. G a -> G a
resetSlots (G JStgStat -> G JStgStat) -> G JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ do
      JStgStat
decs          <- Id -> G JStgStat
declVarsForId Id
e
      JStgStat
load          <- ([JStgExpr] -> [JStgExpr] -> JStgStat)
-> [JStgExpr] -> [JStgExpr] -> JStgStat
forall a b c. (a -> b -> c) -> b -> a -> c
flip [JStgExpr] -> [JStgExpr] -> JStgStat
assignAll ((StgReg -> JStgExpr) -> [StgReg] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [StgReg
R1 ..]) ([JStgExpr] -> JStgStat)
-> ([Ident] -> [JStgExpr]) -> [Ident] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> JStgExpr) -> [Ident] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ([Ident] -> JStgStat) -> G [Ident] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
e
      JStgStat
loadv         <- [Id] -> G JStgStat
HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps [Id
e]
      JStgStat
ras           <- [(Id, Int, Bool)] -> G JStgStat
HasDebugCallStack => [(Id, Int, Bool)] -> G JStgStat
loadRetArgs [(Id, Int, Bool)]
free
      JStgStat
rasv          <- [Id] -> G JStgStat
HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps (((Id, Int, Bool) -> Id) -> [(Id, Int, Bool)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
_,Bool
_)->Id
x) [(Id, Int, Bool)]
free)
      JStgStat
restoreCCS    <- G JStgStat -> G JStgStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStgStat -> G JStgStat)
-> ([(JStgExpr, StackSlot)] -> G JStgStat)
-> [(JStgExpr, StackSlot)]
-> G JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JStgExpr, StackSlot)] -> G JStgStat
pop_handle_CCS ([(JStgExpr, StackSlot)] -> G JStgStat)
-> [(JStgExpr, StackSlot)] -> G JStgStat
forall a b. (a -> b) -> a -> b
$ (JStgExpr, StackSlot) -> [(JStgExpr, StackSlot)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgExpr
jCurrentCCS, StackSlot
SlotUnknown)
      JStgStat
rlne          <- Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame Bool
False Int
lneLive ExprCtx
ctx'
      JStgStat
rlnev         <- [Id] -> G JStgStat
HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps [Id]
lneVars
      (JStgStat
alts, ExprResult
_altr) <- HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> G (JStgStat, ExprResult)
ExprCtx
-> Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> G (JStgStat, ExprResult)
genAlts ExprCtx
ctx' Id
e AltType
at [GenStgAlt 'CodeGen]
as
      JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgStat
decs JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
load JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
loadv JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
ras JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
rasv JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
restoreCCS JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
rlne JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
rlnev JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
alts JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<>
               JStgStat
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
        -> [CgStgAlt]     -- ^ the alternatives
        -> G (JStgStat, ExprResult)
genAlts :: HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> G (JStgStat, ExprResult)
genAlts ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
alts = do
  (JStgStat
st, ExprResult
er) <- case AltType
at of

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

    PrimAlt PrimRep
_tc
      | [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
      -> do
        [JStgExpr]
ie       <- Id -> G [JStgExpr]
varsForId Id
e
        JStgStat
dids     <- [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G JStgStat) -> [Id] -> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> G JStgStat
declVarsForId [Id]
[BinderP 'CodeGen]
bs
        [JStgExpr]
bss      <- (Id -> G [JStgExpr]) -> [Id] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JStgExpr]
varsForId [Id]
[BinderP 'CodeGen]
bs
        (JStgStat
ej, ExprResult
er) <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
        (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
dids JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JStgExpr] -> JStgStat
assignAll [JStgExpr]
bss [JStgExpr]
ie JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
ej, ExprResult
er)

    PrimAlt PrimRep
tc
      -> do
        [JStgExpr]
ie <- Id -> G [JStgExpr]
varsForId Id
e
        (ExprResult
r, [Branch (Maybe [JStgExpr])]
bss) <- ExprCtx
-> [Branch (Maybe [JStgExpr])]
-> (ExprResult, [Branch (Maybe [JStgExpr])])
forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx ([Branch (Maybe [JStgExpr])]
 -> (ExprResult, [Branch (Maybe [JStgExpr])]))
-> StateT GenState IO [Branch (Maybe [JStgExpr])]
-> StateT GenState IO (ExprResult, [Branch (Maybe [JStgExpr])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           (GenStgAlt 'CodeGen
 -> StateT GenState IO (Branch (Maybe [JStgExpr])))
-> [GenStgAlt 'CodeGen]
-> StateT GenState IO [Branch (Maybe [JStgExpr])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT GenState IO (Branch (Maybe [JStgExpr]))
-> StateT GenState IO (Branch (Maybe [JStgExpr]))
forall a. G a -> G a
isolateSlots (StateT GenState IO (Branch (Maybe [JStgExpr]))
 -> StateT GenState IO (Branch (Maybe [JStgExpr])))
-> (GenStgAlt 'CodeGen
    -> StateT GenState IO (Branch (Maybe [JStgExpr])))
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JStgExpr]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> [JSRep]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JStgExpr]))
mkPrimIfBranch ExprCtx
ctx [HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep PrimRep
tc]) [GenStgAlt 'CodeGen]
alts
        [StackSlot] -> G ()
setSlots []
        (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkSw [JStgExpr]
ie [Branch (Maybe [JStgExpr])]
bss, ExprResult
r)

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

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

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

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

    AlgAlt TyCon
_tc -> do
        JStgExpr
ei <- Id -> StateT GenState IO JStgExpr
varForId Id
e
        (ExprResult
r, [Branch (Maybe JStgExpr)]
brs) <- ExprCtx
-> [Branch (Maybe JStgExpr)]
-> (ExprResult, [Branch (Maybe JStgExpr)])
forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx ([Branch (Maybe JStgExpr)]
 -> (ExprResult, [Branch (Maybe JStgExpr)]))
-> StateT GenState IO [Branch (Maybe JStgExpr)]
-> StateT GenState IO (ExprResult, [Branch (Maybe JStgExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (GenStgAlt 'CodeGen
 -> StateT GenState IO (Branch (Maybe JStgExpr)))
-> [GenStgAlt 'CodeGen]
-> StateT GenState IO [Branch (Maybe JStgExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StateT GenState IO (Branch (Maybe JStgExpr))
-> StateT GenState IO (Branch (Maybe JStgExpr))
forall a. G a -> G a
isolateSlots (StateT GenState IO (Branch (Maybe JStgExpr))
 -> StateT GenState IO (Branch (Maybe JStgExpr)))
-> (GenStgAlt 'CodeGen
    -> StateT GenState IO (Branch (Maybe JStgExpr)))
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
mkAlgBranch ExprCtx
ctx Id
e) [GenStgAlt 'CodeGen]
alts
        [StackSlot] -> G ()
setSlots []
        (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat
mkSwitch (JStgExpr
ei JStgExpr -> FastString -> JStgExpr
.^ FastString
"f" JStgExpr -> FastString -> JStgExpr
.^ FastString
"a") [Branch (Maybe JStgExpr)]
brs, ExprResult
r)

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

  JStgStat
ver <- HasDebugCallStack => Id -> AltType -> G JStgStat
Id -> AltType -> G JStgStat
verifyMatchRep Id
e AltType
at
  (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat
ver JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
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 JStgStat
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStgStat
verifyMatchRep Id
x AltType
alt = do
  Bool
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  if Bool -> Bool
not Bool
runtime_assert
    then JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
    else case AltType
alt of
      AlgAlt TyCon
tc -> do
        [JStgExpr]
ix <- Id -> G [JStgExpr]
varsForId Id
x
        JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (FastString -> JStgExpr
var FastString
"h$verify_match_alg") (JVal -> JStgExpr
ValExpr(FastString -> JVal
JStr(String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc))))JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[JStgExpr]
ix)
      AltType
_ -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
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 -> JStgStat
branch_stat   :: JStgStat
  , forall a. Branch a -> ExprResult
branch_result :: ExprResult
  }
  deriving (Branch a -> Branch a -> Bool
(Branch a -> Branch a -> Bool)
-> (Branch a -> Branch a -> Bool) -> Eq (Branch a)
forall a. Eq a => Branch a -> Branch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Branch a -> Branch a -> Bool
Eq,(forall a b. (a -> b) -> Branch a -> Branch b)
-> (forall a b. a -> Branch b -> Branch a) -> Functor Branch
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
$cfmap :: forall a b. (a -> b) -> Branch a -> Branch b
fmap :: forall a b. (a -> b) -> Branch a -> Branch b
$c<$ :: forall a b. a -> Branch b -> Branch a
<$ :: forall a b. a -> Branch b -> Branch a
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
    | (ExprResult -> Bool) -> [ExprResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ExprResult -> ExprResult -> Bool
forall a. Eq a => a -> a -> Bool
==ExprResult
ExprCont) ((Branch a -> ExprResult) -> [Branch a] -> [ExprResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) =
        (ExprResult
ExprCont, [Branch a]
brs)
    | [ExprResult] -> ExprResult
HasDebugCallStack => [ExprResult] -> ExprResult
branchResult ((Branch a -> ExprResult) -> [Branch a] -> [ExprResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) ExprResult -> ExprResult -> Bool
forall a. Eq a => a -> a -> Bool
== ExprResult
ExprCont =
        (ExprResult
ExprCont, (Branch a -> Branch a) -> [Branch a] -> [Branch a]
forall a b. (a -> b) -> [a] -> [b]
map Branch a -> Branch a
mkCont [Branch a]
brs)
    | Bool
otherwise =
        (ExprResult
ExprInline, [Branch a]
brs)
  where
    mkCont :: Branch a -> Branch a
mkCont Branch a
b = case Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result Branch a
b of
      ExprResult
ExprInline -> Branch a
b { branch_stat   = branch_stat b <> assignAll jsRegsFromR1
                                                                   (concatMap typex_expr $ ctxTarget ctx)
                      , branch_result = 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 :: [JStgExpr] -> [Id] -> Int -> G JStgStat
loadUbxTup :: [JStgExpr] -> [Id] -> Int -> G JStgStat
loadUbxTup [JStgExpr]
es [Id]
bs Int
_n = do
  [Ident]
bs' <- (Id -> G [Ident]) -> [Id] -> G [Ident]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [Ident]
identsForId [Id]
bs
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [Ident] -> [JStgExpr] -> JStgStat
declAssignAll [Ident]
bs' [JStgExpr]
es

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

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

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

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

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

  | Bool
otherwise = String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkSwitch: multiple default cases"
  where
    addBreak :: Branch (Maybe a) -> (a, JStgStat)
addBreak (Branch (Just a
c) JStgStat
s ExprResult
_) = (a
c, [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat
s, Maybe LexicalFastString -> JStgStat
BreakStat Maybe LexicalFastString
forall a. Maybe a
Nothing])
    addBreak Branch (Maybe a)
_                     = String -> (a, JStgStat)
forall a. HasCallStack => String -> a
panic String
"mkSwitch: addBreak"
    ([Branch (Maybe JStgExpr)]
n,[Branch (Maybe JStgExpr)]
d) = (Branch (Maybe JStgExpr) -> Bool)
-> [Branch (Maybe JStgExpr)]
-> ([Branch (Maybe JStgExpr)], [Branch (Maybe JStgExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Maybe JStgExpr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe JStgExpr -> Bool)
-> (Branch (Maybe JStgExpr) -> Maybe JStgExpr)
-> Branch (Maybe JStgExpr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch (Maybe JStgExpr) -> Maybe JStgExpr
forall a. Branch a -> a
branch_expr) [Branch (Maybe JStgExpr)]
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 :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkIfElse :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkIfElse [JStgExpr]
e [Branch (Maybe [JStgExpr])]
s = [Branch (Maybe [JStgExpr])] -> JStgStat
go ([Branch (Maybe [JStgExpr])] -> [Branch (Maybe [JStgExpr])]
forall a. [a] -> [a]
L.reverse [Branch (Maybe [JStgExpr])]
s)
    where
      go :: [Branch (Maybe [JStgExpr])] -> JStgStat
go = \case
        [Branch Maybe [JStgExpr]
_ JStgStat
s ExprResult
_]              -> JStgStat
s -- only one 'nothing' allowed
        (Branch (Just [JStgExpr]
e0) JStgStat
s ExprResult
_ : [Branch (Maybe [JStgExpr])]
xs) -> JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat ([JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq [JStgExpr]
e [JStgExpr]
e0) JStgStat
s ([Branch (Maybe [JStgExpr])] -> JStgStat
go [Branch (Maybe [JStgExpr])]
xs)
        [] -> String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: empty expression list"
        [Branch (Maybe [JStgExpr])]
_  -> String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: multiple DEFAULT cases"

-- | Wrapper to construct sequences of (===), e.g.,
--
-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2)
--
mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq [JStgExpr]
es1 [JStgExpr]
es2
  | [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es2 = (JStgExpr -> JStgExpr -> JStgExpr) -> [JStgExpr] -> JStgExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
LAndOp) ((JStgExpr -> JStgExpr -> JStgExpr)
-> [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
StrictEqOp) [JStgExpr]
es1 [JStgExpr]
es2)
  | Bool
otherwise                = String -> JStgExpr
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 JStgExpr))
mkAlgBranch :: ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
mkAlgBranch ExprCtx
top Id
d GenStgAlt 'CodeGen
alt
  | DataAlt DataCon
dc <- GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt
  , DataCon -> Bool
isUnboxableCon DataCon
dc
  , [BinderP 'CodeGen
b] <- GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt
  = do
    JStgExpr
idd  <- Id -> StateT GenState IO JStgExpr
varForId Id
d
    [Ident]
fldx <- Id -> G [Ident]
identsForId Id
BinderP 'CodeGen
b
    case [Ident]
fldx of
      [Ident
fld] -> do
        (JStgStat
ej, ExprResult
er) <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
        Branch (Maybe JStgExpr)
-> StateT GenState IO (Branch (Maybe JStgExpr))
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JStgExpr -> JStgStat -> ExprResult -> Branch (Maybe JStgExpr)
forall a. a -> JStgStat -> ExprResult -> Branch a
Branch Maybe JStgExpr
forall a. Maybe a
Nothing ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [Ident
fld Ident -> JStgExpr -> JStgStat
||= JStgExpr
idd, JStgStat
ej]) ExprResult
er)
      [Ident]
_ -> String -> StateT GenState IO (Branch (Maybe JStgExpr))
forall a. HasCallStack => String -> a
panic String
"mkAlgBranch: invalid size"

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

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

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

caseCond :: AltCon -> G (Maybe JStgExpr)
caseCond :: AltCon -> G (Maybe JStgExpr)
caseCond = \case
-- fixme use single tmp var for all branches
  AltCon
DEFAULT    -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStgExpr
forall a. Maybe a
Nothing
  DataAlt DataCon
da -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JStgExpr -> G (Maybe JStgExpr))
-> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> Int -> JStgExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
da)
  LitAlt Literal
l   -> HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l G [JStgExpr]
-> ([JStgExpr] -> G (Maybe JStgExpr)) -> G (Maybe JStgExpr)
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [JStgExpr
e] -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
e)
    [JStgExpr]
es  -> String -> SDoc -> G (Maybe JStgExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseCond: expected single-variable literal" ([JExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([JExpr] -> SDoc) -> [JExpr] -> SDoc
forall a b. (a -> b) -> a -> b
$ JStgExpr -> JExpr
jStgExprToJS (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JStgExpr]
es)

-- | Load parameters from constructor
loadParams :: JStgExpr -> [Id] -> G JStgStat
loadParams :: JStgExpr -> [Id] -> G JStgStat
loadParams JStgExpr
from [Id]
args = do
  [(Ident, Bool)]
as <- [[(Ident, Bool)]] -> [(Ident, Bool)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Ident, Bool)]] -> [(Ident, Bool)])
-> StateT GenState IO [[(Ident, Bool)]]
-> StateT GenState IO [(Ident, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> Bool -> StateT GenState IO [(Ident, Bool)])
-> [Id] -> [Bool] -> StateT GenState IO [[(Ident, Bool)]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Id
a Bool
u -> (Ident -> (Ident, Bool)) -> [Ident] -> [(Ident, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
u) ([Ident] -> [(Ident, Bool)])
-> G [Ident] -> StateT GenState IO [(Ident, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
a) [Id]
args [Bool]
use
  case [(Ident, Bool)]
as of
    []                 -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
    [(Ident
x,Bool
u)]            -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_) Ident
x  Bool
u
    [(Ident
x1,Bool
u1),(Ident
x2,Bool
u2)]  -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                            [ JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_) Ident
x1 Bool
u1
                            , JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_) Ident
x2 Bool
u2
                            ]
    ((Ident
x,Bool
u):[(Ident, Bool)]
xs)         -> do Ident
d <- StateT GenState IO Ident
freshIdent
                             JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
                               [ JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_) Ident
x Bool
u
                               , [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ Ident
d Ident -> JStgExpr -> JStgStat
||= JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_
                                         , JStgExpr -> [(Ident, Bool)] -> JStgStat
loadConVarsIfUsed (Ident -> JStgExpr
Var Ident
d) [(Ident, Bool)]
xs
                                         ]
                               ]
  where
    use :: [Bool]
use = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True -- fixme clean up

    loadIfUsed :: JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed JStgExpr
fr Ident
tgt Bool
True = Ident
tgt Ident -> JStgExpr -> JStgStat
||= JStgExpr
fr
    loadIfUsed  JStgExpr
_ Ident
_   Bool
_    = JStgStat
forall a. Monoid a => a
mempty

    loadConVarsIfUsed :: JStgExpr -> [(Ident, Bool)] -> JStgStat
loadConVarsIfUsed JStgExpr
fr [(Ident, Bool)]
cs = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ ((Ident, Bool) -> Int -> JStgStat)
-> [(Ident, Bool)] -> [Int] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ident, Bool) -> Int -> JStgStat
f [(Ident, Bool)]
cs [(Int
1::Int)..]
      where f :: (Ident, Bool) -> Int -> JStgStat
f (Ident
x,Bool
u) Int
n = JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr -> Ident -> JStgExpr
SelExpr JStgExpr
fr (FastString -> Ident
global (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
  []                   -> String -> ExprResult
forall a. HasCallStack => String -> a
panic String
"branchResult: empty list"
  [ExprResult
e]                  -> ExprResult
e
  (ExprResult
ExprCont:[ExprResult]
_)         -> ExprResult
ExprCont
  (ExprResult
_:[ExprResult]
es)
    | ExprResult -> [ExprResult] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExprResult
ExprCont [ExprResult]
es -> ExprResult
ExprCont
    | Bool
otherwise        -> ExprResult
ExprInline

-- | 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)] -> JStgExpr -> G JStgStat
pushRetArgs :: HasDebugCallStack => [(Id, Int, Bool)] -> JStgExpr -> G JStgStat
pushRetArgs [(Id, Int, Bool)]
free JStgExpr
fun = do
  [(JStgExpr, Bool)]
rs <- ((Id, Int, Bool) -> StateT GenState IO (JStgExpr, Bool))
-> [(Id, Int, Bool)] -> StateT GenState IO [(JStgExpr, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Id
i,Int
n,Bool
b) -> (\[JStgExpr]
es->([JStgExpr]
es[JStgExpr] -> Int -> JStgExpr
forall a. HasCallStack => [a] -> Int -> a
!!(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),Bool
b)) ([JStgExpr] -> (JStgExpr, Bool))
-> G [JStgExpr] -> StateT GenState IO (JStgExpr, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> G [JStgExpr]
Id -> G [JStgExpr]
genIdArg Id
i) [(Id, Int, Bool)]
free
  [(JStgExpr, Bool)] -> G JStgStat
pushOptimized ([(JStgExpr, Bool)]
rs[(JStgExpr, Bool)] -> [(JStgExpr, Bool)] -> [(JStgExpr, Bool)]
forall a. [a] -> [a] -> [a]
++[(JStgExpr
fun,Bool
False)])

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

-- All identifiers referenced by the expression (does not traverse into nested functions)
allVars :: JStgExpr -> [Ident]
allVars :: JStgExpr -> [Ident]
allVars (ValExpr JVal
v) = case JVal
v of
  (JVar Ident
i) -> [Ident
i]
  (JList [JStgExpr]
xs) -> (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
xs
  (JHash UniqMap FastString JStgExpr
xs) -> ((FastString, JStgExpr) -> [Ident])
-> [(FastString, JStgExpr)] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (JStgExpr -> [Ident]
allVars (JStgExpr -> [Ident])
-> ((FastString, JStgExpr) -> JStgExpr)
-> (FastString, JStgExpr)
-> [Ident]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, JStgExpr) -> JStgExpr
forall a b. (a, b) -> b
snd) (UniqMap FastString JStgExpr -> [(FastString, JStgExpr)]
forall k a. UniqMap k a -> [(k, a)]
UM.nonDetUniqMapToList UniqMap FastString JStgExpr
xs)
  (JInt {})  -> []
  (JDouble {}) -> []
  (JStr {}) -> []
  (JRegEx {}) -> []
  (JBool {}) -> []
  (JFunc [Ident]
is JStgStat
_s) -> [Ident]
is
allVars (InfixExpr Op
_op JStgExpr
lh JStgExpr
rh) = JStgExpr -> [Ident]
allVars JStgExpr
lh [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
rh
allVars (ApplExpr JStgExpr
f [JStgExpr]
xs) = JStgExpr -> [Ident]
allVars JStgExpr
f [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
xs
allVars (IfExpr JStgExpr
c JStgExpr
t JStgExpr
e) = JStgExpr -> [Ident]
allVars JStgExpr
c [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
t [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
e
allVars (UOpExpr UOp
_op JStgExpr
x) = JStgExpr -> [Ident]
allVars JStgExpr
x
allVars (SelExpr JStgExpr
e Ident
_) = JStgExpr -> [Ident]
allVars JStgExpr
e
allVars (IdxExpr JStgExpr
e JStgExpr
i) = JStgExpr -> [Ident]
allVars JStgExpr
e [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
i

-- | allocate multiple, possibly mutually recursive, closures
allocDynAll :: Bool -> Maybe JStgStat -> [(Ident,JStgExpr,[JStgExpr],CostCentreStack)] -> G JStgStat
allocDynAll :: Bool
-> Maybe JStgStat
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
-> G JStgStat
allocDynAll Bool
haveDecl Maybe JStgStat
middle [(Ident
to,JStgExpr
entry,[JStgExpr]
free,CostCentreStack
cc)]
  | Maybe JStgStat -> Bool
forall a. Maybe a -> Bool
isNothing Maybe JStgStat
middle Bool -> Bool -> Bool
&& Ident
to Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
free = do
      Maybe JStgExpr
ccs <- CostCentreStack -> G (Maybe JStgExpr)
ccsVarJ CostCentreStack
cc
      StgToJSConfig
s <- StateT GenState IO StgToJSConfig
getSettings
      JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig
-> Bool
-> Ident
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgStat
allocDynamic StgToJSConfig
s (Bool -> Bool
not Bool
haveDecl) Ident
to JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
ccs
allocDynAll Bool
haveDecl Maybe JStgStat
middle [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls = do
  StgToJSConfig
settings <- StateT GenState IO StgToJSConfig
getSettings
  let
    middle' :: JStgStat
    middle' :: JStgStat
middle' = JStgStat -> Maybe JStgStat -> JStgStat
forall a. a -> Maybe a -> a
fromMaybe JStgStat
forall a. Monoid a => a
mempty Maybe JStgStat
middle

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

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

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

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

    checkObjs :: [JStgStat]
    checkObjs :: [JStgStat]
checkObjs | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings  =
                ((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> JStgStat)
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ident
i,JStgExpr
_,[JStgExpr]
_,CostCentreStack
_) -> JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (FastString -> JStgExpr
var FastString
"h$checkObj") [Ident -> JStgExpr
Var Ident
i]) [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls
              | Bool
otherwise = [JStgStat]
forall a. Monoid a => a
mempty

  JStgStat
objs <- G JStgStat
makeObjs
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat
objs, JStgStat
middle', [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat]
fillObjs, [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat]
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 (JStgStat, ExprResult)
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t = do
  [JStgExpr]
as <- (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
  Bool
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  Bool
bound <- StgToJSConfig -> Bool
csBoundsCheck (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  let prim_gen :: JSM PrimRes
prim_gen = FastString -> JSM PrimRes -> JSM PrimRes
forall a. FastString -> JSM a -> JSM a
withTag FastString
"h$PRM" (JSM PrimRes -> JSM PrimRes) -> JSM PrimRes -> JSM PrimRes
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Type
-> PrimOp
-> [JStgExpr]
-> [JStgExpr]
-> JSM PrimRes
genPrim Bool
prof Bool
bound Type
t PrimOp
op ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JStgExpr]
as
  -- fixme: should we preserve/check the primreps?
  JEnv
jsm <- IO JEnv -> StateT GenState IO JEnv
forall a. IO a -> StateT GenState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO JEnv
initJSM
  (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JStgStat, ExprResult) -> G (JStgStat, ExprResult))
-> (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a b. (a -> b) -> a -> b
$ case JEnv -> JSM PrimRes -> PrimRes
forall a. JEnv -> JSM a -> a
runJSM JEnv
jsm JSM PrimRes
prim_gen of
             PrimInline JStgStat
s -> (JStgStat
s, ExprResult
ExprInline)
             PRPrimCall JStgStat
s -> (JStgStat
s, ExprResult
ExprCont)