summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/JS/Make.hs31
-rw-r--r--compiler/GHC/JS/Optimizer.hs271
-rw-r--r--compiler/GHC/JS/Ppr.hs189
-rw-r--r--compiler/GHC/JS/Syntax.hs56
-rw-r--r--compiler/GHC/JS/Transform.hs14
-rw-r--r--compiler/GHC/JS/Unsat/Syntax.hs2
-rw-r--r--compiler/GHC/StgToJS/Apply.hs16
-rw-r--r--compiler/GHC/StgToJS/CodeGen.hs27
-rw-r--r--compiler/GHC/StgToJS/Expr.hs11
-rw-r--r--compiler/GHC/StgToJS/Linker/Linker.hs5
-rw-r--r--compiler/GHC/StgToJS/Linker/Opt.hs120
-rw-r--r--compiler/GHC/StgToJS/Object.hs48
-rw-r--r--compiler/GHC/StgToJS/Printer.hs216
-rw-r--r--compiler/GHC/StgToJS/Rts/Rts.hs44
-rw-r--r--compiler/ghc.cabal.in3
15 files changed, 666 insertions, 387 deletions
diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs
index 8b06198a83..85651647bc 100644
--- a/compiler/GHC/JS/Make.hs
+++ b/compiler/GHC/JS/Make.hs
@@ -83,7 +83,7 @@ module GHC.JS.Make
-- $intro_funcs
, var
, jString
- , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally
+ , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally
-- * Combinators
-- $combinators
, (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)
@@ -253,7 +253,7 @@ jLam f = ValExpr . UnsatVal . IS $ do
-- of the enclosed expression. The result is a block statement.
-- Usage:
--
--- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@
+-- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@
jVar :: ToSat a => a -> JStat
jVar f = UnsatBlock . IS $ do
(block, is) <- runIdentSupply $ toSat_ f []
@@ -262,6 +262,9 @@ jVar f = UnsatBlock . IS $ do
addDecls x = x
return $ addDecls block
+jFunction :: Ident -> [Ident] -> JStat -> JStat
+jFunction name args body = FuncStat name args body
+
-- | Create a 'for in' statement.
-- Usage:
--
@@ -279,6 +282,23 @@ jForEachIn e f = UnsatBlock . IS $ do
let i = head is
return $ decl i `mappend` ForInStat True i e block
+-- | Create a 'for' statement given a function for initialization, a predicate
+-- to step to, a step and a body
+-- Usage:
+--
+-- @ jFor (|= zero_) (.<. Int 65536) preIncrS
+-- (\j -> ...something with the counter j...)@
+--
+jFor :: (JExpr -> JStat)
+ -> (JExpr -> JExpr)
+ -> (JExpr -> JStat)
+ -> (JExpr -> JStat)
+ -> JStat
+jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i)
+
+jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat
+jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body
+
-- | As with "jForIn" but creating a \"for each in\" statement.
jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat
jTryCatchFinally s f s2 = UnsatBlock . IS $ do
@@ -294,13 +314,6 @@ var = ValExpr . JVar . TxtI
jString :: FastString -> JExpr
jString = toJExpr
--- | Create a 'for' statement
-jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat
-jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b']
- where b' = case toStat b of
- BlockStat xs -> BlockStat $ xs ++ [after]
- x -> BlockStat [x,after]
-
-- | construct a js declaration with the given identifier
decl :: Ident -> JStat
decl i = DeclStat i Nothing
diff --git a/compiler/GHC/JS/Optimizer.hs b/compiler/GHC/JS/Optimizer.hs
new file mode 100644
index 0000000000..211e6bbd07
--- /dev/null
+++ b/compiler/GHC/JS/Optimizer.hs
@@ -0,0 +1,271 @@
+{-# LANGUAGE LambdaCase #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.JS.Optimizer
+-- 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
+--
+--
+-- * Domain and Purpose
+--
+-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is,
+-- this module defines transformations over the JavaScript IR in
+-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or
+-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The
+-- optimizer is written in continuation passing style so optimizations
+-- compose.
+--
+-- * Architecture of the optimizer
+--
+-- The design is that each optimization pattern matches on the head of a
+-- block by pattern matching onto the head of the stream of nodes in the
+-- JavaScript IR. If an optimization gets a successful match then it performs
+-- whatever rewrite is necessary and then calls the 'loop' continuation. This
+-- ensures that the result of the optimization is subject to the same
+-- optimization, /and/ the rest of the optimizations. If there is no match
+-- then the optimization should call the 'next' continuation to pass the
+-- stream to the next optimization in the optimization chain. We then define
+-- the last "optimization" to be @tailLoop@ which selects the next block of
+-- code to optimize and begin the optimization pipeline again.
+-----------------------------------------------------------------------------
+module GHC.JS.Optimizer
+ ( jsOptimize
+ ) where
+
+
+import Prelude
+
+import GHC.JS.Syntax
+
+import Control.Arrow
+
+{-
+Note [ Unsafe JavaScript Optimizations ]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a number of optimizations that the JavaScript Backend performs that
+are not sound with respect to arbritrary JavaScript. We still perform these
+optimizations because we are not optimizing arbritrary javascript and under the
+assumption that the JavaScript backend will not generate code that violates the
+soundness of the optimizer. For example, the @deadCodeElim@ optimization removes
+all statements that occur after a 'return' in JavaScript, however this is not
+always sound because of hoisting, consider this program:
+
+ function foo() {
+ var x = 2;
+ bar();
+ return x;
+
+ function bar() {
+ x = 10;
+ }}
+
+ which is transformed to:
+
+ function foo() {
+ var x = 2;
+ bar();
+ return x;
+ }}
+
+The optimized form is clearly a program that goes wrong because `bar()` is no
+longer defined. But the JavaScript backend will never generate this code, so as
+long as that assumption holds we are safe to perform optimizations that would
+normally be unsafe.
+-}
+
+
+--------------------------------------------------------------------------------
+-- Top level Driver
+--------------------------------------------------------------------------------
+jsOptimize :: JStat -> JStat
+jsOptimize = go
+ where
+ p_opt = jsOptimize
+ opt = jsOptimize'
+ e_opt = jExprOptimize
+ -- base case
+ go (BlockStat xs) = BlockStat (opt xs)
+ -- recursive cases
+ go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body)
+ go (ForInStat b i p body) = ForInStat b i p (p_opt body)
+ go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body)
+ go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body)
+ go (FuncStat i args body) = FuncStat i args (p_opt body)
+ go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e)
+ go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f)
+ go (LabelStat lbl s) = LabelStat lbl (p_opt s)
+ -- special case: drive the optimizer into expressions
+ go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs)
+ go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e)
+ go (ReturnStat e) = ReturnStat (e_opt e)
+ go (UOpStat op e) = UOpStat op (e_opt e)
+ go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args)
+ -- all else is terminal, we match on these to force a warning in the event
+ -- another constructor is added
+ go x@BreakStat{} = x
+ go x@ContinueStat{} = x
+ go x@DeclStat{} = x -- match on the nothing case
+
+jsOptimize' :: [JStat] -> [JStat]
+jsOptimize' = runBlockOpt opts . single_pass_opts
+ where
+ opts :: BlockOpt
+ opts = safe_opts
+ <> unsafe_opts
+ <> tailLoop -- tailloop must be last, see module description
+
+ unsafe_opts :: BlockOpt
+ unsafe_opts = mconcat [ deadCodeElim ]
+
+ safe_opts :: BlockOpt
+ safe_opts = mconcat [ declareAssign, combineOps ]
+
+ single_pass_opts :: BlockTrans
+ single_pass_opts = runBlockTrans sp_opts
+
+ sp_opts = [flattenBlocks]
+
+-- | recur over a @JExpr@ and optimize the @JVal@s
+jExprOptimize :: JExpr -> JExpr
+-- the base case
+jExprOptimize (ValExpr val) = ValExpr (jValOptimize val)
+-- recursive cases
+jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field
+jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix)
+jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp)
+jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e)
+jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args)
+jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r)
+
+-- | drive optimizations to anonymous functions and over expressions
+jValOptimize :: JVal -> JVal
+-- base case
+jValOptimize (JFunc args body) = JFunc args (jsOptimize body)
+-- recursive cases
+jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs)
+jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash)
+-- all else is terminal
+jValOptimize x@JVar{} = x
+jValOptimize x@JDouble{} = x
+jValOptimize x@JInt{} = x
+jValOptimize x@JStr{} = x
+jValOptimize x@JRegEx{} = x
+
+-- | A block transformation is a function from a stream of syntax to another
+-- stream
+type BlockTrans = [JStat] -> [JStat]
+
+-- | A BlockOpt is a function that alters the stream, and a continuation that
+-- represents the rest of the stream. The first @BlockTrans@ represents
+-- restarting the optimizer after a change has happened. The second @BlockTrans@
+-- represents the rest of the continuation stream.
+newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans)
+
+-- | To merge two BlockOpt we first run the left-hand side optimization and
+-- capture the right-hand side in the continuation
+instance Semigroup BlockOpt where
+ BlockOpt opt0 <> BlockOpt opt1 = BlockOpt
+ $ \loop next -> opt0 loop (opt1 loop next)
+
+instance Monoid BlockOpt where
+ -- don't loop, just finalize
+ mempty = BlockOpt $ \_loop next -> next
+
+-- | loop until a fixpoint is reached
+runBlockOpt :: BlockOpt -> [JStat] -> [JStat]
+runBlockOpt (BlockOpt opt) xs = recur xs
+ where recur = opt recur id
+
+runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat]
+runBlockTrans opts = foldl (.) id opts
+
+-- | Perform all the optimizations on the tail of a block.
+tailLoop :: BlockOpt
+tailLoop = BlockOpt $ \loop next -> \case
+ [] -> next []
+ -- this call to jsOptimize is required or else the optimizer will not
+ -- properly recur down JStat. See the 'deadCodeElim' test for examples which
+ -- were failing before this change
+ (x:xs) -> next (jsOptimize x : loop xs)
+
+--------------------------------------------------------------------------------
+-- Single Slot Optimizations
+--------------------------------------------------------------------------------
+
+{- |
+ Catch modify and assign operators:
+ case 1:
+ i = i + 1; ==> ++i;
+ case 2:
+ i = i - 1; ==> --i;
+ case 3:
+ i = i + n; ==> i += n;
+ case 4:
+ i = i - n; ==> i -= n;
+-}
+combineOps :: BlockOpt
+combineOps = BlockOpt $ \loop next ->
+ \case
+ -- find a op pattern, and rerun the optimizer on its result unless there is
+ -- nothing to optimize, in which case call the next optimization
+ (unchanged@(AssignStat
+ ident@(ValExpr (JVar i))
+ AssignOp
+ (InfixExpr op (ValExpr (JVar i')) e)) : xs)
+ | i == i' -> case (op, e) of
+ (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs
+ (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs
+ (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs
+ (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs
+ _ -> next $ unchanged : xs
+ -- commutative cases
+ (unchanged@(AssignStat
+ ident@(ValExpr (JVar i))
+ AssignOp
+ (InfixExpr op e (ValExpr (JVar i')))) : xs)
+ | i == i' -> case (op, e) of
+ (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs
+ (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs
+ (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs
+ (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs
+ _ -> next $ unchanged : xs
+ -- general case, we had nothing to optimize in this case so call the next
+ -- optimization
+ xs -> next xs
+
+
+--------------------------------------------------------------------------------
+-- Dual Slot Optimizations
+--------------------------------------------------------------------------------
+-- | Catch 'var i; i = q;' ==> 'var i = q;'
+declareAssign :: BlockOpt
+declareAssign = BlockOpt $
+ \loop next -> \case
+ ( (DeclStat i Nothing)
+ : (AssignStat (ValExpr (JVar i')) AssignOp v)
+ : xs
+ ) | i == i' -> loop (DeclStat i (Just v) : xs)
+ xs -> next xs
+
+-- | Eliminate all code after a return statement. This is a special case
+-- optimization that doesn't need to loop. See Note [Unsafe JavaScript
+-- optimizations]
+deadCodeElim :: BlockOpt
+deadCodeElim = BlockOpt $
+ \_loop next -> \case
+ (x@ReturnStat{}:_) -> next [x]
+ xs -> next xs
+
+-- | remove nested blocks
+flattenBlocks :: BlockTrans
+flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys
+flattenBlocks (x:xs) = x : flattenBlocks xs
+flattenBlocks [] = []
diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs
index 9315156eeb..5f3dd737e7 100644
--- a/compiler/GHC/JS/Ppr.hs
+++ b/compiler/GHC/JS/Ppr.hs
@@ -10,10 +10,46 @@
-- For Outputable instances for JS syntax
{-# OPTIONS_GHC -Wno-orphans #-}
--- | Pretty-printing JavaScript
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.JS.Ppr
+-- 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
+--
+--
+-- * Domain and Purpose
+--
+-- GHC.JS.Ppr defines the code generation facilities for the JavaScript
+-- backend. That is, this module exports a function from the JS backend IR
+-- to JavaScript compliant concrete syntax that can readily be executed by
+-- nodejs or called in a browser.
+--
+-- * Design
+--
+-- This module follows the architecture and style of the other backends in
+-- GHC: it intances Outputable for the relevant types, creates a class that
+-- describes a morphism from the IR domain to JavaScript concrete Syntax and
+-- then generates that syntax on a case by case basis.
+--
+-- * How to use
+--
+-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record.
+-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for
+-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a
+-- custom renderer ensures all @Ident@ generated by the linker optimization
+-- pass are prefixed differently than the default. Use @renderJS@ to
+-- generate JavaScript concrete syntax in the general case, suitable for
+-- human consumption.
+-----------------------------------------------------------------------------
+
module GHC.JS.Ppr
( renderJs
- , renderJs'
, renderPrefixJs
, renderPrefixJs'
, JsToDoc(..)
@@ -21,9 +57,10 @@ module GHC.JS.Ppr
, RenderJs(..)
, jsToDoc
, pprStringLit
- , flattenBlocks
, braceNest
, hangBrace
+ , interSemi
+ , addSemi
)
where
@@ -49,9 +86,9 @@ instance Outputable JExpr where
instance Outputable JVal where
ppr = docToSDoc . renderJs
-
-($$$) :: Doc -> Doc -> Doc
-x $$$ y = nest 2 $ x $+$ y
+--------------------------------------------------------------------------------
+-- Top level API
+--------------------------------------------------------------------------------
-- | Render a syntax tree as a pretty-printable document
-- (simply showing the resultant doc produces a nice,
@@ -84,26 +121,17 @@ renderPrefixJs = renderPrefixJs' defaultRenderJs
renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderPrefixJs' r = jsToDocR r
-braceNest :: Doc -> Doc
-braceNest x = char '{' <+> nest 2 x $$ char '}'
-
--- | Hang with braces:
---
--- hdr {
--- body
--- }
-hangBrace :: Doc -> Doc -> Doc
-hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]
+--------------------------------------------------------------------------------
+-- Code Generator
+--------------------------------------------------------------------------------
class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
-instance JsToDoc JStat where jsToDocR r = renderJsS r r
-instance JsToDoc JExpr where jsToDocR r = renderJsE r r
-instance JsToDoc JVal where jsToDocR r = renderJsV r r
-instance JsToDoc Ident where jsToDocR r = renderJsI r r
-instance JsToDoc [JExpr] where
- jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
-instance JsToDoc [JStat] where
- jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
+instance JsToDoc JStat where jsToDocR r = renderJsS r r
+instance JsToDoc JExpr where jsToDocR r = renderJsE r r
+instance JsToDoc JVal where jsToDocR r = renderJsV r r
+instance JsToDoc Ident where jsToDocR r = renderJsI r r
+instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
+instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
defRenderJsS :: RenderJs -> JStat -> Doc
defRenderJsS r = \case
@@ -120,12 +148,16 @@ defRenderJsS r = \case
ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s
where
- printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss
+ printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss
printBS x = jsToDocR r x
- interSemi [x] = [jsToDocR r x]
- interSemi [] = []
- interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs
+ ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb)
+ where
+ forCond = parens $ hcat $ interSemi
+ [ jsToDocR r init
+ , jsToDocR r p
+ , parens (jsToDocR r s1)
+ ]
ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b)
where txt | each = "for each"
| otherwise = "for"
@@ -134,12 +166,15 @@ defRenderJsS r = \case
cases = vcat l'
ReturnStat e -> text "return" <+> jsToDocR r e
ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es)
+ FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i
+ <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
+ (jsToDocR r b)
TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally
where mbCatch | s1 == BlockStat [] = PP.empty
| otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1)
mbFinally | s2 == BlockStat [] = PP.empty
| otherwise = hangBrace (text "finally") (jsToDocR r s2)
- AssignStat i x -> case x of
+ AssignStat i op x -> case x of
-- special treatment for functions, otherwise there is too much left padding
-- (more than the length of the expression assigned to). E.g.
--
@@ -148,19 +183,13 @@ defRenderJsS r = \case
-- ...
-- });
--
- ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
- _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x
+ ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
+ _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x
UOpStat op x
| isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
| isPre op -> ftext (uOpText op) <> optParens r x
| otherwise -> optParens r x <> ftext (uOpText op)
- BlockStat xs -> jsToDocR r (flattenBlocks xs)
-
-flattenBlocks :: [JStat] -> [JStat]
-flattenBlocks = \case
- BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys
- y:ys -> y : flattenBlocks ys
- [] -> []
+ BlockStat xs -> jsToDocR r xs
optParens :: RenderJs -> JExpr -> Doc
optParens r x = case x of
@@ -204,33 +233,12 @@ defRenderJsV r = \case
defRenderJsI :: RenderJs -> Ident -> Doc
defRenderJsI _ (TxtI t) = ftext t
+aOpText :: AOp -> FastString
+aOpText = \case
+ AssignOp -> "="
+ AddAssignOp -> "+="
+ SubAssignOp -> "-="
-pprStringLit :: FastString -> Doc
-pprStringLit s = hcat [char '\"',encodeJson s, char '\"']
-
-encodeJson :: FastString -> Doc
-encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
-
-encodeJsonChar :: Char -> Doc
-encodeJsonChar = \case
- '/' -> text "\\/"
- '\b' -> text "\\b"
- '\f' -> text "\\f"
- '\n' -> text "\\n"
- '\r' -> text "\\r"
- '\t' -> text "\\t"
- '"' -> text "\\\""
- '\\' -> text "\\\\"
- c
- | not (isControl c) && ord c <= 127 -> char c
- | ord c <= 0xff -> hexxs "\\x" 2 (ord c)
- | ord c <= 0xffff -> hexxs "\\u" 4 (ord c)
- | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair
- in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <>
- hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)
- where hexxs prefix pad cp =
- let h = showHex cp ""
- in text (prefix ++ replicate (pad - length h) '0' ++ h)
uOpText :: UOp -> FastString
uOpText = \case
@@ -289,3 +297,56 @@ isAlphaOp = \case
YieldOp -> True
VoidOp -> True
_ -> False
+
+pprStringLit :: FastString -> Doc
+pprStringLit s = hcat [char '\"',encodeJson s, char '\"']
+
+--------------------------------------------------------------------------------
+-- Utilities
+--------------------------------------------------------------------------------
+
+encodeJson :: FastString -> Doc
+encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
+
+encodeJsonChar :: Char -> Doc
+encodeJsonChar = \case
+ '/' -> text "\\/"
+ '\b' -> text "\\b"
+ '\f' -> text "\\f"
+ '\n' -> text "\\n"
+ '\r' -> text "\\r"
+ '\t' -> text "\\t"
+ '"' -> text "\\\""
+ '\\' -> text "\\\\"
+ c
+ | not (isControl c) && ord c <= 127 -> char c
+ | ord c <= 0xff -> hexxs "\\x" 2 (ord c)
+ | ord c <= 0xffff -> hexxs "\\u" 4 (ord c)
+ | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair
+ in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <>
+ hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)
+ where hexxs prefix pad cp =
+ let h = showHex cp ""
+ in text (prefix ++ replicate (pad - length h) '0' ++ h)
+
+braceNest :: Doc -> Doc
+braceNest x = char '{' <+> nest 2 x $$ char '}'
+
+interSemi :: [Doc] -> [Doc]
+interSemi [] = []
+interSemi [s] = [s]
+interSemi (x:xs) = x <> text ";" : interSemi xs
+
+addSemi :: Doc -> Doc
+addSemi x = x <> text ";"
+
+-- | Hang with braces:
+--
+-- hdr {
+-- body
+-- }
+hangBrace :: Doc -> Doc -> Doc
+hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]
+
+($$$) :: Doc -> Doc -> Doc
+x $$$ y = nest 2 $ x $+$ y
diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs
index 0b8a6c05b2..b2d381ec7d 100644
--- a/compiler/GHC/JS/Syntax.hs
+++ b/compiler/GHC/JS/Syntax.hs
@@ -58,6 +58,7 @@ module GHC.JS.Syntax
, JVal(..)
, Op(..)
, UOp(..)
+ , AOp(..)
, Ident(..)
, JLabel
-- * pattern synonyms over JS operators
@@ -110,20 +111,22 @@ import GHC.Generics
-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)
-- for details
data JStat
- = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e]
- | ReturnStat JExpr -- ^ Return
- | IfStat JExpr JStat JStat -- ^ If
+ = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e]
+ | ReturnStat JExpr -- ^ Return
+ | IfStat JExpr JStat JStat -- ^ If
| WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True
+ | ForStat JStat JExpr JStat JStat -- ^ For
| ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True
| SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch
| TryStat JStat Ident JStat JStat -- ^ Try
- | BlockStat [JStat] -- ^ Blocks
- | ApplStat JExpr [JExpr] -- ^ Application
- | UOpStat UOp JExpr -- ^ Unary operators
- | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@
- | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic
- | BreakStat (Maybe JLabel) -- ^ Break
- | ContinueStat (Maybe JLabel) -- ^ Continue
+ | BlockStat [JStat] -- ^ Blocks
+ | ApplStat JExpr [JExpr] -- ^ Application
+ | UOpStat UOp JExpr -- ^ Unary operators
+ | AssignStat JExpr AOp JExpr -- ^ Binding form: @<foo> <op> <bar>@
+ | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic
+ | BreakStat (Maybe JLabel) -- ^ Break
+ | ContinueStat (Maybe JLabel) -- ^ Continue
+ | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition
deriving (Eq, Typeable, Generic)
-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of
@@ -146,9 +149,9 @@ appendJStat mx my = case (mx,my) of
(BlockStat [] , y ) -> y
(x , BlockStat []) -> x
(BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys
- (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys]
- (xs , BlockStat ys) -> BlockStat $! xs : ys
- (xs , ys ) -> BlockStat [xs,ys]
+ (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys]
+ (xs , BlockStat ys) -> BlockStat $! xs : ys
+ (xs , ys ) -> BlockStat [xs,ys]
--------------------------------------------------------------------------------
@@ -156,13 +159,13 @@ appendJStat mx my = case (mx,my) of
--------------------------------------------------------------------------------
-- | JavaScript Expressions
data JExpr
- = ValExpr JVal -- ^ All values are trivially expressions
- | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'
- | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!'
- | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms
- | UOpExpr UOp JExpr -- ^ Unary Expressions
+ = ValExpr JVal -- ^ All values are trivially expressions
+ | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'
+ | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!'
+ | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms
+ | UOpExpr UOp JExpr -- ^ Unary Expressions
| IfExpr JExpr JExpr JExpr -- ^ If-expression
- | ApplExpr JExpr [JExpr] -- ^ Application
+ | ApplExpr JExpr [JExpr] -- ^ Application
deriving (Eq, Typeable, Generic)
-- * Useful pattern synonyms to ease programming with the deeply embedded JS
@@ -321,6 +324,15 @@ data UOp
instance NFData UOp
+-- | JS Unary Operators
+data AOp
+ = AssignOp -- ^ Vanilla Assignment: =
+ | AddAssignOp -- ^ Addition Assignment: +=
+ | SubAssignOp -- ^ Subtraction Assignment: -=
+ deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)
+
+instance NFData AOp
+
-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
-- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
-- Sane-ness
@@ -345,10 +357,12 @@ instance Show SaneDouble where
--------------------------------------------------------------------------------
jassignAllEqual :: [JExpr] -> [JExpr] -> JStat
-jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys)
+jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys)
+ where go l r = AssignStat l AssignOp r
jassignAll :: [JExpr] -> [JExpr] -> JStat
-jassignAll xs ys = mconcat (zipWith AssignStat xs ys)
+jassignAll xs ys = mconcat $ zipWith go xs ys
+ where go l r = AssignStat l AssignOp r
jvar :: FastString -> JExpr
jvar = ValExpr . JVar . TxtI
diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs
index e9c157a97b..9c45ebdd57 100644
--- a/compiler/GHC/JS/Transform.hs
+++ b/compiler/GHC/JS/Transform.hs
@@ -47,6 +47,7 @@ identsS = \case
Sat.ReturnStat e -> identsE e
Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2
Sat.WhileStat _ e s -> identsE e ++ identsS s
+ Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body
Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s
Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s
where traverseCase (e,s) = identsE e ++ identsS s
@@ -54,10 +55,11 @@ identsS = \case
Sat.BlockStat xs -> concatMap identsS xs
Sat.ApplStat e es -> identsE e ++ concatMap identsE es
Sat.UOpStat _op e -> identsE e
- Sat.AssignStat e1 e2 -> identsE e1 ++ identsE e2
+ Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2
Sat.LabelStat _l s -> identsS s
Sat.BreakStat{} -> []
Sat.ContinueStat{} -> []
+ Sat.FuncStat i args body -> [i] ++ args ++ identsS body
{-# INLINE identsE #-}
identsE :: Sat.JExpr -> [Ident]
@@ -148,6 +150,8 @@ jmcompos ret app f' v =
ReturnStat i -> ret ReturnStat `app` f i
IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'
WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s
+ ForStat init p step body -> ret ForStat `app` f init `app` f p
+ `app` f step `app` f body
ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s
SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d
where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l
@@ -158,6 +162,7 @@ jmcompos ret app f' v =
AssignStat e e' -> ret AssignStat `app` f e `app` f e'
UnsatBlock _ -> ret v'
ContinueStat l -> ret (ContinueStat l)
+ FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body
BreakStat l -> ret (BreakStat l)
LabelStat l s -> ret (LabelStat l) `app` f s
JMGExpr v' -> ret JMGExpr `app` case v' of
@@ -217,7 +222,6 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
--------------------------------------------------------------------------------
-- Translation
--
--- This will be moved after GHC.JS.Syntax is removed
--------------------------------------------------------------------------------
satJStat :: JStat -> Sat.JStat
satJStat = witness . proof
@@ -229,6 +233,9 @@ satJStat = witness . proof
witness (ReturnStat e) = Sat.ReturnStat (satJExpr e)
witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e)
witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e)
+ witness (ForStat init p step body) = Sat.ForStat
+ (witness init) (satJExpr p)
+ (witness step) (witness body)
witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i
(satJExpr iter)
(witness body)
@@ -240,12 +247,13 @@ satJStat = witness . proof
witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs
witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand)
witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand)
- witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs)
+ witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) Sat.AssignOp (satJExpr rhs)
witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt)
witness (BreakStat Nothing) = Sat.BreakStat Nothing
witness (BreakStat (Just l)) = Sat.BreakStat $! Just l
witness (ContinueStat Nothing) = Sat.ContinueStat Nothing
witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l
+ witness (FuncStat i args body) = Sat.FuncStat i args (witness body)
witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly"
diff --git a/compiler/GHC/JS/Unsat/Syntax.hs b/compiler/GHC/JS/Unsat/Syntax.hs
index f5ab076aa5..d873caa804 100644
--- a/compiler/GHC/JS/Unsat/Syntax.hs
+++ b/compiler/GHC/JS/Unsat/Syntax.hs
@@ -146,6 +146,7 @@ data JStat
| ReturnStat JExpr -- ^ Return
| IfStat JExpr JStat JStat -- ^ If
| WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True
+ | ForStat JStat JExpr JStat JStat -- ^ For
| ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True
| SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch
| TryStat JStat Ident JStat JStat -- ^ Try
@@ -157,6 +158,7 @@ data JStat
| LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic
| BreakStat (Maybe JsLabel) -- ^ Break
| ContinueStat (Maybe JsLabel) -- ^ Continue
+ | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition
deriving (Eq, Typeable, Generic)
-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of
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
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index a0a5f23133..fc2151f547 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -532,6 +532,7 @@ Library
GHC.IfaceToCore
GHC.Iface.Type
GHC.JS.Make
+ GHC.JS.Optimizer
GHC.JS.Ppr
GHC.JS.Syntax
GHC.JS.Transform
@@ -672,7 +673,6 @@ Library
GHC.StgToJS.Object
GHC.StgToJS.Prim
GHC.StgToJS.Profiling
- GHC.StgToJS.Printer
GHC.StgToJS.Regs
GHC.StgToJS.Rts.Types
GHC.StgToJS.Rts.Rts
@@ -686,6 +686,7 @@ Library
GHC.StgToJS.Linker.Linker
GHC.StgToJS.Linker.Types
GHC.StgToJS.Linker.Utils
+ GHC.StgToJS.Linker.Opt
GHC.Stg.Unarise
GHC.SysTools
GHC.SysTools.Ar
View Lorry Controller Status