diff options
Diffstat (limited to 'compiler/GHC/StgToJS')
| -rw-r--r-- | compiler/GHC/StgToJS/Apply.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/CodeGen.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Expr.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Linker/Linker.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Linker/Opt.hs | 120 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Object.hs | 48 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Printer.hs | 216 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Rts/Rts.hs | 44 |
8 files changed, 198 insertions, 289 deletions
diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs index 2a4ec9fd17..d960c361df 100644 --- a/compiler/GHC/StgToJS/Apply.hs +++ b/compiler/GHC/StgToJS/Apply.hs @@ -408,17 +408,11 @@ mkApplyArr = mconcat [ TxtI "h$apply" ||= toJExpr (JList []) , TxtI "h$paps" ||= toJExpr (JList []) , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] + [ ValExpr $ JFunc [] $ mconcat + [ jFor (|= zero_) (.<. Int 65536) preIncrS + (\j -> var "h$apply" .! j |= var "h$ap_gen") + , jFor (|= zero_) (.<. Int 128) preIncrS + (\j -> var "h$paps" .! j |= var "h$pap_gen") , mconcat (map assignSpec applySpec) , mconcat (map assignPap specPap) ] diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs index fdc431ef4c..6110135afb 100644 --- a/compiler/GHC/StgToJS/CodeGen.hs +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -16,6 +16,7 @@ import GHC.JS.Ppr import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Arg import GHC.StgToJS.Sinker @@ -133,10 +134,10 @@ genUnits m ss spt_entries foreign_stubs = do glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) - $ mconcat (reverse glbl) <> staticInit) + let stat = ( jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit { oiSymbols = syms @@ -208,7 +209,9 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsOptimize + . satJStat + $ jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -245,10 +248,10 @@ genUnits m ss spt_entries foreign_stubs = do let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl + stat = jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit { oiSymbols = syms @@ -308,15 +311,15 @@ genSetConInfo i d l {- srt -} = do (fixedLayout $ map uTypeVt fields) (CICon $ dataConTag d) sr - return (ei ||= mkDataEntry) + return (mkDataEntry ei) 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 +mkDataEntry :: Ident -> JStat +mkDataEntry i = FuncStat i [] returnStack genToplevelRhs :: Id -> CgStgRhs -> G JStat -- general cases: diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs index 0b8e34e14b..835140791d 100644 --- a/compiler/GHC/StgToJS/Expr.hs +++ b/compiler/GHC/StgToJS/Expr.hs @@ -240,7 +240,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = body <- genBody ctx R1 args body typ ei@(TxtI eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = JFunc [] (bh <> lvs <> body) + let f = (bh <> lvs <> body) emitClosureInfo $ ClosureInfo ei (CIRegs 0 $ concatMap idVt args) @@ -249,7 +249,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = map (stackSlotType . fst) (ctxLneFrameVars ctx)) CIStackFrame sr - emitToplevel (ei ||= toJExpr f) + emitToplevel (jFunction ei [] f) genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx ei@(TxtI _eii) <- identForEntryId i @@ -258,8 +258,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do 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]))) + emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () @@ -283,7 +282,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = (fixedLayout $ map (uTypeVt . idType) live) et sr - emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) where entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) @@ -630,7 +629,7 @@ genRet ctx e at as l = freshIdent >>= f ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr - emitToplevel $ r ||= toJExpr (JFunc [] fun') + emitToplevel $ jFunction r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs index ea8cb79d95..067616b1cb 100644 --- a/compiler/GHC/StgToJS/Linker/Linker.hs +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -30,6 +30,7 @@ import Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make +import GHC.JS.Optimizer import GHC.JS.Unsat.Syntax import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform @@ -43,11 +44,11 @@ import GHC.Linker.Static.Utils (exeFileName) import GHC.StgToJS.Linker.Types import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt import GHC.StgToJS.Rts.Rts import GHC.StgToJS.Object import GHC.StgToJS.Types hiding (LinkableUnit) import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer import GHC.StgToJS.Arg import GHC.StgToJS.Closure @@ -332,7 +333,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods diff --git a/compiler/GHC/StgToJS/Linker/Opt.hs b/compiler/GHC/StgToJS/Linker/Opt.hs new file mode 100644 index 0000000000..867154c61e --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Opt.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Opt +-- 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> +-- Stability : experimental +-- +-- Optimization pass at link time +-- +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Linker.Opt + ( pretty + , ghcjsRenderJs + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Ppr as PP +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JStat -> Doc +pretty = jsToDocR ghcjsRenderJs + +ghcjsRenderJs :: RenderJs +ghcjsRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: RenderJs -> Ident -> Doc +ghcjsRenderJsI _ (TxtI fs) + -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by + -- name in user code, only in compiled code. Hence we can rename them if we do + -- it consistently in all the linked code. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: Word -> Doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: RenderJs -> JStat -> Doc +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: RenderJs -> JVal -> Doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . PP.fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m + where + quoteIfRequired :: FastString -> Doc + quoteIfRequired x + | isUnquotedKey x = ftext x + | otherwise = PP.squotes (ftext x) + + isUnquotedKey :: FastString -> Bool + isUnquotedKey fs = case unpackFS fs of + [] -> False + s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs) + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c + +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs index 168784ab81..be87945f3f 100644 --- a/compiler/GHC/StgToJS/Object.hs +++ b/compiler/GHC/StgToJS/Object.hs @@ -408,31 +408,35 @@ instance Binary Sat.JStat where put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (Sat.ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (Sat.SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (Sat.BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (Sat.ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (Sat.UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (Sat.AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ bh (Sat.LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (Sat.BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (Sat.ContinueStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b get bh = getByte bh >>= \case 1 -> Sat.DeclStat <$> get bh <*> get bh 2 -> Sat.ReturnStat <$> get bh 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh - 5 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> Sat.BlockStat <$> get bh - 9 -> Sat.ApplStat <$> get bh <*> get bh - 10 -> Sat.UOpStat <$> get bh <*> get bh - 11 -> Sat.AssignStat <$> get bh <*> get bh - 12 -> Sat.LabelStat <$> get bh <*> get bh - 13 -> Sat.BreakStat <$> get bh - 14 -> Sat.ContinueStat <$> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) @@ -541,6 +545,10 @@ instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = putByte bh 1 diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs deleted file mode 100644 index 03d224f0f9..0000000000 --- a/compiler/GHC/StgToJS/Printer.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Printer --- 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> --- Stability : experimental --- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work --- --- ------------------------------------------------------------------------------ -module GHC.StgToJS.Printer - ( pretty - , ghcjsRenderJs - , prettyBlock - ) -where - -import GHC.Prelude -import GHC.Int -import GHC.Exts - -import GHC.JS.Syntax -import GHC.JS.Ppr - -import GHC.Utils.Ppr as PP -import GHC.Data.FastString -import GHC.Types.Unique.Map - -import Data.List (sortOn) -import Data.Char (isAlpha,isDigit,ord) -import qualified Data.ByteString.Short as SBS - -pretty :: JStat -> Doc -pretty = jsToDocR ghcjsRenderJs - -ghcjsRenderJs :: RenderJs -ghcjsRenderJs = defaultRenderJs - { renderJsV = ghcjsRenderJsV - , renderJsS = ghcjsRenderJsS - , renderJsI = ghcjsRenderJsI - } - -hdd :: SBS.ShortByteString -hdd = SBS.pack (map (fromIntegral . ord) "h$$") - -ghcjsRenderJsI :: RenderJs -> Ident -> Doc -ghcjsRenderJsI _ (TxtI fs) - -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by - -- name in user code, only in compiled code. Hence we can rename them if we do - -- it consistently in all the linked code. - -- - -- These symbols are usually very large because their name includes the - -- unit-id, the module name, and some unique number. So we rename these - -- symbols with a much shorter globally unique number. - -- - -- Here we reuse their FastString unique for this purpose! Note that it only - -- works if we pretty-print all the JS code linked together at once, which we - -- currently do. GHCJS used to maintain a CompactorState to support - -- incremental linking: it contained the mapping between original symbols and - -- their renaming. - | hdd `SBS.isPrefixOf` fastStringToShortByteString fs - , u <- uniqueOfFS fs - = text "h$$" <> hexDoc (fromIntegral u) - | otherwise - = ftext fs - --- | Render as an hexadecimal number in reversed order (because it's faster and we --- don't care about the actual value). -hexDoc :: Word -> Doc -hexDoc 0 = char '0' -hexDoc v = text $ go v - where - sym (I# i) = C# (indexCharOffAddr# chars i) - chars = "0123456789abcdef"# - go = \case - 0 -> [] - n -> sym (fromIntegral (n .&. 0x0F)) - : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) - : go (n `shiftR` 8) - - - - --- attempt to resugar some of the common constructs -ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s - --- don't quote keys in our object literals, so closure compiler works -ghcjsRenderJsV :: RenderJs -> JVal -> Doc -ghcjsRenderJsV r (JHash m) - | isNullUniqMap m = text "{}" - | otherwise = braceNest . PP.fsep . punctuate comma . - map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) - -- nonDetEltsUniqMap doesn't introduce non-determinism here because - -- we sort the elements lexically - . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m - where - quoteIfRequired :: FastString -> Doc - quoteIfRequired x - | isUnquotedKey x = ftext x - | otherwise = PP.squotes (ftext x) - - isUnquotedKey :: FastString -> Bool - isUnquotedKey fs = case unpackFS fs of - [] -> False - s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs) - - validFirstIdent c = c == '_' || c == '$' || isAlpha c - validOtherIdent c = isAlpha c || isDigit c - -ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs index 2f41862b6a..a25cd6c4e7 100644 --- a/compiler/GHC/StgToJS/Rts/Rts.hs +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -30,16 +30,18 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Apply import GHC.StgToJS.Closure import GHC.StgToJS.Heap -import GHC.StgToJS.Printer import GHC.StgToJS.Profiling import GHC.StgToJS.Regs import GHC.StgToJS.Types import GHC.StgToJS.Stack +import GHC.StgToJS.Linker.Opt + import GHC.Data.FastString import GHC.Types.Unique.Map @@ -134,7 +136,7 @@ closureConstructors s = BlockStat | otherwise = mempty mkClosureCon :: Maybe Int -> JStat - mkClosureCon n0 = funName ||= toJExpr fun + mkClosureCon n0 = jFunction funName args funBod where n | Just n' <- n0 = n' | Nothing <- n0 = 0 @@ -142,7 +144,6 @@ closureConstructors s = BlockStat | Nothing <- n0 = TxtI $ mkFastString "h$c" -- args are: f x1 x2 .. xn [cc] args = TxtI "f" : addCCArg' (map varName [1..n]) - fun = JFunc args funBod -- x1 goes into closureField1. All the other args are bundled into an -- object in closureField2: { d1 = x2, d2 = x3, ... } -- @@ -157,12 +158,12 @@ closureConstructors s = BlockStat ] mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun + mkDataFill n = jFunction funName (map TxtI ds) body where funName = TxtI $ dataName n ds = map dataFieldName [1..n] extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + body = (checkD <> returnS extra_args) -- | JS Payload to perform stack manipulation in the RTS stackManip :: JStat @@ -172,10 +173,10 @@ stackManip = mconcat (map mkPush [1..32]) <> mkPush :: Int -> JStat mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) as = map varName [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun + body = ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in jFunction funName as body -- partial pushes, based on bitmap, increases Sp by highest bit mkPpush :: Integer -> JStat @@ -185,11 +186,10 @@ stackManip = mconcat (map mkPush [1..32]) <> n = length bits h = last bits args = map varName [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun + body = mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in jFunction funName args body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -244,12 +244,12 @@ loadRegs :: JStat loadRegs = mconcat $ map mkLoad [1..32] where mkLoad :: Int -> JStat - mkLoad n = let args = map varName [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun + mkLoad n = let args = map varName [1..n] + body = mconcat $ + zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + in jFunction fname args body -- | Assign registers R1 ... Rn in descending order, that is assign Rn first. -- This function uses the 'assignRegs'' array to construct functions which set @@ -314,11 +314,11 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . jsOptimize . satJStat . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty . jsOptimize . satJStat $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' rts :: StgToJSConfig -> JStat |