[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: JS: add simple optimizer

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Thu Feb 15 20:03:48 UTC 2024



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
d7e72d9d by Luite Stegeman at 2024-02-15T15:03:22-05:00
JS: add simple optimizer

The simple optimizer reduces the size of the code generated by the
JavaScript backend without the complexity and performance penalty
of the optimizer in GHCJS.

Also see #22736

Metric Decrease:
    libdir
    size_hello_artifact

- - - - -
5b9a838f by Matthew Pickering at 2024-02-15T15:03:22-05:00
base: Expose `--no-automatic-time-samples` in `GHC.RTS.Flags` API

This patch builds on 5077416e12cf480fb2048928aa51fa4c8fc22cf1 and
modifies the base API to reflect the new RTS flag.

CLC proposal #243 - https://github.com/haskell/core-libraries-committee/issues/243

Fixes #24337

- - - - -


22 changed files:

- compiler/GHC/JS/JStg/Syntax.hs
- compiler/GHC/JS/Make.hs
- + compiler/GHC/JS/Opt/Expr.hs
- + compiler/GHC/JS/Opt/Simple.hs
- compiler/GHC/JS/Optimizer.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/ghc.cabal.in
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/RTS/Flags.hsc
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/javascript/opt/all.T
- testsuite/tests/javascript/opt/deadCodeElim.hs
- + testsuite/tests/javascript/opt/jsOptimizer.hs


Changes:

=====================================
compiler/GHC/JS/JStg/Syntax.hs
=====================================
@@ -1,12 +1,9 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE BlockArguments #-}
@@ -265,6 +262,7 @@ data JVal
   | JInt     Integer                    -- ^ A BigInt
   | JStr     FastString                 -- ^ A String
   | JRegEx   FastString                 -- ^ A Regex
+  | JBool    Bool                       -- ^ A Boolean
   | JHash    (UniqMap FastString JStgExpr) -- ^ A JS HashMap: @{"foo": 0}@
   | JFunc    [Ident] JStgStat              -- ^ A function
   deriving (Eq, Typeable, Generic)
@@ -281,7 +279,7 @@ data Op
   | StrictNeqOp     -- ^ Strict InEquality      `!==`
   | GtOp            -- ^ Greater Than:          `>`
   | GeOp            -- ^ Greater Than or Equal: `>=`
-  | LtOp            -- ^ Less Than:             <
+  | LtOp            -- ^ Less Than:              <
   | LeOp            -- ^ Less Than or Equal:     <=
   | AddOp           -- ^ Addition:               +
   | SubOp           -- ^ Subtraction:            -


=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -651,11 +651,11 @@ undefined_ = var "undefined"
 
 -- | The JS literal 'true'
 true_ :: JStgExpr
-true_ = var "true"
+true_ = ValExpr (JBool True)
 
 -- | The JS literal 'false'
 false_ :: JStgExpr
-false_ = var "false"
+false_ = ValExpr (JBool False)
 
 returnStack :: JStgStat
 returnStack = ReturnStat (ApplExpr (var "h$rs") [])


=====================================
compiler/GHC/JS/Opt/Expr.hs
=====================================
@@ -0,0 +1,186 @@
+{-# LANGUAGE ViewPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.JS.Opt.Expr
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Jeffrey Young  <jeffrey.young at iohk.io>
+--                Luite Stegeman <luite.stegeman at iohk.io>
+--                Sylvain Henry  <sylvain.henry at iohk.io>
+--                Josh Meredith  <josh.meredith at iohk.io>
+-- Stability   :  experimental
+--
+--
+--  This module contains a simple expression optimizer that performs constant
+--  folding and some boolean expression optimizations.
+-----------------------------------------------------------------------------
+
+module GHC.JS.Opt.Expr (optExprs) where
+
+import GHC.Prelude hiding (shiftL, shiftR)
+
+import GHC.JS.Syntax
+
+import Data.Bifunctor (second)
+import Data.Bits (shiftL, shiftR, (.^.))
+import Data.Int (Int32)
+
+{-
+  Optimize expressions in a statement.
+
+  This is best done after running the simple optimizer in GHC.JS.Opt.Simple,
+  which eliminates redundant assignments and produces expressions that can be
+  optimized more effectively.
+ -}
+optExprs :: JStat -> JStat
+optExprs s = go s
+  where
+    go (DeclStat v mb_e) = DeclStat v (fmap opt mb_e)
+    go (AssignStat lhs op rhs) = AssignStat (opt lhs) op (opt rhs)
+    go (ReturnStat e) = ReturnStat (opt e)
+    go (BlockStat ss) = BlockStat (map go ss)
+    go (IfStat e s1 s2) = IfStat (optCond e) (go s1) (go s2)
+    go (WhileStat b e s) = WhileStat b (optCond e) (go s)
+    go (ForStat s1 e s2 s3) = ForStat (go s1) (optCond e) (go s2) (go s3)
+    go (ForInStat b v e s) = ForInStat b v (opt e) (go s)
+    go (SwitchStat e cases s) = SwitchStat (opt e)
+                                           (map (second go) cases)
+                                           (go s)
+    go (TryStat s1 v s2 s3) = TryStat (go s1) v (go s2) (go s3)
+    go (ApplStat e es) = ApplStat (opt e) (map opt es)
+    go (UOpStat op e) = UOpStat op (opt e)
+    go (LabelStat lbl s) = LabelStat lbl (go s)
+    go s@(BreakStat{}) = s
+    go s@(ContinueStat{}) = s
+    go (FuncStat n vs s) = FuncStat n vs (go s)
+
+ -- remove double negation if we're using the expression in a loop/if condition
+optCond :: JExpr -> JExpr
+optCond e = let f (UOpExpr NotOp (UOpExpr NotOp e')) = f e'
+                f e' = e'
+            in f (opt e)
+
+opt :: JExpr -> JExpr
+opt (ValExpr v)          = ValExpr v
+opt (SelExpr e i)        = SelExpr (opt e) i
+opt (IdxExpr e1 e2)      = IdxExpr (opt e1) (opt e2)
+-- ((c_e ? 1 : 0) === 1)   ==> !!c_e
+-- ((c_e ? 1 : 0) === 0)   ==> !c_e
+opt(InfixExpr StrictEqOp (IfExpr c_e (opt -> t_e) (opt -> f_e)) (opt -> e))
+    | ValExpr t_v <- t_e
+    , ValExpr v <- e
+    , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e)
+    | ValExpr f_v <- f_e
+    , ValExpr v <- e
+    , eqVal f_v v = UOpExpr NotOp (opt c_e)
+    | otherwise = InfixExpr StrictEqOp (IfExpr c_e t_e f_e) e
+-- (1 === (c_e ? 1 : 0))   ==> !!c_e
+-- (0 === (c_e ? 1 : 0))   ==> !c_e
+opt(InfixExpr StrictEqOp (opt -> e) (IfExpr (opt -> c_e) (opt -> t_e) (opt -> f_e)))
+    | ValExpr t_v <- t_e
+    , ValExpr v <- e
+    , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e)
+    | ValExpr f_v <- f_e
+    , ValExpr v <- e
+    , eqVal f_v v = UOpExpr NotOp c_e
+    | otherwise = InfixExpr StrictEqOp e (IfExpr c_e t_e f_e)
+opt (InfixExpr op (opt -> e1) (opt -> e2))
+  | (ValExpr (JInt n1)) <- e1
+  , (ValExpr (JInt n2)) <- e2
+  , Just v <- optInt op n1 n2 = ValExpr v
+  | (ValExpr (JBool b1)) <- e1
+  , (ValExpr (JBool b2)) <- e2
+  , Just v <- optBool op b1 b2 = ValExpr v
+  | otherwise = InfixExpr op e1 e2
+opt (UOpExpr op e)       = UOpExpr op (opt e)
+opt (IfExpr e1 e2 e3)    = IfExpr (optCond e1) (opt e2) (opt e3)
+opt (ApplExpr e es)      = ApplExpr (opt e) (map opt es)
+
+{-
+  Optimizations for operations on two known boolean values
+ -}
+optBool :: Op -> Bool -> Bool -> Maybe JVal
+optBool LAndOp x y = Just (JBool (x && y))
+optBool LOrOp x y = Just (JBool (x || y))
+optBool EqOp x y = Just (JBool (x == y))
+optBool StrictEqOp x y = Just (JBool (x == y))
+optBool NeqOp x y = Just (JBool (x /= y))
+optBool StrictNeqOp x y = Just (JBool (x /= y))
+optBool _ _ _ = Nothing
+
+{-
+  Optimizations for operations on two known integer values
+ -}
+optInt :: Op -> Integer -> Integer -> Maybe JVal
+optInt ZRightShiftOp n m = Just $
+  JInt (toInteger $ (n .&. 0xffffffff) `shiftR` fromInteger (m .&. 0x1f))
+optInt BOrOp n m = Just (truncOp (.|.) n m)
+optInt BAndOp n m = Just (truncOp (.&.) n m)
+optInt BXorOp n m = Just (truncOp (.^.) n m)
+optInt RightShiftOp n m = Just (shiftOp shiftR n m)
+optInt LeftShiftOp n m = Just (shiftOp shiftL n m)
+optInt AddOp n m = smallIntOp (+) n m
+optInt SubOp n m = smallIntOp (-) n m
+optInt MulOp n m = smallIntOp (*) n m
+optInt op n m
+  | Just cmp <- getCmpOp op, isSmall52 n && isSmall52 m
+  = Just (JBool (cmp n m))
+optInt _ _ _ = Nothing
+
+smallIntOp :: (Integer -> Integer -> Integer)
+           -> Integer -> Integer -> Maybe JVal
+smallIntOp op n m
+  | isSmall52 n && isSmall52 m && isSmall52 r = Just (JInt r)
+  | otherwise                                 = Nothing
+  where
+    r = op n m
+
+getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool)
+getCmpOp EqOp = Just (==)
+getCmpOp StrictEqOp = Just (==)
+getCmpOp NeqOp = Just (/=)
+getCmpOp StrictNeqOp = Just (/=)
+getCmpOp GtOp = Just (>)
+getCmpOp GeOp = Just (>=)
+getCmpOp LtOp = Just (<)
+getCmpOp LeOp = Just (<=)
+getCmpOp _ = Nothing
+
+shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal
+shiftOp op n m = JInt $ toInteger
+   (fromInteger n `op` (fromInteger m .&. 0x1f))
+
+{-
+  JavaScript bitwise operations truncate numbers to 32 bit signed integers.
+  Here we do the same when constant folding with this kind of operators.
+ -}
+truncOp :: (Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal
+truncOp op n m = JInt $ toInteger
+   (fromInteger n `op` fromInteger m)
+
+{-
+  JavaScript numbers are IEEE 754 double precision floats, which have a
+  52-bit mantissa. This returns True if the given integer can definitely
+  be represented without loss of precision in a JavaScript number.
+ -}
+isSmall52 :: Integer -> Bool
+isSmall52 n = n >= -0x10000000000000 && n <= 0xfffffffffffff
+
+{-
+  In JavaScript, e1 === e2 is not always true even if expressions e1 and e2
+  are syntactically equal, examples:
+
+    - NaN !== NaN  (NaN is not equal to itself)
+    - [1] !== [1]  (different arrays allocated)
+    - f() !== f()
+
+  This returns True if the values are definitely equal in JavaScript
+ -}
+eqVal :: JVal -> JVal -> Bool
+eqVal (JInt n1) (JInt n2)   = n1 == n2
+eqVal (JStr s1) (JStr s2)   = s1 == s2
+eqVal (JBool b1) (JBool b2) = b1 == b2
+eqVal (JDouble (SaneDouble d1)) (JDouble (SaneDouble d2))
+  | not (isNaN d1) && not (isNaN d2) = d1 == d2
+eqVal _ _ = False
\ No newline at end of file


=====================================
compiler/GHC/JS/Opt/Simple.hs
=====================================
@@ -0,0 +1,607 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.JS.Opt.Simple
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Jeffrey Young  <jeffrey.young at iohk.io>
+--                Luite Stegeman <luite.stegeman at iohk.io>
+--                Sylvain Henry  <sylvain.henry at iohk.io>
+--                Josh Meredith  <josh.meredith at iohk.io>
+-- Stability   :  experimental
+--
+--
+-- * Simple optimizer for the JavaScript IR
+--
+--     This is a simple optimizer for the JavaScript IR. It is intended to be
+--     the first optimization pass after generating the JavaScript IR.
+--
+-- * Design
+--
+--     The optimizer is invoked on the top-level JStat. It leaves the top-level
+--     scope alone, but traverses into each function body and optimizes it.
+--     Nested functions are mostly left alone, since they are uncommon in
+--     generated code.
+--
+--     The optimizations are:
+--
+--       - rename local variables to shorter names
+--       - remove unused variables
+--       - remove trivial assignments: x = x
+--       - "float" expressions without side effects:
+--       -   var x = 1; var y = x + 1; -> var y = 1 + 1;
+--
+-- * Limitations
+--
+--     The simple optimization pass is intended to be fast and applicable to
+--     almost all generated JavaScript code. Limitations are:
+--
+--       - optimization is disabled if an `eval` statement is encountered
+--       - variables declared in nested scopes are not renamed
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE OverloadedStrings #-}
+module GHC.JS.Opt.Simple (simpleOpt) where
+
+import GHC.Prelude
+
+import GHC.JS.Opt.Expr
+import GHC.JS.Syntax
+
+import GHC.Data.FastString
+import qualified GHC.Types.Unique.Map as UM
+import GHC.Types.Unique.Map (UniqMap)
+import qualified GHC.Types.Unique.Set as US
+
+import Control.Monad
+import Data.Function
+import Data.List (sortBy)
+import Data.Maybe
+import qualified Data.Semigroup as Semi
+
+
+data Multiplicity = Zero | One | Many
+    deriving (Eq, Ord, Show)
+
+data VarValue = Unassigned
+              | AssignedOnce
+              | AssignedOnceKnown !JExpr
+              | AssignedMany
+
+data VarDecl = NoDecl -- not declared in analyzed scope (possibly deeper or global)
+             | ArgDecl !Int -- argument in analyzed scope
+             | LocalDecl !Int -- local variable in analyzed scope
+  deriving (Eq, Show)
+
+isLocalOrArg :: VarDecl -> Bool
+isLocalOrArg (LocalDecl {}) = True
+isLocalOrArg (ArgDecl {})   = True
+isLocalOrArg _              = False
+
+isDecl :: VarDecl -> Bool
+isDecl NoDecl = False
+isDecl _      = True
+
+instance Semi.Semigroup VarDecl where
+  NoDecl <> x = x
+  x <> NoDecl = x
+  ArgDecl n <> ArgDecl m = ArgDecl (min n m)
+  LocalDecl n <> LocalDecl m = LocalDecl (min n m)
+  ArgDecl n <> _ = ArgDecl n
+  _ <> ArgDecl n = ArgDecl n
+
+instance Ord VarDecl where
+  compare NoDecl NoDecl = EQ
+  compare NoDecl _      = LT
+  compare _      NoDecl = GT
+  compare (ArgDecl n) (ArgDecl m) = compare n m
+  compare (ArgDecl {}) _ = LT
+  compare _ (ArgDecl {}) = GT
+  compare (LocalDecl n) (LocalDecl m) = compare n m
+
+data JFunction = JFunction [Ident] JStat
+
+instance Semi.Semigroup VarValue where
+  Unassigned <> x = x
+  x <> Unassigned = x
+  _ <> _ = AssignedMany
+
+instance Monoid VarValue where
+  mempty = Unassigned
+  mappend = (Semi.<>)
+
+instance Semigroup Multiplicity where
+    Zero <> x = x
+    x <> Zero = x
+    _ <> _    = Many
+
+instance Monoid Multiplicity where
+    mempty = Zero
+    mappend = (Semi.<>)
+
+data VarUsage = VarUsage
+    { varUsed :: !Multiplicity
+    , varAssigned :: !VarValue
+    , varDeclared :: !VarDecl
+    , varDeepDeclared :: !Bool
+    }
+
+assignedMultiple :: VarUsage -> Bool
+assignedMultiple VarUsage { varAssigned = AssignedMany } = True
+assignedMultiple _                                       = False
+
+data SimpleRewrite = SimpleRewrite
+    { renameVar :: UniqMap Ident Ident
+    , varUsage :: UniqMap Ident VarUsage
+    }
+
+instance Semigroup VarUsage where
+    x <> y = VarUsage
+        { varUsed = varUsed x Semi.<> varUsed y
+        , varAssigned = varAssigned x Semi.<> varAssigned y
+        , varDeclared = varDeclared x Semi.<> varDeclared y
+        , varDeepDeclared = varDeepDeclared x || varDeepDeclared y
+        }
+
+instance Monoid VarUsage where
+    mempty = VarUsage Zero Unassigned NoDecl False
+
+disableOpt :: Bool
+-- disableOpt = True
+disableOpt = False
+
+simpleOpt :: JStat -> JStat
+simpleOpt x | disableOpt = x
+simpleOpt (BlockStat xs) = BlockStat (map simpleOpt xs)
+simpleOpt (AssignStat lhs AssignOp (ValExpr (JFunc args body)))  =
+     let JFunction args' body' = simpleOptFunction (JFunction args body)
+     in AssignStat lhs AssignOp (ValExpr (JFunc args' body'))
+simpleOpt (FuncStat name args body) =
+     let JFunction args' body' = simpleOptFunction (JFunction args body)
+     in  FuncStat name args' body'
+simpleOpt s = s
+
+simpleOptFunction :: JFunction -> JFunction
+simpleOptFunction jf = s_opt
+  where
+    -- we need to run it twice since floating in the first pass can
+    -- cause unused variables that can be removed in the second pass
+    s_opt  = functionOptExprs $ maybe jf (`simpleRewrite` s_opt0) mb_rw
+    mb_rw  = mkRewrite True (simpleAnalyze s_opt0)
+    s_opt0 = functionOptExprs $ maybe jf (`simpleRewrite` jf) mb_rw0
+    mb_rw0 = mkRewrite False (simpleAnalyze jf)
+
+functionOptExprs :: JFunction -> JFunction
+functionOptExprs (JFunction args s) = JFunction args (optExprs s)
+
+newLocals :: [Ident]
+newLocals = filter (not . isReserved  ) $
+            map (TxtI . mkFastString) $
+            map (:[]) chars0 ++ concatMap mkIdents [1..]
+  where
+    mkIdents n = [c0:cs | c0 <- chars0, cs <- replicateM n chars]
+    chars0 = ['a'..'z']++['A'..'Z']
+    chars = chars0++['0'..'9']
+    isReserved (TxtI i) = i `US.elementOfUniqSet` reservedSet
+    reservedSet = US.mkUniqSet reserved
+    reserved = [  -- reserved words
+                  "abstract", "arguments", "await", "boolean"
+                , "break", "byte", "case", "catch"
+                , "char", "class", "const", "continue"
+                , "debugger", "default", "delete", "do"
+                , "double", "else", "enum", "eval"
+                , "export", "extends", "false", "final"
+                , "finally", "float", "for", "function"
+                , "goto", "if", "implements", "import"
+                , "in", "instanceof", "int", "interface"
+                , "let", "long", "native", "new"
+                , "null", "package", "private", "protected"
+                , "public", "return", "short", "static"
+                , "super", "switch", "synchronized", "this"
+                , "throw", "throws", "transient", "true"
+                , "try", "typeof", "var", "void"
+                , "volatile", "while", "with", "yield"
+                -- some special values
+                , "as", "async", "from", "get"
+                , "of", "NaN", "prototype", "undefined"
+                ]
+
+mkRewrite :: Bool -> AnalysisResult -> Maybe SimpleRewrite
+mkRewrite do_rename a
+  | arBailout a = Nothing
+  | otherwise  = Just $
+  SimpleRewrite { renameVar = if do_rename
+                              then UM.listToUniqMap (zip localVars newVars)
+                              else UM.emptyUniqMap
+                , varUsage = vu
+                }
+  where
+    vu :: UM.UniqMap Ident VarUsage
+    vu = arVarUsage a
+
+    -- local variables in the order that they were declared
+    localVars :: [Ident]
+    localVars =
+        map fst
+         -- recover original order and remove non-determinism
+      . sortBy (compare `on` snd)
+      . map (\(v, u) -> (v, varDeclared u))
+      . filter (isDecl . varDeclared . snd)
+      -- non-determinism is removed by sorting afterwards
+      $ UM.nonDetUniqMapToList vu
+    -- we can't rename variables that are used in the global scope
+    blockedNames :: US.UniqSet Ident
+    blockedNames =
+      US.mkUniqSet $
+      map fst (
+      filter (\(_k,v) -> (not . isDecl) (varDeclared v) || varDeepDeclared v)
+             (UM.nonDetUniqMapToList vu))
+
+
+    newVars :: [Ident]
+    newVars = filter (not . (`US.elementOfUniqSet` blockedNames)) newLocals
+
+simpleRewrite :: SimpleRewrite -> JFunction -> JFunction
+simpleRewrite rw (JFunction args stat)= JFunction (map varReplace args) (go stat)
+  where
+    zeroUsed :: JExpr -> Bool
+    zeroUsed (ValExpr (JVar v)) =
+      maybe True ((== Zero) . varUsed) (UM.lookupUniqMap (varUsage rw) v) &&
+      maybe False (isDecl . varDeclared) (UM.lookupUniqMap (varUsage rw) v)
+    zeroUsed _                  = False
+
+    varReplace :: Ident -> Ident
+    varReplace v = fromMaybe v (UM.lookupUniqMap (renameVar rw) v)
+
+    {-
+      We can sometimes float down an expression to avoid an assignment:
+
+      var x = e;
+      f(x);
+        ==>
+      f(e);
+
+      This can only be done if the expression has no side effects and x is
+      only used once.
+
+      Heap object property lookups cannot be floated just yet, since we
+      don't know whether an object is mutable or not. For example a thunk
+      can be blackholed, which would change the result if we float the lookup
+      after the blackholing.
+     -}
+
+    mayBeFloated :: JExpr -> Bool
+    mayBeFloated (ValExpr v) = mayBeFloatedV v
+    mayBeFloated (SelExpr _e _) = False
+    mayBeFloated (IdxExpr _e1 _e2) = False
+    mayBeFloated (InfixExpr _ e1 e2)= mayBeFloated e1 && mayBeFloated e2
+    mayBeFloated (UOpExpr _ _e) = False
+    mayBeFloated (IfExpr e1 e2 e3) = mayBeFloated e1 &&
+                                     mayBeFloated e2 &&
+                                     mayBeFloated e3
+    mayBeFloated (ApplExpr e es)
+      | ValExpr (JVar (TxtI i)) <- e, isClosureAllocator i = all mayBeFloated es
+      | otherwise                                          = False
+
+    mayBeFloatedV :: JVal -> Bool
+    mayBeFloatedV (JVar v)
+      | Just vu <- UM.lookupUniqMap (varUsage rw) v
+      = isDecl (varDeclared vu) && not (assignedMultiple vu)
+      | otherwise = False
+    mayBeFloatedV (JList es) = all mayBeFloated es
+    mayBeFloatedV (JDouble {}) = True
+    mayBeFloatedV (JInt {}) = True
+    mayBeFloatedV (JStr {}) = True
+    mayBeFloatedV (JRegEx {}) = True
+    mayBeFloatedV (JBool {}) = True
+    mayBeFloatedV (JHash ps) = all (mayBeFloated . snd)
+                                   (UM.nonDetUniqMapToList ps)
+    mayBeFloatedV (JFunc {}) = False
+
+    {-
+       we allow small literals and local variables and arguments to be
+       duplicated, since they tend to take up little space.
+      -}
+    mayDuplicate :: JExpr -> Bool
+    mayDuplicate (ValExpr (JVar i))
+      | Just vu <- (UM.lookupUniqMap (varUsage rw) i)
+      = isLocalOrArg (varDeclared vu)
+    mayDuplicate (ValExpr (JInt n))     = abs n < 1000000
+    mayDuplicate (ValExpr (JDouble {})) = True
+    mayDuplicate _                      = False
+
+    zeroAssigned :: Ident -> Bool
+    zeroAssigned v
+       | Just vu <- UM.lookupUniqMap (varUsage rw) v
+       = case varAssigned vu of
+          Unassigned -> True
+          _          -> False
+      | otherwise = False
+
+    assignedAtMostOnce :: Ident -> Bool
+    assignedAtMostOnce v
+      | Just vu <- UM.lookupUniqMap (varUsage rw) v =
+        case varAssigned vu of
+          Unassigned           -> True
+          AssignedOnce         -> True
+          AssignedOnceKnown {} -> True
+          AssignedMany         -> False
+      | otherwise = False
+
+    go :: JStat -> JStat
+    go (DeclStat v mb_e)
+        | zeroUsed (ValExpr (JVar v)) =
+          case mb_e of
+            Nothing | zeroAssigned v -> BlockStat []
+                    | otherwise      -> DeclStat (varReplace v) Nothing
+            Just e | not (mayHaveSideEffects e) && assignedAtMostOnce v
+                                                -> BlockStat []
+                   | otherwise                  -> DeclStat (varReplace v) (Just (goE True e))
+        | otherwise = DeclStat (varReplace v) (fmap (goE True) mb_e)
+    go (AssignStat lhs aop e)
+        | ValExpr (JVar i) <- lhs, isTrivialAssignment i aop e = BlockStat []
+        | zeroUsed lhs && not (mayHaveSideEffects e) = BlockStat []
+        | zeroUsed lhs = AssignStat (goE False lhs) aop (goE True e)
+        | otherwise = AssignStat (goE False lhs) aop (goE True e)
+    go (ReturnStat e) = ReturnStat (goE True e)
+    go (BlockStat ss) = flattenBlock (map go ss)
+    go (IfStat e s1 s2) = IfStat (goE True e) (go s1) (go s2)
+    go (WhileStat b e s) = WhileStat b (goE True e) (go s)
+    go (ForStat s1 e s2 s3) = ForStat (go s1) (goE True e) (go s2) (go s3)
+    go (ForInStat b v e s) = ForInStat b (varReplace v) (goE True e) (go s)
+    go (SwitchStat e cases s) = SwitchStat (goE True e)
+                                           (map (\(c,cs) -> (c, go cs)) cases)
+                                           (go s)
+    go (TryStat s1 v s2 s3) = TryStat (go s1) (varReplace v) (go s2) (go s3)
+    go (ApplStat e es) = ApplStat (goE True e) (map (goE True) es)
+    go (UOpStat uop e) = UOpStat uop (goE False e)
+    go (LabelStat lbl s) = LabelStat lbl (go s)
+    go s@(BreakStat {}) = s
+    go s@(ContinueStat {}) = s
+    go (FuncStat i args s) = FuncStat i (map varReplace args) (go s)
+
+    goE :: Bool -> JExpr -> JExpr
+    goE rhs (ValExpr (JVar v))
+      | rhs
+      , Just vu <- UM.lookupUniqMap (varUsage rw) v
+      , AssignedOnceKnown ee <- varAssigned vu
+      , varUsed vu == One || mayDuplicate ee
+      , isDecl (varDeclared vu)
+      , mayBeFloated ee
+      = goE rhs ee
+    goE _rhs (ValExpr v) = ValExpr (goV v)
+    goE rhs (SelExpr e i) = SelExpr (goE rhs e) i
+    goE rhs (IdxExpr e1 e2) = IdxExpr (goE rhs e1) (goE rhs e2)
+    goE rhs (InfixExpr op e1 e2) = InfixExpr op (goE rhs e1) (goE rhs e2)
+    goE rhs (UOpExpr op e) = UOpExpr op (goE rhs e)
+    goE rhs (IfExpr e1 e2 e3) = IfExpr (goE rhs e1) (goE rhs e2) (goE rhs e3)
+    goE rhs (ApplExpr e es) = ApplExpr (goE rhs e) (map (goE rhs) es)
+
+    goV :: JVal -> JVal
+    goV (JVar v) = JVar (varReplace v)
+    goV (JList es) = JList (map (goE True) es)
+    goV (JHash ps) = JHash (fmap (goE True) ps)
+    goV v@(JFunc {}) = v
+    goV v@(JDouble {}) = v
+    goV v@(JInt {}) = v
+    goV v@(JStr {}) = v
+    goV v@(JRegEx {}) = v
+    goV v@(JBool {}) = v
+
+flattenBlock :: [JStat] -> JStat
+flattenBlock stats =
+    case filter (/= BlockStat []) stats of
+        []  -> BlockStat []
+        [s] -> s
+        ss  -> BlockStat ss
+
+data AnalysisResult = AnalysisResult
+  { arBailout       :: !Bool
+  , arVarUsage      :: !(UniqMap Ident VarUsage)
+  , arDeclaredCount :: !Int
+  }
+
+simpleAnalyze :: JFunction -> AnalysisResult
+simpleAnalyze (JFunction args body) = go False (AnalysisResult False start 0) body
+  where
+    start :: UniqMap Ident VarUsage
+    start = UM.listToUniqMap
+          $ zipWith (\n v -> (v, VarUsage Zero Unassigned (ArgDecl n) False))
+                    [0..]
+                    args
+
+    add :: Ident -> VarUsage -> AnalysisResult -> AnalysisResult
+    add i vu m = m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu }
+
+
+    declare :: Bool -> Ident -> Maybe JExpr -> AnalysisResult -> AnalysisResult
+    declare True i _assign m = -- declaration in deeper scope
+      let vu = VarUsage Zero AssignedMany NoDecl True
+      in  m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu}
+    declare False i assign m = -- declaration in analyzed scope
+      let count  = arDeclaredCount m
+          !newCount
+            | Just (VarUsage _ _ (LocalDecl _) _) <-
+                UM.lookupUniqMap (arVarUsage m) i = count -- already declared
+            | otherwise                           = count + 1
+          vassign | Just e <- assign = AssignedOnceKnown e
+                  | otherwise        = Unassigned
+          !vu = VarUsage Zero vassign (LocalDecl count) False
+      in m { arDeclaredCount = newCount
+           , arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu
+           }
+
+    go :: Bool -> AnalysisResult -> JStat -> AnalysisResult
+    go deep u (DeclStat v mb_e) =
+        case mb_e of
+            Nothing -> declare deep v mb_e u
+            Just e  -> declare deep v mb_e (goE u e)
+    go _deep u (AssignStat (ValExpr (JVar v)) aop e) =
+        let use = case aop of
+                    AssignOp -> Zero
+                    _        -> One
+        in add v (VarUsage use (AssignedOnceKnown e) NoDecl False) (goE u e)
+    go _deep u (AssignStat lhs _aop rhs) = goE (goE u lhs) rhs
+    go _deep u (ReturnStat e) = goE u e
+    go deep u (BlockStat ss) = foldl' (go deep) u ss
+    go deep u (IfStat e s1 s2) = go deep (go deep (goE u e) s1) s2
+    go deep u (WhileStat _b e s) = go deep (goE u e) s
+    go deep u (ForStat s1 e s2 s3)
+      = go deep (go deep (goE (go deep u s1) e) s2) s3
+    go deep u (ForInStat b v e s) =
+      let !u' = if b then declare deep v Nothing u else u
+      in  add v (VarUsage Zero AssignedMany NoDecl True)
+                (go deep (go deep (goE u' e) s) s)
+    go deep u (SwitchStat e cases s)
+      = go deep (goE (foldl' (go deep) u (map snd cases)) e) s
+    go deep u (TryStat s1 v s2 s3)
+      = add v (VarUsage Zero AssignedMany NoDecl True)
+              (go deep (go deep (go deep u s1) s2) s3)
+    go _deep u (ApplStat e es)
+      | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True }
+      | otherwise = foldl' goE (goE u e) es
+    go _deep u (UOpStat op e)
+      | ValExpr (JVar v) <- e
+      , op `elem` [PreIncOp, PostIncOp, PreDecOp, PostDecOp] =
+          add v (VarUsage One AssignedOnce NoDecl False) u
+      | otherwise = goE u e
+    go deep u (LabelStat _ s) = go deep u s
+    go _deep u (BreakStat _) = u
+    go _deep u (ContinueStat _) = u
+    go _deep u (FuncStat _ vs s)
+      = go True (foldl' (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s
+
+    goE :: AnalysisResult -> JExpr -> AnalysisResult
+    goE u (ValExpr v) = goV u v
+    goE u (SelExpr e _i) = goE u e
+    goE u (IdxExpr e1 e2) = goE (goE u e1) e2
+    goE u (InfixExpr _ e1 e2) = goE (goE u e1) e2
+    goE u (UOpExpr _ e) = goE u e
+    goE u (IfExpr e1 e2 e3) = goE (goE (goE u e1) e2) e3
+    goE u (ApplExpr e es)
+      | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True }
+      | otherwise = foldl' goE (goE u e) es
+
+    goV :: AnalysisResult -> JVal -> AnalysisResult
+    goV u (JVar v)   = add v (VarUsage One Unassigned NoDecl False) u
+    goV u (JList es) = foldl' goE u es
+    goV u (JDouble _) = u
+    goV u (JInt _) = u
+    goV u (JStr _) = u
+    goV u (JRegEx _) = u
+    goV u (JBool _) = u
+    goV u (JHash ps) = foldl' goE u (map snd $ UM.nonDetUniqMapToList ps)
+    goV u (JFunc vs s)
+      = go True (foldl (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s
+
+-- | A trivial assignment is an assignment of a variable to itself: x = x
+isTrivialAssignment :: Ident -> AOp -> JExpr -> Bool
+isTrivialAssignment v AssignOp (ValExpr (JVar v')) = v == v'
+isTrivialAssignment _ _ _                          = False
+
+-- | Does the expression have side effects?
+--
+-- This only returns False if the expression definitely does not have side
+-- effects, i.e. it can be removed without changing the semantics if the
+-- result is not used.
+--
+-- Note: We have some assumptions here about Haskell RTS related values, which
+--       may not be true for all JavaScript code. We should really replace
+--       these with explicit nodes or annotations in the AST.
+--
+mayHaveSideEffects :: JExpr -> Bool
+-- special cases for Haskell things. These should really be special operations
+-- in the AST:
+-- 1. stack indexing does not have side effects
+mayHaveSideEffects (IdxExpr (ValExpr (JVar (TxtI i))) e)
+  | i == "h$stack" = mayHaveSideEffects e
+-- 2. we assume that x.d1, x.d2, ... are heap object property lookups,
+--    which do not have side effects
+mayHaveSideEffects (SelExpr e (TxtI i))
+  | isHeapObjectProperty i = mayHaveSideEffects e
+
+-- general cases (no Haskell RTS specific assumptions here):
+mayHaveSideEffects (ValExpr v) = mayHaveSideEffectsV v
+mayHaveSideEffects (SelExpr {}) = True
+mayHaveSideEffects (IdxExpr {}) = True
+mayHaveSideEffects (UOpExpr uop e) = uo || mayHaveSideEffects e
+    where
+        uo = case uop of
+              NotOp    -> False
+              BNotOp   -> False
+              NegOp    -> False
+              PlusOp   -> False
+              TypeofOp -> False
+              _        -> True
+mayHaveSideEffects (InfixExpr _o e1 e2) =
+  mayHaveSideEffects e1 || mayHaveSideEffects e2
+mayHaveSideEffects (IfExpr e1 e2 e3) =
+  mayHaveSideEffects e1 || mayHaveSideEffects e2 || mayHaveSideEffects e3
+mayHaveSideEffects (ApplExpr {}) = True
+
+mayHaveSideEffectsV :: JVal -> Bool
+mayHaveSideEffectsV (JVar {}) = False
+mayHaveSideEffectsV (JList es) = any mayHaveSideEffects es
+mayHaveSideEffectsV (JDouble {}) = False
+mayHaveSideEffectsV (JInt {}) = False
+mayHaveSideEffectsV (JStr {}) = False
+mayHaveSideEffectsV (JRegEx {}) = False
+mayHaveSideEffectsV (JBool {}) = False
+mayHaveSideEffectsV (JHash ps) = UM.anyUniqMap mayHaveSideEffects ps
+mayHaveSideEffectsV (JFunc {}) = True
+
+isHeapObjectProperty :: FastString -> Bool
+isHeapObjectProperty "d1"  = True
+isHeapObjectProperty "d2"  = True
+isHeapObjectProperty "d3"  = True
+isHeapObjectProperty "d4"  = True
+isHeapObjectProperty "d5"  = True
+isHeapObjectProperty "d6"  = True
+isHeapObjectProperty "d7"  = True
+isHeapObjectProperty "d8"  = True
+isHeapObjectProperty "d9"  = True
+isHeapObjectProperty "d10" = True
+isHeapObjectProperty "d11" = True
+isHeapObjectProperty "d12" = True
+isHeapObjectProperty "d13" = True
+isHeapObjectProperty "d14" = True
+isHeapObjectProperty "d15" = True
+isHeapObjectProperty "d16" = True
+isHeapObjectProperty "d17" = True
+isHeapObjectProperty "d18" = True
+isHeapObjectProperty "d19" = True
+isHeapObjectProperty "d20" = True
+isHeapObjectProperty "d21" = True
+isHeapObjectProperty "d22" = True
+isHeapObjectProperty "d23" = True
+isHeapObjectProperty "d24" = True
+
+isHeapObjectProperty _     = False
+
+isClosureAllocator :: FastString -> Bool
+isClosureAllocator "h$c1" = True
+isClosureAllocator "h$c2" = True
+isClosureAllocator "h$c3" = True
+isClosureAllocator "h$c4" = True
+isClosureAllocator "h$c5" = True
+isClosureAllocator "h$c6" = True
+isClosureAllocator "h$c7" = True
+isClosureAllocator "h$c8" = True
+isClosureAllocator "h$c9" = True
+isClosureAllocator "h$c10" = True
+isClosureAllocator "h$c11" = True
+isClosureAllocator "h$c12" = True
+isClosureAllocator "h$c13" = True
+isClosureAllocator "h$c14" = True
+isClosureAllocator "h$c15" = True
+isClosureAllocator "h$c16" = True
+isClosureAllocator "h$c17" = True
+isClosureAllocator "h$c18" = True
+isClosureAllocator "h$c19" = True
+isClosureAllocator "h$c20" = True
+isClosureAllocator "h$c21" = True
+isClosureAllocator "h$c22" = True
+isClosureAllocator "h$c23" = True
+isClosureAllocator "h$c24" = True
+isClosureAllocator _       = False
\ No newline at end of file


=====================================
compiler/GHC/JS/Optimizer.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -46,6 +46,8 @@ import GHC.JS.Syntax
 
 import Control.Arrow
 
+import qualified GHC.JS.Opt.Simple as Simple
+
 {-
 Note [Unsafe JavaScript optimizations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -85,9 +87,12 @@ normally be unsafe.
 --                        Top level Driver
 --------------------------------------------------------------------------------
 jsOptimize :: JStat -> JStat
-jsOptimize = go
+jsOptimize s0 = jsOptimizeStat (Simple.simpleOpt s0)
+
+jsOptimizeStat :: JStat -> JStat
+jsOptimizeStat s0 = go s0
   where
-    p_opt = jsOptimize
+    p_opt = jsOptimizeStat
     opt   = jsOptimize'
     e_opt = jExprOptimize
     -- base case
@@ -147,7 +152,7 @@ jExprOptimize (InfixExpr op l r)  = InfixExpr op (jExprOptimize l) (jExprOptimiz
 -- | drive optimizations to anonymous functions and over expressions
 jValOptimize ::  JVal -> JVal
 -- base case
-jValOptimize (JFunc args body) = JFunc args (jsOptimize body)
+jValOptimize (JFunc args body) = JFunc args (jsOptimizeStat body)
 -- recursive cases
 jValOptimize (JList exprs)     = JList (jExprOptimize <$> exprs)
 jValOptimize (JHash hash)      = JHash (jExprOptimize <$> hash)
@@ -157,6 +162,7 @@ jValOptimize x at JDouble{}       = x
 jValOptimize x at JInt{}          = x
 jValOptimize x at JStr{}          = x
 jValOptimize x at JRegEx{}        = x
+jValOptimize x at JBool{}         = x
 
 -- | A block transformation is a function from a stream of syntax to another
 -- stream
@@ -193,11 +199,7 @@ tailLoop = BlockOpt $ \loop next -> \case
     -- 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
---------------------------------------------------------------------------------
+    (x:xs) -> next (jsOptimizeStat x : loop xs)
 
 {- |
    Catch modify and assign operators:
@@ -212,9 +214,26 @@ tailLoop = BlockOpt $ \loop next -> \case
 -}
 combineOps :: BlockOpt
 combineOps = BlockOpt $ \loop next ->
-  \case
-    -- find a op pattern, and rerun the optimizer on its result unless there is
+    -- find an op pattern, and rerun the optimizer on its result unless there is
     -- nothing to optimize, in which case call the next optimization
+  \case
+    -- var x = expr; return x; ==> return expr;
+    (DeclStat i (Just e) : ReturnStat (ValExpr (JVar i')) : xs)
+      | i == i' -> loop $ ReturnStat e : xs
+
+    -- x = expr; return x; ==> return expr;
+    (AssignStat (ValExpr (JVar i)) AssignOp e : ReturnStat (ValExpr (JVar i')) : xs)
+      | i == i' -> loop $ ReturnStat e : xs
+
+    -- h$sp -= 2; h$sp += 5; ==> h$sp += 3;
+    (op1 : op2 : xs)
+      | Just s1 <- isStackAdjust op1
+      , Just s2 <- isStackAdjust op2 -> loop $ mkStackAdjust (s1 + s2) ++ xs
+
+    -- x = x + 1; ==> ++x;
+    -- x = x - 1; ==> --x;
+    -- x = x + n; ==> x += n;
+    -- x = x - n; ==> x -= n;
     (unchanged@(AssignStat
                   ident@(ValExpr (JVar i))
                   AssignOp
@@ -232,18 +251,13 @@ combineOps = BlockOpt $ \loop next ->
                   (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 $
@@ -268,3 +282,30 @@ flattenBlocks :: BlockTrans
 flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys
 flattenBlocks (x:xs)             = x : flattenBlocks xs
 flattenBlocks []                 = []
+
+-- | stack adjustments
+sp :: JExpr
+sp = ValExpr (JVar (TxtI "h$sp"))
+
+isStackAdjust :: JStat -> Maybe Integer
+isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp"))))
+  | op == PreIncOp || op == PostIncOp = Just 1
+isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp"))))
+  | op == PreDecOp || op == PostDecOp = Just (-1)
+isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) op (ValExpr (JInt n)))
+  | op == AddAssignOp = Just n
+  | op == SubAssignOp = Just (-n)
+isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr op (ValExpr (JVar (TxtI "h$sp"))) (ValExpr (JInt n))))
+  | op == AddOp = Just n
+  | op == SubOp = Just (-n)
+isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr AddOp (ValExpr (JInt n)) (ValExpr (JVar (TxtI "h$sp")))))
+  = Just n
+isStackAdjust _ = Nothing
+
+mkStackAdjust :: Integer -> [JStat]
+mkStackAdjust 0 = []
+mkStackAdjust 1 = [UOpStat PostIncOp sp]
+mkStackAdjust (-1) = [UOpStat PostDecOp sp]
+mkStackAdjust x
+  | x < 0 = [AssignStat sp AssignOp (InfixExpr SubOp sp (ValExpr (JInt (-x))))]
+  | otherwise = [AssignStat sp AssignOp (InfixExpr AddOp sp (ValExpr (JInt x)))]


=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -6,7 +6,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeApplications #-}
 
 -- For Outputable instances for JS syntax
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -236,6 +235,7 @@ defRenderJsV r = \case
     | otherwise -> integer i
   JStr   s -> pprStringLit s
   JRegEx s -> char '/' <> ftext s <> char '/'
+  JBool b -> text (if b then "true" else "false")
   JHash m
     | isNullUniqMap m  -> text "{}"
     | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma .


=====================================
compiler/GHC/JS/Syntax.hs
=====================================
@@ -271,6 +271,7 @@ data JVal
   | JInt     Integer      -- ^ A BigInt
   | JStr     FastString   -- ^ A String
   | JRegEx   FastString   -- ^ A Regex
+  | JBool    Bool         -- ^ A Boolean
   | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@
   | JFunc    [Ident] JStat             -- ^ A function
   deriving (Eq, Typeable, Generic)
@@ -344,8 +345,8 @@ var = Var . global
 
 -- | The JS literal 'true'
 true_ :: JExpr
-true_ = var "true"
+true_ = ValExpr (JBool True)
 
 -- | The JS literal 'false'
 false_ :: JExpr
-false_ = var "false"
+false_ = ValExpr (JBool False)


=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -71,6 +70,7 @@ identsV = \case
   JInt{}       -> []
   JStr{}       -> []
   JRegEx{}     -> []
+  JBool{}      -> []
   JHash m      -> concatMap identsE (nonDetEltsUniqMap m)
   JFunc args s -> args ++ identsS s
 
@@ -119,6 +119,7 @@ jStgValToJS = \case
   JInt i    -> JS.JInt   i
   JStr s    -> JS.JStr   s
   JRegEx f  -> JS.JRegEx f
+  JBool b   -> JS.JBool  b
   JHash m   -> JS.JHash $ mapUniqMapM satHash m
     where
       satHash (i, x) = (i,) . (i,) $ jStgExprToJS x


=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -135,15 +135,15 @@ genUnits m ss spt_entries foreign_stubs = do
         glbl <- State.gets gsGlobal
         staticInit <-
           initStaticPtrs spt_entries
-        let stat = ( jsOptimize .
-                     jStgStatToJS
+        let stat = ( jStgStatToJS
                    $ mconcat (reverse glbl) <> staticInit)
+        let opt_stat = jsOptimize stat
         let syms = [moduleGlobalSymbol m]
         let oi = ObjBlock
                   { oiSymbols  = syms
                   , oiClInfo   = []
                   , oiStatic   = []
-                  , oiStat     = stat
+                  , oiStat     = opt_stat
                   , oiRaw      = mempty
                   , oiFExports = []
                   , oiFImports = []
@@ -203,21 +203,16 @@ genUnits m ss spt_entries foreign_stubs = do
           bids <- identsForId bnd
           case bids of
             [(identFS -> b1t),(identFS -> 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 =  jsOptimize
-                          $ jStgStatToJS body
               let ids = [bnd]
               syms <- (\(identFS -> i) -> [i]) <$> identForId bnd
               let oi = ObjBlock
                         { oiSymbols  = syms
                         , oiClInfo   = []
                         , oiStatic   = si
-                        , oiStat     = stat
+                        , oiStat     = mempty
                         , oiRaw      = ""
                         , oiFExports = []
                         , oiFImports = []
@@ -247,15 +242,15 @@ genUnits m ss spt_entries foreign_stubs = do
           let allDeps  = collectIds unf decl
               topDeps  = collectTopIds decl
               required = hasExport decl
-              stat     = jsOptimize
-                         . jStgStatToJS
+              stat     = jStgStatToJS
                          $ mconcat (reverse extraTl) <> tl
+          let opt_stat = jsOptimize stat
           syms <- mapM (fmap (\(identFS -> i) -> i) . identForId) topDeps
           let oi = ObjBlock
                     { oiSymbols  = syms
                     , oiClInfo   = ci
                     , oiStatic   = si
-                    , oiStat     = stat
+                    , oiStat     = opt_stat
                     , oiRaw      = ""
                     , oiFExports = []
                     , oiFImports = fRefs


=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -78,6 +78,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
 import qualified Control.Monad.Trans.State.Strict as State
 import GHC.Data.FastString
+import qualified GHC.Types.Unique.Map as UM
+
 import qualified GHC.Data.List.SetOps as ListSetOps
 
 import Data.Monoid
@@ -948,14 +950,32 @@ loadRetArgs free = do
   ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free
   popSkipI 1 ids
 
+-- All identifiers referenced by the expression (does not traverse into nested functions)
+allVars :: JStgExpr -> [Ident]
+allVars (ValExpr v) = case v of
+  (JVar i) -> [i]
+  (JList xs) -> concatMap allVars xs
+  (JHash xs) -> concatMap (allVars . snd) (UM.nonDetUniqMapToList xs)
+  (JInt {})  -> []
+  (JDouble {}) -> []
+  (JStr {}) -> []
+  (JRegEx {}) -> []
+  (JBool {}) -> []
+  (JFunc is _s) -> is
+allVars (InfixExpr _op lh rh) = allVars lh ++ allVars rh
+allVars (ApplExpr f xs) = allVars f ++ concatMap allVars xs
+allVars (IfExpr c t e) = allVars c ++ allVars t ++ allVars e
+allVars (UOpExpr _op x) = allVars x
+allVars (SelExpr e _) = allVars e
+allVars (IdxExpr e i) = allVars e ++ allVars i
+
 -- | allocate multiple, possibly mutually recursive, closures
 allocDynAll :: Bool -> Maybe JStgStat -> [(Ident,JStgExpr,[JStgExpr],CostCentreStack)] -> G JStgStat
-{-
-XXX remove use of template and enable in-place init again
 allocDynAll haveDecl middle [(to,entry,free,cc)]
-  | isNothing middle && to `notElem` (free ^.. template) = do
+  | isNothing middle && to `notElem` concatMap allVars free = do
       ccs <- ccsVarJ cc
-      return $ allocDynamic s haveDecl to entry free ccs -}
+      s <- getSettings
+      return $ allocDynamic s (not haveDecl) to entry free ccs
 allocDynAll haveDecl middle cls = do
   settings <- getSettings
   let


=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -243,8 +243,10 @@ jsLink lc_cfg cfg logger tmpfs ar_cache out link_plan = do
       unless (lcNoRts lc_cfg) $ do
         jsm <- initJSM
         withFile (out </> "rts.js") WriteMode $ \h -> do
+          let opt = jsOptimize (runJSM jsm $ jStgStatToJS <$> rts cfg)
           void $
-            hPutJS (csPrettyRender cfg) h (jsOptimize $ runJSM jsm $ jStgStatToJS <$> rts cfg)
+            hPutJS (csPrettyRender cfg) h opt
+
 
       -- link user-provided JS files into lib.js
       (emcc_opts,lib_cc_objs) <- withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
@@ -580,12 +582,14 @@ renderModules h render_pretty mods = do
 
   -- modules themselves
   mod_sizes <- forM compacted_mods $ \m -> do
-    !mod_size <- fromIntegral <$> putJS (cmc_js_code m)
+
+    !mod_size <- fromIntegral <$> (putJS $ cmc_js_code m)
     let !mod_mod  = cmc_module m
     pure (mod_mod, mod_size)
 
   -- commoned up metadata
-  !meta_length <- fromIntegral <$> putJS (jsOptimize meta)
+  let meta_opt = jsOptimize meta
+  !meta_length <- fromIntegral <$> putJS meta_opt
 
   -- module exports
   mapM_ (B.hPut h . cmc_exports) compacted_mods


=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -520,8 +520,9 @@ instance Binary Sat.JVal where
   put_ bh (Sat.JInt i)      = putByte bh 4 >> put_ bh i
   put_ bh (Sat.JStr xs)     = putByte bh 5 >> put_ bh xs
   put_ bh (Sat.JRegEx xs)   = putByte bh 6 >> put_ bh xs
-  put_ bh (Sat.JHash m)     = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)
-  put_ bh (Sat.JFunc is s)  = putByte bh 8 >> put_ bh is >> put_ bh s
+  put_ bh (Sat.JBool b)     = putByte bh 7 >> put_ bh b
+  put_ bh (Sat.JHash m)     = putByte bh 8 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)
+  put_ bh (Sat.JFunc is s)  = putByte bh 9 >> put_ bh is >> put_ bh s
   get bh = getByte bh >>= \case
     1 -> Sat.JVar    <$> get bh
     2 -> Sat.JList   <$> get bh
@@ -529,8 +530,9 @@ instance Binary Sat.JVal where
     4 -> Sat.JInt    <$> get bh
     5 -> Sat.JStr    <$> get bh
     6 -> Sat.JRegEx  <$> get bh
-    7 -> Sat.JHash . listToUniqMap <$> get bh
-    8 -> Sat.JFunc   <$> get bh <*> get bh
+    7 -> Sat.JBool   <$> get bh
+    8 -> Sat.JHash . listToUniqMap <$> get bh
+    9 -> Sat.JFunc   <$> get bh <*> get bh
     n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n)
 
 instance Binary Ident where


=====================================
compiler/ghc.cabal.in
=====================================
@@ -578,6 +578,8 @@ Library
         GHC.JS.Ident
         GHC.JS.Make
         GHC.JS.Optimizer
+        GHC.JS.Opt.Expr
+        GHC.JS.Opt.Simple
         GHC.JS.Ppr
         GHC.JS.Syntax
         GHC.JS.JStg.Syntax


=====================================
libraries/base/changelog.md
=====================================
@@ -5,6 +5,8 @@
   * Add `permutations` and `permutations1` to `Data.List.NonEmpty` ([CLC proposal #68](https://github.com/haskell/core-libraries-committee/issues/68))
   * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #175](https://github.com/haskell/core-libraries-committee/issues/175))
   * Implement `stimes` for `instance Semigroup (Endo a)` explicitly ([CLC proposal #4](https://github.com/haskell/core-libraries-committee/issues/4))
+  * Add `startTimeProfileAtStartup` to `GHC.RTS.Flags` to expose new RTS flag
+    `--no-automatic-heap-samples` in the Haskell API ([CLC proposal #243](https://github.com/haskell/core-libraries-committee/issues/243)).
   * Add laws relating between `Foldable` / `Traversable` with `Bifoldable` / `Bitraversable` ([CLC proposal #205](https://github.com/haskell/core-libraries-committee/issues/205))
   * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
   * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/).


=====================================
libraries/ghc-internal/src/GHC/RTS/Flags.hsc
=====================================
@@ -307,6 +307,7 @@ data ProfFlags = ProfFlags
     , heapProfileInterval      :: RtsTime -- ^ time between samples
     , heapProfileIntervalTicks :: Word    -- ^ ticks between samples (derived)
     , startHeapProfileAtStartup :: Bool
+    , startTimeProfileAtStartup :: Bool   -- ^ @since 4.20.0.0
     , showCCSOnException       :: Bool
     , maxRetainerSetSize       :: Word
     , ccsLength                :: Word
@@ -626,6 +627,8 @@ getProfFlags = do
             <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr
             <*> (toBool <$>
                   (#{peek PROFILING_FLAGS, startHeapProfileAtStartup} ptr :: IO CBool))
+            <*> (toBool <$>
+                  (#{peek PROFILING_FLAGS, startTimeProfileAtStartup} ptr :: IO CBool))
             <*> (toBool <$>
                   (#{peek PROFILING_FLAGS, showCCSOnException} ptr :: IO CBool))
             <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -9061,7 +9061,8 @@ module GHC.RTS.Flags where
   type ParFlags :: *
   data ParFlags = ParFlags {nCapabilities :: GHC.Word.Word32, migrate :: GHC.Types.Bool, maxLocalSparks :: GHC.Word.Word32, parGcEnabled :: GHC.Types.Bool, parGcGen :: GHC.Word.Word32, parGcLoadBalancingEnabled :: GHC.Types.Bool, parGcLoadBalancingGen :: GHC.Word.Word32, parGcNoSyncWithIdle :: GHC.Word.Word32, parGcThreads :: GHC.Word.Word32, setAffinity :: GHC.Types.Bool}
   type ProfFlags :: *
-  data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
+  data ProfFlags
+    = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, startTimeProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
   type RTSFlags :: *
   data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
   type RtsTime :: *


=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11839,7 +11839,8 @@ module GHC.RTS.Flags where
   type ParFlags :: *
   data ParFlags = ParFlags {nCapabilities :: GHC.Word.Word32, migrate :: GHC.Types.Bool, maxLocalSparks :: GHC.Word.Word32, parGcEnabled :: GHC.Types.Bool, parGcGen :: GHC.Word.Word32, parGcLoadBalancingEnabled :: GHC.Types.Bool, parGcLoadBalancingGen :: GHC.Word.Word32, parGcNoSyncWithIdle :: GHC.Word.Word32, parGcThreads :: GHC.Word.Word32, setAffinity :: GHC.Types.Bool}
   type ProfFlags :: *
-  data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
+  data ProfFlags
+    = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, startTimeProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
   type RTSFlags :: *
   data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
   type RtsTime :: *


=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -9285,7 +9285,8 @@ module GHC.RTS.Flags where
   type ParFlags :: *
   data ParFlags = ParFlags {nCapabilities :: GHC.Word.Word32, migrate :: GHC.Types.Bool, maxLocalSparks :: GHC.Word.Word32, parGcEnabled :: GHC.Types.Bool, parGcGen :: GHC.Word.Word32, parGcLoadBalancingEnabled :: GHC.Types.Bool, parGcLoadBalancingGen :: GHC.Word.Word32, parGcNoSyncWithIdle :: GHC.Word.Word32, parGcThreads :: GHC.Word.Word32, setAffinity :: GHC.Types.Bool}
   type ProfFlags :: *
-  data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
+  data ProfFlags
+    = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, startTimeProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
   type RTSFlags :: *
   data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
   type RtsTime :: *


=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -9065,7 +9065,8 @@ module GHC.RTS.Flags where
   type ParFlags :: *
   data ParFlags = ParFlags {nCapabilities :: GHC.Word.Word32, migrate :: GHC.Types.Bool, maxLocalSparks :: GHC.Word.Word32, parGcEnabled :: GHC.Types.Bool, parGcGen :: GHC.Word.Word32, parGcLoadBalancingEnabled :: GHC.Types.Bool, parGcLoadBalancingGen :: GHC.Word.Word32, parGcNoSyncWithIdle :: GHC.Word.Word32, parGcThreads :: GHC.Word.Word32, setAffinity :: GHC.Types.Bool}
   type ProfFlags :: *
-  data ProfFlags = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
+  data ProfFlags
+    = ProfFlags {doHeapProfile :: DoHeapProfile, heapProfileInterval :: RtsTime, heapProfileIntervalTicks :: GHC.Types.Word, startHeapProfileAtStartup :: GHC.Types.Bool, startTimeProfileAtStartup :: GHC.Types.Bool, showCCSOnException :: GHC.Types.Bool, maxRetainerSetSize :: GHC.Types.Word, ccsLength :: GHC.Types.Word, modSelector :: GHC.Maybe.Maybe GHC.Base.String, descrSelector :: GHC.Maybe.Maybe GHC.Base.String, typeSelector :: GHC.Maybe.Maybe GHC.Base.String, ccSelector :: GHC.Maybe.Maybe GHC.Base.String, ccsSelector :: GHC.Maybe.Maybe GHC.Base.String, retainerSelector :: GHC.Maybe.Maybe GHC.Base.String, bioSelector :: GHC.Maybe.Maybe GHC.Base.String}
   type RTSFlags :: *
   data RTSFlags = RTSFlags {gcFlags :: GCFlags, concurrentFlags :: ConcFlags, miscFlags :: MiscFlags, debugFlags :: DebugFlags, costCentreFlags :: CCFlags, profilingFlags :: ProfFlags, traceFlags :: TraceFlags, tickyFlags :: TickyFlags, parFlags :: ParFlags, hpcFlags :: HpcFlags}
   type RtsTime :: *


=====================================
testsuite/tests/javascript/opt/all.T
=====================================
@@ -2,3 +2,4 @@
 setTestOpts(when(not(js_arch()),skip))
 
 test('deadCodeElim', normal, compile_and_run, ['-package ghc'])
+test('jsOptimizer', normal, compile_and_run, ['-package ghc'])


=====================================
testsuite/tests/javascript/opt/deadCodeElim.hs
=====================================
@@ -78,11 +78,13 @@ bignum_test_2 = BlockStat [FuncStat (global $ fsLit "h$$ghczmbignumZCGHCziNumziI
                                                     , ReturnStat (ApplExpr (var $ fsLit "h$rs") [])]))])]
 
 bignum_test_opt_2 :: JStat
-bignum_test_opt_2 = BlockStat [FuncStat (global $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (global $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e")
+bignum_test_opt_2 = BlockStat [
+  FuncStat (global $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (DeclStat (global $ fsLit "a")
               (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (global $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (var $ fsLit "h$r2"))
                                                     , ApplStat (var $ fsLit "h$p1") [var $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"]
                                                     , ReturnStat (ApplExpr (var $ fsLit "h$e") [var $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"])
-                                                    ]))])]
+                                                    ]))) ]
+
 
 main :: IO ()
 main = mapM_ print


=====================================
testsuite/tests/javascript/opt/jsOptimizer.hs
=====================================
@@ -0,0 +1,361 @@
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
+
+module Main where
+
+{-
+   Test for the JavaScript optimizer.
+
+   This tests contains some hand-written JavaScript code to test the
+   optimizer.
+
+   The tests are run by executing the JavaScript code with node.js
+
+   Run with -v to see the original and optimized JavaScript code.
+ -}
+
+import GHC.Utils.TmpFs
+import System.Process
+import System.Exit
+import System.FilePath
+import Control.Monad
+import System.IO
+import qualified GHC.Utils.Ppr as Ppr
+import qualified GHC.JS.Syntax as JS
+import qualified GHC.Types.Unique.Map as UM
+
+import GHC.JS.Syntax
+
+import GHC.Utils.BufHandle
+import GHC.Utils.Outputable
+import GHC.StgToJS.Linker.Opt
+import GHC.Data.FastString
+import System.Environment
+
+import qualified GHC.JS.Optimizer as Opt
+
+{-
+  The location of the node.js program.
+
+  This is used to run the tests and compare the output of the optimized
+  and unoptimized code.
+ -}
+nodePgm :: IO FilePath
+nodePgm = pure "node"
+
+main :: IO ()
+main = do
+  args <- getArgs
+  let trace = args == ["-v"]
+  mapM_ (runTest trace) tests
+
+data Test = Test
+  { testName   :: String
+  , optSize    :: Maybe Double  {- ^ expected ratio of optimized size to
+                                     unoptimized size -}
+  , optPred    :: Maybe (JStat -> Bool) {- ^ predicate expected to be False
+                                             for unoptimized code and True
+                                             for optimized code -}
+  , testScript :: JStat
+  }
+
+printJS :: JStat -> IO ()
+printJS x = do
+  bh <- newBufHandle stdout
+  bPutHDoc bh defaultJsContext (line $ pretty False x)
+  bPutChar bh '\n'
+  bFlush bh
+
+runTest :: Bool -> Test -> IO ()
+runTest trace test = do
+  let script_unopt = testScript test
+  let script_opt = Opt.jsOptimize script_unopt
+  let out = if trace then putStrLn else const (pure ())
+      outJS = if trace then printJS else const (pure ())
+  out $ "###### " ++ testName test ++ " ######"
+  out "### Unoptimized ###" >> outJS script_unopt
+  out "### Optimized ###" >> outJS script_opt
+  out "###"
+  (size_u, code_u, out_u, err_u) <- runTestScript script_unopt
+  (size_o, code_o, out_o, err_o) <- runTestScript script_opt
+  out ("### result " ++ show code_u ++ " ###")
+  out ("### stdout ###") >> out out_u
+  out ("### stderr ###") >> out err_u
+  let smallEnough = maybe True
+                          (\r -> fromIntegral size_o < r * fromIntegral size_u)
+                          (optSize test)
+      (predUnopt, predOpt) = maybe (False, True)
+                                   (\p -> (p script_unopt, p script_opt))
+                                   (optPred test)
+  when (predUnopt || not predOpt) $ failTest ("predicate failed: " ++ show (predUnopt, predOpt))
+  when (code_u /= code_o) $ failTest ("different exit codes\n" ++ show (code_u, code_o))
+  when (out_u /= out_o)   $ failTest ("different stdout\n" ++ show (out_u, out_o))
+  when (err_u /= err_o)   $ failTest ("different stderr\n" ++ show (err_u, err_o))
+  when (not smallEnough)  $ failTest ("not small enough: " ++ show (size_o, size_u, optSize test))
+    where
+      failTest msg = do
+        error $ "Test " ++ testName test ++ " failed: " ++ msg
+
+runTestScript :: JStat -> IO (Integer, ExitCode, String, String)
+runTestScript script = withTempDirectory "." "test" $ \dir -> do
+  let scriptFile = dir </> "test.js"
+  scriptSize <- withFile scriptFile WriteMode (\h -> hPutJS True h script >> hFileSize h)
+  (run_exit, run_out, run_err) <- readProcessWithExitCode "node" [scriptFile] ""
+  pure (scriptSize, run_exit, run_out, run_err)
+
+hPutJS :: Bool -> Handle -> JS.JStat -> IO Integer
+hPutJS render_pretty h = \case
+  JS.BlockStat [] -> pure 0
+  x                -> do
+    before <- hTell h
+    if render_pretty
+      then do
+        printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x)
+      else do
+        bh <- newBufHandle h
+        bPutHDoc bh defaultJsContext (line $ pretty render_pretty x)
+        bFlush bh
+    hPutChar h '\n'
+    after <- hTell h
+    pure $! (after - before)
+
+defaultJsContext :: SDocContext
+defaultJsContext = defaultSDocContext{sdocStyle = PprCode}
+
+
+-- tests here
+tests :: [Test]
+tests =
+  [ {-
+      Test that all local variables are renamed to short names
+     -}
+    Test "rename_args" Nothing (Just (maxLongDecls 0)) $ BlockStat
+      [ FuncStat (ii "testFunc") [ii "foo", ii "bar"] $
+          BlockStat [ decl' "baz" (Int 1)
+                    , clog (var (fsLit "foo"))
+                    , clog (var (fsLit "bar"))
+                    , clog (var (fsLit "baz"))
+                    , clog (var (fsLit "baz"))
+                    , ReturnStat (Int 0)
+                    ]
+      , ApplStat (var (fsLit "testFunc")) [Int 1, Int 2]
+      ]
+  {-
+    Test that local variables are removed:
+      foo: unused
+      bar: constant propagation
+   -}
+  , Test "remove_unused"  Nothing    (Just (maxDecls 0)) $ BlockStat
+      [ FuncStat (ii "testFunc") [] $
+          BlockStat [ decl' "foo" (Int 1)
+                    , decl' "bar" (Int 2)
+                    , clog (iv "bar")
+                    , ReturnStat (Int 0)
+                    ]
+      , ApplStat (var (fsLit "testFunc")) []
+      ]
+  {- test that second return is removed in:
+       return 0;
+       return 1;
+    -}
+  , Test "unreachable_return" Nothing (Just (maxReturns 1)) $
+        testFuncPrint $
+        [ DeclStat (ii "foo") (Just (Int 0))
+        , ReturnStat (Int 0)
+        , ReturnStat (Int 1)
+        ]
+  {- make sure we don't rename things around an eval -}
+  , Test "eval_bailout"   Nothing    Nothing (
+     testFuncRun $
+  [ DeclStat (ii "foo") (Just (Int 0))
+  , AssignStat (var (fsLit "foo")) AssignOp (ValExpr (JFunc [] (BlockStat [ ApplStat (var (fsLit "eval")) [(str "foo++;")]
+                                                                            , ReturnStat (Int 0)
+                                                                            ])))
+  , ReturnStat (ApplExpr (var (fsLit "foo")) [])
+             ]
+  )
+  {- make sure we remove operations for known constants -}
+  , Test "constant_fold" Nothing  (Just (maxOp AddOp 0)) (testFuncRun $
+  [ decl' "foo" (Int 1)
+  , decl' "bar" (Int 2)
+  , decl' "baz" (Int 3)
+  , clog (InfixExpr AddOp (var "foo") (InfixExpr AddOp (var "bar") (var "baz")))
+  ])
+  {- nested function that closes over a local variable in outer function -}
+  , Test "nested_function1" Nothing Nothing (testFuncRun $
+  [ decl' "xyz" (Int 1)
+  , clog (var "xyz")
+  , FuncStat (ii "f") [] $
+      BlockStat [ UOpStat PreIncOp (var "xyz")
+                , clog (var "xyz")
+                , ReturnStat (Int 0)
+                ]
+  , app "f" []
+  ])
+  {- nested function arguments -}
+  , Test "nested_function2" Nothing Nothing (testFuncRun $
+  [ decl' "xyz" (Int 1)
+  , clog (var (fsLit "xyz"))
+  , FuncStat (ii "f") [ii "xyz"] $
+      BlockStat [ UOpStat PreIncOp (var "xyz")
+                , clog (var "xyz")
+                , ReturnStat (Int 0)
+                ]
+  , clog (var "xyz")
+  , app "f" [Int 2]
+  , clog (var "xyz")
+  , app "f" [var "xyz"]
+  , clog (var "xyz")
+  ])
+  ]
+
+ii :: String -> Ident
+ii = TxtI . fsLit
+
+iv :: String -> JExpr
+iv = ValExpr . JVar . TxtI . fsLit
+
+str :: String -> JExpr
+str = ValExpr . JStr . fsLit
+
+decl :: String -> JStat
+decl i = DeclStat (TxtI (fsLit i)) Nothing
+
+decl' :: String -> JExpr -> JStat
+decl' i e = DeclStat (TxtI (fsLit i)) (Just e)
+
+clog :: JExpr -> JStat
+clog e = ApplStat (SelExpr (var "console") (ii "log")) [e]
+
+app :: String -> [JExpr] -> JStat
+app f es = ApplStat (iv f) es
+
+testFunc :: [JStat] -> JStat
+testFunc body = FuncStat (ii "test") [] (BlockStat body)
+
+testFuncRun :: [JStat] -> JStat
+testFuncRun body = BlockStat [ testFunc body
+                             , ApplStat (var (fsLit "test")) []
+                             ]
+
+testFuncPrint :: [JStat] -> JStat
+testFuncPrint body = BlockStat [ testFunc body
+                               , clog (ApplExpr (var (fsLit "test")) [])
+                               ]
+
+
+
+-- predicates
+maxDecls, maxLongDecls, maxReturns :: Int -> JStat -> Bool
+
+{-
+  Test that the number of local variable declarations is at most n
+ -}
+maxDecls n s = countStats isDecl s <= n
+  where
+    isDecl (DeclStat _ _) = True
+    isDecl _              = False
+
+{-
+  Test that the number of return statements is at most n
+ -}
+maxReturns n s = countStats isReturn s <= n
+  where
+    isReturn (ReturnStat _) = True
+    isReturn _              = False
+
+{-
+   Test that the number of long (more than one character) declarations 
+   is at most n
+
+   Declarations are both explicit local variables ('var x') and
+   function arguments ('function f(x) { ... }') or other implicitly
+   declared variables ('catch(x) { }', 'for(var x in y) { }').
+-}
+maxLongDecls n s = countCode (CodeCount countLongStat countLongExpr) s <= n
+  where
+    isLong :: Ident -> Bool
+    isLong (TxtI i) = length (unpackFS i) > 1
+    countLongStat :: JStat -> Int
+    countLongStat (DeclStat i _) = b2i isLong i
+    countLongStat (FuncStat _ args _) = length (filter isLong args)
+    countLongStat (ForInStat True i _ _) = b2i isLong i
+    countLongStat _                   = 0
+    countLongExpr :: JExpr -> Int
+    countLongExpr (ValExpr (JFunc args _)) = length (filter isLong args)
+    countLongExpr _                      = 0
+
+{-
+  Test that the number of operations of type op is at most n
+ -}
+maxOp :: Op -> Int -> JStat -> Bool
+maxOp op n s = countExprs isOp s <= n
+  where
+    isOp (InfixExpr op' _ _) = op == op'
+    isOp _                   = False
+
+{-
+  Test that the number of long (more than one character) variable references
+  is at most n
+ -}
+maxLongVars :: Int -> JStat -> Bool
+maxLongVars n s = countExprs isLongVar s <= n
+  where
+    isLongVar (ValExpr (JVar (TxtI i))) = length (unpackFS i) > 1
+    isLongVar _                         = False
+
+countStats :: (JStat -> Bool) -> JStat -> Int
+countStats p stat = countCode (CodeCount (b2i p) (const 0)) stat
+
+countExprs :: (JExpr -> Bool) -> JStat -> Int
+countExprs p expr = countCode (CodeCount (const 0) (b2i p)) expr
+
+b2i :: (a -> Bool) -> a -> Int
+b2i f x = if f x then 1 else 0
+
+data CodeCount = CodeCount
+  { statCount :: JStat -> Int
+  , exprCount :: JExpr -> Int
+  }
+
+countCode :: CodeCount -> JStat -> Int
+countCode c s0 = goST s0
+  where    
+    goST :: JStat -> Int
+    goST s = statCount c s + goS s
+
+    goET :: JExpr -> Int
+    goET e = exprCount c e + goE e
+    
+    goS (DeclStat _i mb_e) = maybe 0 goET mb_e
+    goS (ReturnStat e) = goET e
+    goS (IfStat e s1 s2) = goET e + goST s1 + goST s2
+    goS (WhileStat _b e s) = goET e + goST s
+    goS (ForStat s1 e s2 s3) = goST s1 + goET e + goST s2 + goST s3
+    goS (ForInStat _b _i e s) = goET e + goST s
+    goS (SwitchStat e xs s) = goET e +
+                              sum (map (goET . fst) xs) +
+                              sum (map (goST . snd) xs) +
+                              goST s
+    goS (TryStat s1 _i s2 s3) = goST s1 + goST s2 + goST s3
+    goS (BlockStat xs) = sum (map goST xs)
+    goS (ApplStat e es) = goET e + sum (map goET es)
+    goS (UOpStat _ e) = goET e
+    goS (AssignStat e1 _ e2) = goET e1 + goET e2
+    goS (LabelStat _l s) = goST s
+    goS (BreakStat _l) = 0
+    goS (ContinueStat _l) = 0
+    goS (FuncStat _i _is s) = goST s
+
+    goE (ValExpr v) = goV v
+    goE (SelExpr e _i) = goET e
+    goE (IdxExpr e1 e2) = goET e1 + goET e2
+    goE (InfixExpr _ e1 e2) = goET e1 + goET e2
+    goE (UOpExpr _ e) = goET e
+    goE (IfExpr e1 e2 e3) = goET e1 + goET e2 + goET e3
+    goE (ApplExpr e es) = goET e + sum (map goET es)
+
+    -- traverse JVal for JExpr or JStat inside
+    goV (JList es) = sum (map goET es)
+    goV (JFunc _is s) = goST s
+    goV (JHash xs) = sum (map (goET . snd) (UM.nonDetUniqMapToList xs))
+    goV _ = 0



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eba09a423e2e2aebe7c721bfbdeb2d2f2a76aa1e...5b9a838f8a9418483a840929ecf1d1dc3da68409

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eba09a423e2e2aebe7c721bfbdeb2d2f2a76aa1e...5b9a838f8a9418483a840929ecf1d1dc3da68409
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240215/335b0d97/attachment-0001.html>


More information about the ghc-commits mailing list