diff options
Diffstat (limited to 'compiler/GHC/StgToJS/Expr.hs')
| -rw-r--r-- | compiler/GHC/StgToJS/Expr.hs | 1045 |
1 files changed, 1045 insertions, 0 deletions
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs new file mode 100644 index 0000000000..fd6d09585f --- /dev/null +++ b/compiler/GHC/StgToJS/Expr.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of Expressions +----------------------------------------------------------------------------- + +module GHC.StgToJS.Expr + ( genExpr + , genEntryType + , loadLiveFun + , genStaticRefsRhs + , genStaticRefs + , genBody + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Apply +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.FFI +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Prim +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Types.Basic +import GHC.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.RepType + +import GHC.Stg.Syntax +import GHC.Stg.Utils + +import GHC.Builtin.PrimOps + +import GHC.Core +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.Arity (isOneShotBndr) +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import qualified GHC.Data.List.SetOps as ListSetOps + +import Data.Monoid +import Data.Maybe +import Data.Function +import Data.Either +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Map as M +import Control.Monad +import Control.Arrow ((&&&)) + +-- | Evaluate an expression in the given expression context (continuation) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult) +genExpr ctx stg = case stg of + StgApp f args -> genApp ctx f args + StgLit l -> do + ls <- genLit l + let r = assignToExprCtx ctx ls + pure (r,ExprInline Nothing) + StgConApp con _n args _ -> do + as <- concatMapM genArg args + c <- genCon ctx con as + return (c, ExprInline (Just as)) + StgOpApp (StgFCallOp f _) args t + -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args + StgOpApp (StgPrimOp op) args t + -> genPrimOp ctx op args t + StgOpApp (StgPrimCallOp c) args t + -> genPrimCall ctx c args t + StgCase e b at alts + -> genCase ctx b e at alts (liveVars $ stgExprLive False stg) + StgLet _ b e -> do + (b',ctx') <- genBind ctx b + (s,r) <- genExpr ctx' e + return (b' <> s, r) + StgLetNoEscape _ b e -> do + (b', ctx') <- genBindLne ctx b + (s, r) <- genExpr ctx' e + return (b' <> s, r) + StgTick (ProfNote cc count scope) e -> do + setSCCstats <- ifProfilingM $ setCC cc count scope + (stats, result) <- genExpr ctx e + return (setSCCstats <> stats, result) + StgTick (SourceNote span _sname) e + -> genExpr (ctxSetSrcSpan span ctx) e + StgTick _m e + -> genExpr ctx e + +-- | regular let binding: allocate heap object +genBind :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBind ctx bndr = + case bndr of + StgNonRec b r -> do + j <- assign b r >>= \case + Just ja -> return ja + Nothing -> allocCls Nothing [(b,r)] + return (j, addEvalRhs ctx [(b,r)]) + StgRec bs -> do + jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls + let m = if null jas then Nothing else Just (mconcat $ catMaybes jas) + j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs + return (j, addEvalRhs ctx bs) + where + ctx' = ctxClearLneFrame ctx + + assign :: Id -> CgStgRhs -> G (Maybe JStat) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr + , StgApp selectee [] <- strip sel_expr + , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params) + , let total_size = sum (map (typeSize . idType) params) + -- , the_fv == scrutinee -- fixme check + , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee + , the_offset <= 16 -- fixme make this some configurable constant + = do + let the_fv = scrutinee -- error "the_fv" -- fixme + let sel_tag | the_offset == 2 = if total_size == 2 then "2a" + else "2b" + | otherwise = show the_offset + tgts <- identsForId b + the_fvjs <- varsForId the_fv + case (tgts, the_fvjs) of + ([tgt], [the_fvj]) -> return $ Just + (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr) + | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + d <- declVarsForId b + tgt <- varsForId b + let ctx' = ctx { ctxTarget = assocIdExprs b tgt } + (j, _) <- genExpr ctx' expr + return (Just (d <> j)) + assign _b StgRhsCon{} = return Nothing + assign b r = genEntry ctx' b r >> return Nothing + + addEvalRhs c [] = c + addEvalRhs c ((b,r):xs) + | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | otherwise = addEvalRhs c xs + +genBindLne :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBindLne ctx bndr = do + -- compute live variables and the offsets where they will be stored in the + -- stack + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + -- initialize updatable bindings to null_ + declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds + -- update expression context to include the updated LNE frame + let ctx' = ctxUpdateLneFrame vis bound ctx + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrameSize = ctxLneFrameSize ctx + isOldLv i = ctxIsLneBinding ctx i || + ctxIsLneLiveVar ctx i + live = liveVars $ mkDVarSet $ stgLneLive' bndr + newLvs = filter (not . isOldLv) (dVarSetElems live) + binds = case bndr of + StgNonRec b e -> [(b,e)] + StgRec bs -> bs + bound = map fst binds + (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) 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 ctx i rhs@(StgRhsClosure _ext _cc update args body) = + resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + vars = ctxLneFrameVars ctx + myOffset = + maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") + ((payloadSize-) . fst) + (L.find ((==i) . fst . snd) (zip [0..] vars)) + bh | isUpdatable update = + jVar (\x -> mconcat + [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] + , IfStat x (ReturnStat x) mempty + ]) + | otherwise = mempty + lvs <- popLneFrame True payloadSize ctx + body <- genBody ctx i R1 args body + ei@(TxtI eii) <- identForEntryId i + sr <- genStaticRefsRhs rhs + let f = JFunc [] (bh <> lvs <> body) + emitClosureInfo $ + ClosureInfo ei + (CIRegs 0 $ concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout . reverse $ + map (stackSlotType . fst) (ctxLneFrameVars ctx)) + CIStackFrame + sr + emitToplevel (ei ||= toJExpr f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + ei@(TxtI _eii) <- identForEntryId i + -- di <- varForDataConWorker con + ii <- freshIdent + p <- popLneFrame True payloadSize ctx + args' <- concatMapM genArg args + ac <- allocCon ii con cc args' + emitToplevel (ei ||= toJExpr (JFunc [] + (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + +-- | Generate the entry function for a local closure +genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntry _ _i StgRhsCon {} = return () +genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do + let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body + ll <- loadLiveFun live + llv <- verifyRuntimeReps live + upd <- genUpdFrame upd_flag i + body <- genBody entryCtx i R2 args body + ei@(TxtI eii) <- identForEntryId i + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 $ PtrV : concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout $ map (uTypeVt . idType) live) + et + sr + emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + where + entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + +-- | Generate the entry function types for identifiers. Note that this only +-- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is +-- filtered as not a RuntimeRepKinded type. +genEntryType :: HasDebugCallStack => [Id] -> G CIType +genEntryType [] = return CIThunk +genEntryType args0 = do + args' <- mapM genIdArg args + return $ CIFun (length args) (length $ concat args') + where + args = filter (not . isRuntimeRepKindedTy . idType) args0 + +-- | Generate the body of an object +genBody :: HasDebugCallStack + => ExprCtx + -> Id + -> StgReg + -> [Id] + -> CgStgExpr + -> G JStat +genBody ctx i startReg args e = do + -- load arguments into local variables + la <- do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [startReg..])) + + -- assert that arguments have valid runtime reps + lav <- verifyRuntimeReps args + + -- compute PrimReps and their number of slots required to return the result of + -- i applied to args. + let res_vars = resultSize args i + + -- compute typed expressions for each slot and assign registers + let go_var regs = \case + [] -> [] + ((rep,size):rs) -> + let !(regs0,regs1) = splitAt size regs + !ts = go_var regs1 rs + in TypedExpr rep regs0 : ts + + let tgt = go_var jsRegsFromR1 res_vars + let !ctx' = ctx { ctxTarget = tgt } + + -- generate code for the expression + (e, _r) <- genExpr ctx' e + + return $ la <> lav <> e <> returnStack + +-- | Find the result type after applying the function to the arguments +-- +-- It's trickier than it looks because: +-- +-- 1. we don't have the Arity of the Id. The following functions return +-- different values in some cases: +-- - idArity +-- - typeArity . idType +-- - idFunRepArity +-- - typeArity . unwrapType . idType +-- Moreover the number of args may be different than all of these arities +-- +-- 2. sometimes the type is Any, perhaps after some unwrapping. For example +-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a). +-- +-- Se we're left to use the applied arguments to peel the type (unwrapped) one +-- arg at a time. But passed args are args after unarisation so we need to +-- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- number of passed args consumed by each type arg. +-- +-- In case of failure to determine the type, we default to LiftedRep as it's +-- probably what it is. +-- +resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)] +resultSize args i = result + where + result = result_reps `zip` result_slots + result_slots = fmap (slotCount . primRepSize) result_reps + result_reps = trim_args (unwrapType (idType i)) (length args) + + trim_args t 0 = typePrimRep t + trim_args t n + | Just (_af, _mult, arg, res) <- splitFunTy_maybe t + , nargs <- length (typePrimRepArgs arg) + , assert (n >= nargs) True + = trim_args (unwrapType res) (n - nargs) + | otherwise + = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t) + [LiftedRep] + +-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function +-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. +verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat +verifyRuntimeReps xs = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else mconcat <$> mapM verifyRuntimeRep xs + where + verifyRuntimeRep i = do + i' <- varsForId i + pure $ go i' (idVt i) + go js (VoidV:vs) = go js vs + go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs + go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs + go (j:js) (v:vs) = ver j v <> go js vs + go [] [] = mempty + go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) + ver j PtrV = v "h$verify_rep_heapobj" [j] + ver j IntV = v "h$verify_rep_int" [j] + ver j RtsObjV = v "h$verify_rep_rtsobj" [j] + ver j DoubleV = v "h$verify_rep_double" [j] + ver j ArrV = v "h$verify_rep_arr" [j] + ver _ _ = mempty + v f as = ApplStat (var f) as + +-- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N +-- registers. This assumes these data fields have already been populated in the +-- registers. For the empty, singleton, and binary case use register 1, for any +-- more use as many registers as necessary. +loadLiveFun :: [Id] -> G JStat +loadLiveFun l = do + l' <- concat <$> mapM identsForId l + case l' of + [] -> return mempty + -- set the ident to d1 field of register 1 + [v] -> return (v ||= r1 .^ closureField1_) + -- set the idents to d1 and d2 fields of register 1 + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureField1_ + , v2 ||= r1 .^ closureField2_ + ] + -- and so on + (v:vs) -> do + d <- freshIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureField1_ + , d ||= r1 .^ closureField2_ + , l'' + ] + where + loadLiveVar d n v = let ident = TxtI (dataFieldName n) + in v ||= SelExpr d ident + +-- | Pop a let-no-escape frame off the stack +popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame inEntry size ctx = do + -- calculate the new stack size + let ctx' = ctxLneShrinkStack ctx size + + let gen_id_slot (i,n) = do + ids <- identsForId i + let !id_n = ids !! (n-1) + pure (id_n, SlotId i n) + + is <- mapM gen_id_slot (ctxLneFrameVars ctx') + + let skip = if inEntry then 1 else 0 -- pop the frame header + popSkipI skip is + +-- | Generate an updated given an 'Id' +genUpdFrame :: UpdateFlag -> Id -> G JStat +genUpdFrame u i + | isReEntrant u = pure mempty + | isOneShotBndr i = maybeBh + | isUpdatable u = updateThunk + | otherwise = maybeBh + where + isReEntrant ReEntrant = True + isReEntrant _ = False + maybeBh = do + settings <- getSettings + assertRtsStat (return $ bhSingleEntry settings) + +-- | Blackhole single entry +-- +-- Overwrite a single entry object with a special thunk that behaves like a +-- black hole (throws a JS exception when entered) but pretends to be a thunk. +-- Useful for making sure that the object is not accidentally entered multiple +-- times +-- +bhSingleEntry :: StgToJSConfig -> JStat +bhSingleEntry _settings = mconcat + [ r1 .^ closureEntry_ |= var "h$blackholeTrap" + , r1 .^ closureField1_ |= undefined_ + , r1 .^ closureField2_ |= undefined_ + ] + +genStaticRefsRhs :: CgStgRhs -> G CIStatic +genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv) + +-- fixme, update to new way to compute static refs dynamically +genStaticRefs :: LiveVars -> G CIStatic +genStaticRefs lv + | isEmptyDVarSet sv = return (CIStaticRefs []) + | otherwise = do + unfloated <- State.gets gsUnfloated + let xs = filter (\x -> not (elemUFM x unfloated || + typeLevity_maybe (idType x) == Just Unlifted)) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + + getStaticRef :: Id -> G (Maybe FastString) + getStaticRef = fmap (fmap itxt . listToMaybe) . 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 offset ids = do + -- this line goes wrong vvvvvvv + let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids + idSize :: Id -> Int + idSize i = sum $ map varSize (typeVt . idType $ i) + ids' = concatMap (\i -> map (i,) [1..idSize i]) ids + -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids) + l = length ids' + slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots + let slm = M.fromList (zip slots [0..]) + (remaining, fixed) = partitionEithers $ + map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True)) + (M.lookup (SlotId i n) slm)) ids' + takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed) + freeSlots = filter (`S.notMember` takenSlots) [0..l-1] + remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots + allSlots = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining') + return $ map (\(i,n,_,b) -> (i,n,b)) allSlots + +-- | Allocate local closures +allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat +allocCls dynMiddle xs = do + (stat, dyn) <- partitionEithers <$> mapM toCl xs + ac <- allocDynAll True dynMiddle dyn + pure (mconcat stat <> ac) + where + -- left = static, right = dynamic + toCl :: (Id, CgStgRhs) + -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack)) + -- statics + {- making zero-arg constructors static is problematic, see #646 + proper candidates for this optimization should have been floated + already + toCl (i, StgRhsCon cc con []) = do + ii <- identForId i + Left <$> (return (decl ii) <> allocCon ii con cc []) -} + toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + ii <- identForId i + ac <- allocCon ii con cc =<< genArg a + pure (Left (decl ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar) = + -- fixme do we need to handle unboxed? + Right <$> ((,,,) <$> identForId i + <*> varForDataConWorker con + <*> concatMapM genArg ar + <*> pure cc) + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> identForId i + <*> varForEntryId i + <*> concatMapM varsForId live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +-- | Consume Stg case statement and generate a case statement. See also +-- 'genAlts' +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStat, ExprResult) +genCase ctx bnd e at alts l + | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do + bndi <- identsForId bnd + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) + $ ctx + (ej, r) <- genExpr ctx' e + let d = case r of + ExprInline d0 -> d0 + ExprCont -> pprPanic "genCase: expression was not inline" + (pprStgExpr panicStgPprOpts e) + + (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts + (saveCCS,restoreCCS) <- ifProfilingM $ do + ccsVar <- freshIdent + pure ( ccsVar ||= toJExpr jCurrentCCS + , toJExpr jCurrentCCS |= toJExpr ccsVar + ) + return ( mconcat + [ mconcat (map decl bndi) + , saveCCS + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) + $ ctx + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStat +genRet ctx e at as l = freshIdent >>= f + where + allRefs :: [Id] + allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as + lneLive :: Int + lneLive = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs) + ctx' = ctxLneShrinkStack ctx lneLive + lneVars = map fst $ ctxLneFrameVars ctx' + isLne i = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i + nonLne = filter (not . isLne) (dVarSetElems l) + + f :: Ident -> G JStat + f r@(TxtI ri) = do + pushLne <- pushLneFrame lneLive ctx + saveCCS <- ifProfilingM $ push [jCurrentCCS] + free <- optimizeFree 0 nonLne + pushRet <- pushRetArgs free (toJExpr r) + fun' <- fun free + sr <- genStaticRefs l -- srt + prof <- profiling + emitClosureInfo $ + ClosureInfo r + (CIRegs 0 altRegs) + ri + (fixedLayout . reverse $ + map (stackSlotType . fst3) free + ++ if prof then [ObjV] else map stackSlotType lneVars) + CIStackFrame + sr + emitToplevel $ r ||= toJExpr (JFunc [] fun') + return (pushLne <> saveCCS <> pushRet) + fst3 ~(x,_,_) = x + + altRegs :: HasDebugCallStack => [VarType] + altRegs = case at of + PrimAlt ptc -> [primRepVt ptc] + MultiValAlt _n -> idVt e + _ -> [PtrV] + + -- special case for popping CCS but preserving stack size + pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat + pop_handle_CCS [] = return mempty + pop_handle_CCS xs = do + -- grab the slots from 'xs' and push + addSlots (map snd xs) + -- move the stack pointer into the stack by ''length xs + n' + a <- adjSpN (length xs) + -- now load from the top of the stack + return (loadSkip 0 (map fst xs) <> a) + + fun free = resetSlots $ do + decs <- declVarsForId e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps lneVars + (alts, _altr) <- genAlts ctx' e at Nothing as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +-- | Consume an Stg case alternative and generate the corresponding alternative +-- in JS land. If one alternative is a continuation then we must normalize the +-- other alternatives. See 'Branch' and 'normalizeBranches'. +genAlts :: HasDebugCallStack + => ExprCtx -- ^ lhs to assign expression result to + -> Id -- ^ id being matched + -> AltType -- ^ type + -> Maybe [JExpr] -- ^ if known, fields in datacon from earlier expression + -> [CgStgAlt] -- ^ the alternatives + -> G (JStat, ExprResult) +genAlts ctx e at me alts = do + (st, er) <- case at of + + PolyAlt -> case alts of + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- varsForId e + dids <- mconcat <$> mapM declVarsForId bs + bss <- concatMapM varsForId bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAll bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- varsForId e + (r, bss) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts + setSlots [] + return (mkSw ie bss, r) + + MultiValAlt n + | [GenStgAlt _ bs expr] <- alts + -> do + eids <- varsForId e + l <- loadUbxTup eids bs n + (ej, er) <- genExpr ctx expr + return (l <> ej, er) + + AlgAlt tc + | [_alt] <- alts + , isUnboxedTupleTyCon tc + -> panic "genAlts: unexpected unboxed tuple" + + AlgAlt _tc + | Just es <- me + , [GenStgAlt (DataAlt dc) bs expr] <- alts + , not (isUnboxableCon dc) + -> do + bsi <- mapM identsForId bs + (ej, er) <- genExpr ctx expr + return (declAssignAll (concat bsi) es <> ej, er) + + AlgAlt _tc + | [alt] <- alts + -> do + Branch _ s r <- mkAlgBranch ctx e alt + return (s, r) + + AlgAlt _tc + | [alt,_] <- alts + , DataAlt dc <- alt_con alt + , isBoolDataCon dc + -> do + i <- varForId e + nbs <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + case nbs of + (r, [Branch _ s1 _, Branch _ s2 _]) -> do + let s = if dataConTag dc == 2 + then IfStat i s1 s2 + else IfStat i s2 s1 + setSlots [] + return (s, r) + _ -> error "genAlts: invalid branches for Bool" + + AlgAlt _tc -> do + ei <- varForId e + (r, brs) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + setSlots [] + return (mkSwitch (ei .^ "f" .^ "a") brs, r) + + _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts)) + + ver <- verifyMatchRep e at + pure (ver <> st, er) + +-- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that +-- asserts the pattern match is valid, e.g., the match is attempted on a +-- Boolean, a Data Constructor, or some number. +verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat +verifyMatchRep x alt = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else case alt of + AlgAlt tc -> do + ix <- varsForId x + pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix) + _ -> pure 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 + { branch_expr :: a + , branch_stat :: JStat + , branch_result :: ExprResult + } + deriving (Eq,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 ctx brs + | all (==ExprCont) (fmap branch_result brs) = + (ExprCont, brs) + | branchResult (fmap branch_result brs) == ExprCont = + (ExprCont, map mkCont brs) + | otherwise = + (ExprInline Nothing, brs) + where + mkCont b = case branch_result b of + ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } + _ -> b + +-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input +-- ID's, declaring them as variables in JS land and binding them, in order, to +-- 'es'. +loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat +loadUbxTup es bs _n = do + bs' <- concatMapM identsForId bs + return $ declAssignAll bs' es + +mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases) +mkSw es cases = mkIfElse es cases + +-- | Switch for pattern matching on constructors or prims +mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat +mkSwitch e cases + | [Branch (Just c1) s1 _] <- n + , [Branch _ s2 _] <- d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | [Branch (Just c1) s1 _, Branch _ s2 _] <- n + , null d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | null d + = SwitchStat e (map addBreak (init n)) (branch_stat (last n)) + + | [Branch _ d0 _] <- d + = SwitchStat e (map addBreak n) d0 + + | otherwise = panic "mkSwitch: multiple default cases" + where + addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing]) + addBreak _ = panic "mkSwitch: addBreak" + (n,d) = L.partition (isJust . branch_expr) cases + +-- | if/else for pattern matching on things that js cannot switch on +-- the list of branches is expected to have the default alternative +-- first, if it exists +mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkIfElse e s = go (L.reverse s) + where + go = \case + [Branch _ s _] -> s -- only one 'nothing' allowed + (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs) + [] -> panic "mkIfElse: empty expression list" + _ -> panic "mkIfElse: multiple DEFAULT cases" + +-- | Wrapper to contruct sequences of (===), e.g., +-- +-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) +-- +mkEq :: [JExpr] -> [JExpr] -> JExpr +mkEq es1 es2 + | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) + | otherwise = panic "mkEq: incompatible expressions" + +mkAlgBranch :: ExprCtx -- ^ toplevel id for the result + -> Id -- ^ datacon to match + -> CgStgAlt -- ^ match alternative with binders + -> G (Branch (Maybe JExpr)) +mkAlgBranch top d alt + | DataAlt dc <- alt_con alt + , isUnboxableCon dc + , [b] <- alt_bndrs alt + = do + idd <- varForId d + fldx <- identsForId b + case fldx of + [fld] -> do + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch Nothing (mconcat [fld ||= idd, ej]) er) + _ -> panic "mkAlgBranch: invalid size" + + | otherwise + = do + cc <- caseCond (alt_con alt) + idd <- varForId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +-- | Generate a primitive If-expression +mkPrimIfBranch :: ExprCtx + -> [VarType] + -> CgStgAlt + -> G (Branch (Maybe [JExpr])) +mkPrimIfBranch top _vt alt = + (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt) + +-- fixme are bool things always checked correctly here? +ifCond :: AltCon -> G (Maybe [JExpr]) +ifCond = \case + DataAlt da -> return $ Just [toJExpr (dataConTag da)] + LitAlt l -> Just <$> genLit l + DEFAULT -> return Nothing + +caseCond :: AltCon -> G (Maybe JExpr) +caseCond = \case + DEFAULT -> return Nothing + DataAlt da -> return $ Just (toJExpr $ dataConTag da) + LitAlt l -> genLit l >>= \case + [e] -> pure (Just e) + es -> pprPanic "caseCond: expected single-variable literal" (ppr es) + +-- fixme use single tmp var for all branches +-- | Load parameters from constructor +loadParams :: JExpr -> [Id] -> G JStat +loadParams from args = do + as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use + return $ case as of + [] -> mempty + [(x,u)] -> loadIfUsed (from .^ closureField1_) x u + [(x1,u1),(x2,u2)] -> mconcat + [ loadIfUsed (from .^ closureField1_) x1 u1 + , loadIfUsed (from .^ closureField2_) x2 u2 + ] + ((x,u):xs) -> mconcat + [ loadIfUsed (from .^ closureField1_) x u + , jVar (\d -> mconcat [ d |= from .^ closureField2_ + , loadConVarsIfUsed d xs + ]) + ] + where + use = repeat True -- fixme clean up + loadIfUsed fr tgt True = tgt ||= fr + loadIfUsed _ _ _ = mempty + + loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..] + where f (x,u) n = loadIfUsed (SelExpr fr (TxtI (dataFieldName n))) x 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 = \case + [] -> panic "branchResult: empty list" + [e] -> e + (ExprCont:_) -> ExprCont + (_:es) + | elem ExprCont es -> ExprCont + | otherwise -> ExprInline Nothing + +-- | Push return arguments onto the stack. The 'Bool' tracks whether the value +-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'. +pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat +pushRetArgs free fun = do + rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free + pushOptimized (rs++[(fun,False)]) + +-- | Load the return arguments then pop the stack frame +loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat +loadRetArgs free = do + ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free + popSkipI 1 ids + +-- | allocate multiple, possibly mutually recursive, closures +allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat +{- +XXX remove use of template and enable in-place init again +allocDynAll haveDecl middle [(to,entry,free,cc)] + | isNothing middle && to `notElem` (free ^.. template) = do + ccs <- ccsVarJ cc + return $ allocDynamic s haveDecl to entry free ccs -} +allocDynAll haveDecl middle cls = do + settings <- getSettings + let + middle' = fromMaybe mempty middle + + decl_maybe i e + | haveDecl = toJExpr i |= e + | otherwise = i ||= e + + makeObjs :: G JStat + makeObjs = + fmap mconcat $ forM cls $ \(i,f,_,cc) -> do + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ decl_maybe i $ if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureEntry_ , f) + , (closureField1_, null_) + , (closureField2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs) + ] + + fillObjs = mconcat $ map fillObj cls + fillObj (i,_,es,_) + | csInlineAlloc settings || length es > 24 = + case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= toJExpr ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr e1 + , toJExpr i .^ closureField2_ |= toJExpr e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr ex + , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es)) + ] + | otherwise = case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= e1 + , toJExpr i .^ closureField2_ |= e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= ex + , toJExpr i .^ closureField2_ |= fillFun es + ] + + fillFun [] = null_ + fillFun es = ApplExpr (allocData (length es)) es + + checkObjs | csAssertRts settings = mconcat $ + map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls + | otherwise = mempty + + objs <- makeObjs + pure $ mconcat [objs, middle', fillObjs, checkObjs] + +-- | Generate a primop. This function wraps around the real generator +-- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before +-- generating the primop. +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimOp ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + bound <- csBoundsCheck <$> getSettings + -- fixme: should we preserve/check the primreps? + return $ case genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as of + PrimInline s -> (s, ExprInline Nothing) + PRPrimCall s -> (s, ExprCont) |