[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: JS: add simple optimizer
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Feb 16 00:36:00 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8ad02724 by Luite Stegeman at 2024-02-15T17:33:32-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
- - - - -
20769b36 by Matthew Pickering at 2024-02-15T17:34:07-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
- - - - -
2001d0fe by Teo Camarasu at 2024-02-15T19:35:31-05:00
base: export System.Mem.performBlockingMajorGC
The corresponding C function was introduced in
ba73a807edbb444c49e0cf21ab2ce89226a77f2e. As part of #22264.
Resolves #24228
The CLC proposal was disccused at: https://github.com/haskell/core-libraries-committee/issues/230
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
845e85e4 by Florian Weimer at 2024-02-15T19:35:34-05:00
Fix C output for modern C initiative
GCC 14 on aarch64 rejects the C code written by GHC with this kind of
error:
error: assignment to ‘ffi_arg’ {aka ‘long unsigned int’} from ‘HsPtr’ {aka ‘void *’} makes integer from pointer without a cast [-Wint-conversion]
68 | *(ffi_arg*)resp = cret;
| ^
Add the correct cast.
For more information on this see:
https://fedoraproject.org/wiki/Changes/PortingToModernC
Tested-by: Richard W.M. Jones <rjones at redhat.com>
- - - - -
24 changed files:
- compiler/GHC/HsToCore/Foreign/C.hs
- 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
- libraries/ghc-internal/src/System/Mem.hs
- 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/HsToCore/Foreign/C.hs
=====================================
@@ -560,7 +560,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
, ppUnless res_hty_is_unit $
if libffi
then char '*' <> parens (ffi_cResType <> char '*') <>
- text "resp = cret;"
+ text "resp = " <> parens ffi_cResType <> text "cret;"
else text "return cret;"
, rbrace
]
=====================================
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/).
@@ -14,6 +16,7 @@
([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166))
* Export List from Data.List ([CLC proposal #182](https://github.com/haskell/core-libraries-committee/issues/182)).
* Deprecate `Data.List.NonEmpty.unzip` ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))
+ * Add `System.Mem.performMajorGC` ([CLC proposal #230](https://github.com/haskell/core-libraries-committee/issues/230))
* Fix exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192))
* Implement `many` and `some` methods of `instance Alternative (Compose f g)` explicitly. ([CLC proposal #181](https://github.com/haskell/core-libraries-committee/issues/181))
=====================================
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
=====================================
libraries/ghc-internal/src/System/Mem.hs
=====================================
@@ -20,6 +20,7 @@ module System.Mem
-- * Garbage collection
performGC
, performMajorGC
+ , performBlockingMajorGC
, performMinorGC
-- * Allocation counter and limits
@@ -41,6 +42,12 @@ performGC = performMajorGC
-- @since 4.7.0.0
foreign import ccall "performMajorGC" performMajorGC :: IO ()
+-- | Triggers an immediate major garbage collection, ensuring that collection
+-- finishes before returning.
+--
+-- @since 4.20.0.0
+foreign import ccall "performBlockingMajorGC" performBlockingMajorGC :: IO ()
+
-- | Triggers an immediate minor garbage collection.
--
-- @since 4.7.0.0
=====================================
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 :: *
@@ -10364,6 +10365,7 @@ module System.Mem where
disableAllocationLimit :: GHC.Types.IO ()
enableAllocationLimit :: GHC.Types.IO ()
getAllocationCounter :: GHC.Types.IO GHC.Int.Int64
+ performBlockingMajorGC :: GHC.Types.IO ()
performGC :: GHC.Types.IO ()
performMajorGC :: GHC.Types.IO ()
performMinorGC :: GHC.Types.IO ()
=====================================
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 :: *
@@ -13142,6 +13143,7 @@ module System.Mem where
disableAllocationLimit :: GHC.Types.IO ()
enableAllocationLimit :: GHC.Types.IO ()
getAllocationCounter :: GHC.Types.IO GHC.Int.Int64
+ performBlockingMajorGC :: GHC.Types.IO ()
performGC :: GHC.Types.IO ()
performMajorGC :: GHC.Types.IO ()
performMinorGC :: GHC.Types.IO ()
=====================================
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 :: *
@@ -10650,6 +10651,7 @@ module System.Mem where
disableAllocationLimit :: GHC.Types.IO ()
enableAllocationLimit :: GHC.Types.IO ()
getAllocationCounter :: GHC.Types.IO GHC.Int.Int64
+ performBlockingMajorGC :: GHC.Types.IO ()
performGC :: GHC.Types.IO ()
performMajorGC :: GHC.Types.IO ()
performMinorGC :: GHC.Types.IO ()
=====================================
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 :: *
@@ -10368,6 +10369,7 @@ module System.Mem where
disableAllocationLimit :: GHC.Types.IO ()
enableAllocationLimit :: GHC.Types.IO ()
getAllocationCounter :: GHC.Types.IO GHC.Int.Int64
+ performBlockingMajorGC :: GHC.Types.IO ()
performGC :: GHC.Types.IO ()
performMajorGC :: GHC.Types.IO ()
performMinorGC :: GHC.Types.IO ()
=====================================
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/5b9a838f8a9418483a840929ecf1d1dc3da68409...845e85e462addff51828d6f41ac9842541018666
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b9a838f8a9418483a840929ecf1d1dc3da68409...845e85e462addff51828d6f41ac9842541018666
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/c524bff9/attachment-0001.html>
More information about the ghc-commits
mailing list