diff options
Diffstat (limited to 'compiler/GHC/StgToJS/CodeGen.hs')
| -rw-r--r-- | compiler/GHC/StgToJS/CodeGen.hs | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs new file mode 100644 index 0000000000..7703398aea --- /dev/null +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen + ( stgToJS + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) + +import GHC.JS.Ppr +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.Sinker +import GHC.StgToJS.Types +import qualified GHC.StgToJS.Object as Object +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Deps +import GHC.StgToJS.Expr +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.Symbols +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep (scaledThing) + +import GHC.Unit.Module +import GHC.Linker.Types (SptEntry (..)) + +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub) +import GHC.Types.RepType +import GHC.Types.Id +import GHC.Types.Unique + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Binary +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import Data.Monoid +import Control.Monad +import System.Directory +import System.FilePath + +-- | Code generator for JavaScript +stgToJS + :: Logger + -> StgToJSConfig + -> [CgStgTopBinding] + -> Module + -> [SptEntry] + -> ForeignStubs + -> CollectedCCs + -> FilePath -- ^ Output file name + -> IO () +stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do + + let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0 + -- TODO: avoid top level lifting in core-2-core when the JS backend is + -- enabled instead of undoing it here + + -- TODO: add dump pass for optimized STG ast for JS + + (deps,lus) <- runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + lus <- genUnits this_mod stg_binds spt_entries foreign_stubs + deps <- genDependencyData this_mod lus + pure (deps,lus) + + -- Doc to dump when -ddump-js is enabled + when (logHasDumpFlag logger Opt_D_dump_js) $ do + putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS + $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus) + + -- Write the object file + bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + + createDirectoryIfMissing True (takeDirectory output_fn) + writeBinMem bh output_fn + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G [LinkableUnit] -- ^ the linkable units +genUnits m ss spt_entries foreign_stubs = do + gbl <- generateGlobalBlock + exports <- generateExportsBlock + others <- go 2 ss + pure (gbl:exports:others) + where + go :: HasDebugCallStack + => Int -- the block we're generating (block 0 is the global unit for the module) + -> [CgStgTopBinding] + -> G [LinkableUnit] + go !n = \case + [] -> pure [] + (x:xs) -> do + mlu <- generateBlock x n + lus <- go (n+1) xs + return (maybe lus (:lus) mlu) + + -- Generate the global unit that all other blocks in the module depend on + -- used for cost centres and static initializers + -- the global unit has no dependencies, exports the moduleGlobalSymbol + generateGlobalBlock :: HasDebugCallStack => G LinkableUnit + generateGlobalBlock = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + let stat = ( -- O.optimize . + jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) + let syms = [moduleGlobalSymbol m] + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = stat + , oiRaw = mempty + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure lu + + generateExportsBlock :: HasDebugCallStack => G LinkableUnit + generateExportsBlock = do + let (f_hdr, f_c) = case foreign_stubs of + NoStubs -> (empty, empty) + ForeignStubs hdr c -> (getCHeader hdr, getCStub c) + unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr) + mkUniqueDep (tag:xs) = mkUnique tag (read xs) + mkUniqueDep [] = panic "mkUniqueDep" + + let syms = [moduleExportsSymbol m] + let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = mempty + , oiRaw = raw + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = unique_deps + , luOtherDeps = [] + , luRequired = True + , luForeignRefs = [] + } + pure lu + + -- Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => CgStgTopBinding + -> Int + -> G (Maybe LinkableUnit) + generateBlock top_bind n = case top_bind of + StgTopStringLit bnd str -> do + bids <- identsForId bnd + case bids of + [(TxtI b1t),(TxtI b2t)] -> do + -- [e1,e2] <- genLit (MachStr str) + emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + _extraTl <- State.gets (ggsToplevelStats . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 + let stat = jsSaturate (Just $ modulePrefix m n) body + let ids = [bnd] + syms <- (\(TxtI i) -> [i]) <$> identForId bnd + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = ids + , luOtherExports = [] + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure (Just lu) + _ -> panic "generateBlock: invalid size" + + StgTopLifted decl -> do + tl <- genToplevel decl + extraTl <- State.gets (ggsToplevelStats . gsGroup) + ci <- State.gets (ggsClosureInfo . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + unf <- State.gets gsUnfloated + extraDeps <- State.gets (ggsExtraDeps . gsGroup) + fRefs <- State.gets (ggsForeignRefs . gsGroup) + resetGroup + let allDeps = collectIds unf decl + topDeps = collectTopIds decl + required = hasExport decl + stat = -- Opt.optimize . + jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl + syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = ci + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = fRefs + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = topDeps + , luOtherExports = [] + , luIdDeps = allDeps + , luPseudoIdDeps = [] + , luOtherDeps = S.toList extraDeps + , luRequired = required + , luForeignRefs = fRefs + } + pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu + +-- | variable prefix for the nth block in module +modulePrefix :: Module -> Int -> FastString +modulePrefix m n = + let encMod = zEncodeString . moduleNameString . moduleName $ m + in mkFastString $ "h$" ++ encMod ++ "_id_" ++ show n + +genToplevel :: CgStgBinding -> G JStat +genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs +genToplevel (StgRec bs) = + mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs + +genToplevelDecl :: Id -> CgStgRhs -> G JStat +genToplevelDecl i rhs = do + s1 <- resetSlots (genToplevelConEntry i rhs) + s2 <- resetSlots (genToplevelRhs i rhs) + return (s1 <> s2) + +genToplevelConEntry :: Id -> CgStgRhs -> G JStat +genToplevelConEntry i rhs = case rhs of + StgRhsCon _cc con _mu _ts _args + | isDataConWorkId i + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args _body + | Just dc <- isDataConWorkId_maybe i + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure mempty + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat +genSetConInfo i d l {- srt -} = do + ei <- identForDataConEntryId i + sr <- genStaticRefs l + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 [PtrV]) + (mkFastString $ renderWithContext defaultSDocContext (ppr d)) + (fixedLayout $ map uTypeVt fields) + (CICon $ dataConTag d) + sr + return (ei ||= mkDataEntry) + where + -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? + fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) + (dataConRepArgTys d) + -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) + +mkDataEntry :: JExpr +mkDataEntry = ValExpr $ JFunc [] returnStack + +genToplevelRhs :: Id -> CgStgRhs -> G JStat +-- general cases: +genToplevelRhs i rhs = case rhs of + StgRhsCon cc con _mu _tys args -> do + ii <- identForId i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + {- + algorithm: + - collect all Id refs that are in the global id cache + - count usage in body for each ref + - order by increasing use + - prepend loading lives var to body: body can stay the same + -} + eid@(TxtI eidt) <- identForEntryId i + (TxtI idt) <- identForId i + body <- genBody (initExprCtx i) i R2 args body + global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + let lidents = map global_ident global_occs + let lids = map global_id global_occs + let lidents' = map identFS lidents + CIStaticRefs sr0 <- genStaticRefsRhs rhs + let sri = filter (`notElem` lidents') sr0 + sr = CIStaticRefs sri + et <- genEntryType args + ll <- loadLiveFun lids + (static, regs, upd) <- + if et == CIThunk + then do + r <- updateThunk + pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r) + else return (StaticFun eidt (map StaticObjArg lidents'), + (if null lidents then CIRegs 1 (concatMap idVt args) + else CIRegs 0 (PtrV : concatMap idVt args)) + , mempty) + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + emitClosureInfo (ClosureInfo eid + regs + idt + (fixedLayout $ map (uTypeVt . idType) lids) + et + sr) + ccId <- costCentreStackLbl cc + emitStatic idt static ccId + return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) |