[Git][ghc/ghc][wip/js-staging] 4 commits: Remove JS keywords
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Wed Oct 12 15:01:35 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
c11368a0 by Sylvain Henry at 2022-10-12T14:05:52+02:00
Remove JS keywords
1. The list is incomplete
2. We prefix locals with "h$$" so there is no risk of conflict with JS
keywords
- - - - -
01c0b664 by Sylvain Henry at 2022-10-12T14:08:01+02:00
Remove dead code
- - - - -
e8b23bab by Sylvain Henry at 2022-10-12T14:09:05+02:00
Make ident supply strict (no need to make it lazy, list already is)
- - - - -
21ef7cfb by Sylvain Henry at 2022-10-12T17:04:41+02:00
Add optional assign to DeclStat and remove dead code
- - - - -
13 changed files:
- compiler/GHC/JS/Make.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/DataCon.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Compactor.hs
- compiler/GHC/StgToJS/Linker/Types.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Printer.hs
Changes:
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -266,7 +266,7 @@ jVar :: ToSat a => a -> JStat
jVar f = UnsatBlock . IS $ do
(block, is) <- runIdentSupply $ toSat_ f []
let addDecls (BlockStat ss) =
- BlockStat $ map DeclStat is ++ ss
+ BlockStat $ map decl is ++ ss
addDecls x = x
return $ addDecls block
@@ -278,14 +278,14 @@ jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat
jForIn e f = UnsatBlock . IS $ do
(block, is) <- runIdentSupply $ toSat_ f []
let i = List.head is
- return $ DeclStat i `mappend` ForInStat False i e block
+ return $ decl i `mappend` ForInStat False i e block
-- | As with "jForIn" but creating a \"for each in\" statement.
jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat
jForEachIn e f = UnsatBlock . IS $ do
(block, is) <- runIdentSupply $ toSat_ f []
let i = List.head is
- return $ DeclStat i `mappend` ForInStat True i e block
+ return $ decl i `mappend` ForInStat True i e block
-- | As with "jForIn" but creating a \"for each in\" statement.
jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat
@@ -311,7 +311,7 @@ jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b']
-- | construct a js declaration with the given identifier
decl :: Ident -> JStat
-decl i = DeclStat i
+decl i = DeclStat i Nothing
-- | The empty JS HashMap
jhEmpty :: M.Map k JExpr
@@ -508,7 +508,7 @@ infixl 8 .^
--
-- > foo |= expr ==> var foo; foo = expr;
(||=) :: Ident -> JExpr -> JStat
-i ||= ex = DeclStat i `mappend` (toJExpr i |= ex)
+i ||= ex = DeclStat i (Just ex)
infixl 2 ||=, |=
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -112,7 +112,8 @@ defRenderJsS r = \case
$$ mbElse
where mbElse | y == BlockStat [] = PP.empty
| otherwise = hangBrace (text "else") (jsToDocR r y)
- DeclStat x -> text "var" <+> jsToDocR r x
+ DeclStat x Nothing -> text "var" <+> jsToDocR r x
+ DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e
WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b)
WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
UnsatBlock e -> jsToDocR r $ pseudoSaturate e
=====================================
compiler/GHC/JS/Syntax.hs
=====================================
@@ -85,8 +85,6 @@ module GHC.JS.Syntax
, pseudoSaturate
-- * Utility
, SaneDouble(..)
- -- * Keywords
- , isJsKeyword
) where
import GHC.Prelude
@@ -94,7 +92,6 @@ import GHC.Prelude
import Control.DeepSeq
import Data.Function
-import qualified Data.Set as Set
import Data.Data
import Data.Word
import qualified Data.Semigroup as Semigroup
@@ -144,7 +141,7 @@ instance Show a => Show (IdentSupply a) where
-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)
-- for details
data JStat
- = DeclStat Ident -- ^ Variable declarations: var foo
+ = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e]
| ReturnStat JExpr -- ^ Return
| IfStat JExpr JStat JStat -- ^ If
| WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True
@@ -391,26 +388,3 @@ newtype Ident = TxtI { itxt :: FastString }
instance Ord Ident where
compare (TxtI fs1) (TxtI fs2) = lexicalCompareFS fs1 fs2
-
---------------------------------------------------------------------------------
--- JS Keywords
---------------------------------------------------------------------------------
--- | The set of Javascript keywords
-jsKeywords :: Set.Set Ident
-jsKeywords = Set.fromList $ TxtI <$>
- [ "break", "case", "catch", "continue", "debugger"
- , "default", "delete", "do", "else", "finally", "for"
- , "function", "if", "in", "instanceof", "new", "return"
- , "switch", "this", "throw", "try", "typeof", "var", "void"
- , "while", "with"
- , "class", "enum", "export", "extends", "import", "super"
- , "const"
- , "implements", "interface", "let", "package", "private"
- , "protected"
- , "public", "static", "yield"
- , "null", "true", "false"
- ]
-
--- | Predicate which checks if input 'Ident' is a JS keyword or not.
-isJsKeyword :: Ident -> Bool
-isJsKeyword = flip Set.member jsKeywords
=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -25,9 +25,6 @@ module GHC.JS.Transform
, composOpM
, composOpM_
, composOpFold
- -- * Hygienic transformation
- , withHygiene
- , scopify
)
where
@@ -35,15 +32,12 @@ import GHC.Prelude
import GHC.JS.Syntax
-import qualified Data.Map as M
-import Text.Read (readMaybe)
import Data.Functor.Identity
import Control.Monad
import Data.Bifunctor
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Panic
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.Unique.DSet
@@ -80,7 +74,7 @@ mapIdent f = (map_expr, map_stat)
UnsatVal v2 -> ValExpr $ UnsatVal v2
map_stat s = case s of
- DeclStat{} -> s
+ DeclStat i e -> DeclStat i (fmap map_expr e)
ReturnStat e -> ReturnStat (map_expr e)
IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2)
WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2)
@@ -99,7 +93,7 @@ mapIdent f = (map_expr, map_stat)
{-# INLINE identsS #-}
identsS :: JStat -> UniqDSet Ident
identsS = \case
- DeclStat i -> unitUniqDSet i
+ DeclStat i e -> unitUniqDSet i `unionUniqDSets` maybe emptyUniqDSet identsE e
ReturnStat e -> identsE e
IfStat e s1 s2 -> identsE e `unionUniqDSets` identsS s1 `unionUniqDSets` identsS s2
WhileStat _ e s -> identsE e `unionUniqDSets` identsS s
@@ -206,7 +200,7 @@ jmcompos ret app f' v =
case v of
JMGId _ -> ret v
JMGStat v' -> ret JMGStat `app` case v' of
- DeclStat i -> ret DeclStat `app` f i
+ DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e
ReturnStat i -> ret ReturnStat `app` f i
IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'
WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s
@@ -249,6 +243,10 @@ jmcompos ret app f' v =
where
mapM' :: forall a. (a -> m a) -> [a] -> m [a]
mapM' g = foldr (app . app (ret (:)) . g) (ret [])
+ mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a)
+ mapMaybeM' g = \case
+ Nothing -> ret Nothing
+ Just a -> app (ret Just) (g a)
f :: forall b. JMacro b => b -> m b
f x = ret jfromGADT `app` f' (jtoGADT x)
@@ -270,104 +268,3 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us)
JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us)
_ -> composOpM go v
-
-{--------------------------------------------------------------------
- Transformation
---------------------------------------------------------------------}
-
--- doesn't apply to unsaturated bits
-jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a
-jsReplace_ xs e = jfromGADT $ go (jtoGADT e)
- where
- go :: forall a. JMGadt a -> JMGadt a
- go v = case v of
- JMGId i -> maybe v JMGId (M.lookup i mp)
- _ -> composOp go v
- mp = M.fromList xs
-
--- only works on fully saturated things
-jsUnsat_ :: JMacro a => [Ident] -> a -> IdentSupply a
-jsUnsat_ xs e = IS $ do
- (idents,is') <- splitAt (length xs) <$> get
- put is'
- return $ jsReplace_ (zip xs idents) e
-
--- | Apply a transformation to a fully saturated syntax tree,
--- taking care to return any free variables back to their free state
--- following the transformation. As the transformation preserves
--- free variables, it is hygienic.
-withHygiene :: JMacro a => (a -> a) -> a -> a
-withHygiene f x = jfromGADT $ case jtoGADT x of
- JMGExpr z -> JMGExpr $ UnsatExpr $ inScope z
- JMGStat z -> JMGStat $ UnsatBlock $ inScope z
- JMGVal z -> JMGVal $ UnsatVal $ inScope z
- JMGId _ -> jtoGADT $ f x
- where
- inScope z = IS $ do
- ti <- get
- case ti of
- ((TxtI a):b) -> do
- put b
- return $ withHygiene_ a f z
- _ -> error "withHygiene: empty list"
-
-withHygiene_ :: JMacro a => FastString -> (a -> a) -> a -> a
-withHygiene_ un f x = jfromGADT $ case jtoGADT x of
- JMGStat _ -> jtoGADT $ UnsatBlock (jsUnsat_ is' x'')
- JMGExpr _ -> jtoGADT $ UnsatExpr (jsUnsat_ is' x'')
- JMGVal _ -> jtoGADT $ UnsatVal (jsUnsat_ is' x'')
- JMGId _ -> jtoGADT $ f x
- where
- (x',l) = case runState (runIdentSupply $ jsSaturate_ x) is of
- (_ , []) -> panic "withHygiene: empty ident list"
- (x', TxtI l : _) -> (x',l)
- is' = take lastVal is
- x'' = f x'
- lastVal = case readMaybe (reverse . takeWhile (/= '_') . reverse . unpackFS $ l) of
- Nothing -> panic ("inSat" ++ unpackFS un)
- Just r -> r :: Int
- is = newIdentSupply $ Just (mkFastString "inSat" `mappend` un)
-
--- | Takes a fully saturated expression and transforms it to use unique
--- variables that respect scope.
-scopify :: JStat -> JStat
-scopify x = evalState (jfromGADT <$> go (jtoGADT x)) (newIdentSupply Nothing)
- where
- go :: forall a. JMGadt a -> State [Ident] (JMGadt a)
- go = \case
- JMGStat (BlockStat ss) -> JMGStat . BlockStat <$>
- blocks ss
- where blocks [] = return []
- blocks (DeclStat (TxtI i) : xs)
- | ('!':'!':rs) <- unpackFS i
- = (DeclStat (TxtI (mkFastString rs)):) <$> blocks xs
- | ('!':rs) <- unpackFS i
- = (DeclStat (TxtI $ mkFastString rs):) <$> blocks xs
- | otherwise = do
- xx <- get
- case xx of
- (newI:st) -> do
- put st
- rest <- blocks xs
- return $ [DeclStat newI `mappend` jsReplace_ [(TxtI i, newI)] (BlockStat rest)]
- _ -> error "scopify: empty list"
- blocks (x':xs) = (jfromGADT <$> go (jtoGADT x')) <:> blocks xs
- (<:>) = liftM2 (:)
- JMGStat (TryStat s (TxtI i) s1 s2) -> do
- xx <- get
- case xx of
- (newI:st) -> do
- put st
- t <- jfromGADT <$> go (jtoGADT s)
- c <- jfromGADT <$> go (jtoGADT s1)
- f <- jfromGADT <$> go (jtoGADT s2)
- return . JMGStat . TryStat t newI (jsReplace_ [(TxtI i, newI)] c) $ f
- _ -> error "scopify: empty list"
- JMGExpr (ValExpr (JFunc is s)) -> do
- st <- get
- let (newIs,newSt) = splitAt (length is) st
- put newSt
- rest <- jfromGADT <$> go (jtoGADT s)
- return . JMGExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest
- v -> composOpM go v
-
=====================================
compiler/GHC/StgToJS/DataCon.hs
=====================================
@@ -117,8 +117,8 @@ allocDynamicE inline_alloc entry free cc
-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
-allocDynamic s haveDecl to entry free cc =
- dec to `mappend` (toJExpr to |= allocDynamicE (csInlineAlloc s) entry free cc)
+allocDynamic s need_decl to entry free cc
+ | need_decl = DeclStat to (Just value)
+ | otherwise = toJExpr to |= value
where
- dec i | haveDecl = DeclStat i
- | otherwise = mempty
+ value = allocDynamicE (csInlineAlloc s) entry free cc
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -259,7 +259,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do
args' <- concatMapM genArg args
ac <- allocCon ii con cc args'
emitToplevel (ei ||= toJExpr (JFunc []
- (mconcat [DeclStat ii, p, ac, r1 |= toJExpr ii, returnStack])))
+ (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])))
-- | Generate the entry function for a local closure
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
@@ -427,7 +427,7 @@ loadLiveFun l = do
]
where
loadLiveVar d n v = let ident = TxtI (dataFieldName n)
- in DeclStat v `mappend` (toJExpr v |= SelExpr d ident)
+ in v ||= SelExpr d ident
-- | Pop a let-no-escape frame off the stack
popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
@@ -541,7 +541,7 @@ allocCls dynMiddle xs = do
toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do
ii <- identForId i
ac <- allocCon ii con cc =<< genArg a
- pure (Left (DeclStat ii <> ac))
+ pure (Left (decl ii <> ac))
-- dynamics
toCl (i, StgRhsCon cc con _mu _ticks ar) =
@@ -581,15 +581,13 @@ genCase ctx bnd e at alts l
(pprStgExpr panicStgPprOpts e)
(aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts
- (declCCS,saveCCS,restoreCCS) <- ifProfilingM $ do
+ (saveCCS,restoreCCS) <- ifProfilingM $ do
ccsVar <- freshIdent
- pure ( DeclStat ccsVar
- , toJExpr ccsVar |= toJExpr jCurrentCCS
+ pure ( ccsVar ||= toJExpr jCurrentCCS
, toJExpr jCurrentCCS |= toJExpr ccsVar
)
return ( mconcat
- [ declCCS
- , mconcat (map DeclStat bndi)
+ [ mconcat (map decl bndi)
, saveCCS
, ej
, restoreCCS
@@ -977,13 +975,16 @@ allocDynAll haveDecl middle cls = do
let
middle' = fromMaybe mempty middle
+ decl_maybe i e
+ | haveDecl = toJExpr i |= e
+ | otherwise = i ||= e
+
makeObjs :: G JStat
makeObjs =
fmap mconcat $ forM cls $ \(i,f,_,cc) -> do
ccs <- maybeToList <$> costCentreStackLbl cc
pure $ mconcat
- [ dec i
- , toJExpr i |= if csInlineAlloc settings
+ [ decl_maybe i $ if csInlineAlloc settings
then ValExpr (jhFromList $ [ (closureEntry_ , f)
, (closureField1_, null_)
, (closureField2_, null_)
@@ -1022,8 +1023,6 @@ allocDynAll haveDecl middle cls = do
fillFun [] = null_
fillFun es = ApplExpr (allocData (length es)) es
- dec i | haveDecl = DeclStat i
- | otherwise = mempty
checkObjs | csAssertRts settings = mconcat $
map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls
| otherwise = mempty
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -117,8 +117,7 @@ parseFFIPatternA True True pat t es as = do
, ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"]
])
(mconcat
- [ DeclStat d
- , toJExpr d |= toJExpr x .^ "mv"
+ [ d ||= toJExpr x .^ "mv"
, copyResult (toJExpr d)
])
]
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -225,6 +225,6 @@ varForDataConWorker d = varForDataConEntryId (dataConWorkId d)
declVarsForId :: Id -> G JStat
declVarsForId i = case typeSize (idType i) of
0 -> return mempty
- 1 -> DeclStat <$> identForId i
- s -> mconcat <$> mapM (\n -> DeclStat <$> identForIdN i n) [1..s]
+ 1 -> decl <$> identForId i
+ s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s]
=====================================
compiler/GHC/StgToJS/Linker/Compactor.hs
=====================================
@@ -156,7 +156,7 @@ staticDeclStat :: StaticInfo -> JStat
staticDeclStat (StaticInfo global_name static_value _) = decl
where
global_ident = TxtI global_name
- decl_init v = DeclStat global_ident `mappend` (toJExpr global_ident |= v)
+ decl_init v = global_ident ||= v
decl_no_init = appS "h$di" [toJExpr global_ident]
decl = case static_value of
@@ -299,9 +299,7 @@ renderBuildFunctions normalBfs cycleBreakerBfs =
body = ReturnStat $ ApplExpr (ValExpr (JVar (TxtI $ cbName n)))
(map (ValExpr . JVar) args)
bfn = bfName bf
- in DeclStat (TxtI bfn) <>
- AssignStat (ValExpr (JVar (TxtI bfn)))
- (ValExpr (JFunc args body))
+ in (TxtI bfn) ||= (ValExpr (JFunc args body))
cycleBr2 = renderCbr $ \bf n -> renderBuildFunction (bf { bfName = cbName n })
data BuildFunction = BuildFunction
@@ -369,7 +367,7 @@ rewriteBodies globals idx1 idx2 input = (bfsNormal, bfsCycleBreaker, input')
removeDecls :: UniqSet FastString -> JStat -> JStat
removeDecls t (BlockStat ss) = BlockStat (map (removeDecls t) ss)
- removeDecls t (DeclStat (TxtI i))
+ removeDecls t (DeclStat (TxtI i) _)
| elementOfUniqSet i t = mempty
removeDecls _ s = s
@@ -408,9 +406,7 @@ rewriteBodies globals idx1 idx2 input = (bfsNormal, bfsCycleBreaker, input')
-> JStat
-> JStat
createFunction _i idx g args body =
- DeclStat bi <>
- AssignStat (ValExpr (JVar bi))
- (ValExpr (JFunc bargs bbody))
+ bi ||= ValExpr (JFunc bargs bbody)
where
ng = length g
bi = buildFunId idx
@@ -425,9 +421,7 @@ rewriteBodies globals idx1 idx2 input = (bfsNormal, bfsCycleBreaker, input')
renderBuildFunction :: BuildFunction -> JStat
renderBuildFunction (BuildFunction i bfid deps _nargs) =
- DeclStat (TxtI i) <>
- AssignStat (ValExpr (JVar (TxtI i)))
- (ApplExpr (ValExpr (JVar bfid)) (map (ValExpr . JVar . TxtI) deps))
+ (TxtI i) ||= (ApplExpr (ValExpr (JVar bfid)) (map (ValExpr . JVar . TxtI) deps))
dedupeBody :: Int -> Int -> Bool
dedupeBody n size
@@ -447,9 +441,9 @@ findGlobals globals stat = filter isGlobal . map itxt . uniqDSetToList $ identsS
isGlobal i = elementOfUniqSet i globals && not (elementOfUniqSet i locals)
findLocals :: JStat -> [FastString]
-findLocals (BlockStat ss) = concatMap findLocals ss
-findLocals (DeclStat (TxtI i)) = [i]
-findLocals _ = []
+findLocals (BlockStat ss) = concatMap findLocals ss
+findLocals (DeclStat (TxtI i) _) = [i]
+findLocals _ = []
data HashIdx = HashIdx (UniqMap FastString Hash) (Map Hash FastString)
@@ -492,12 +486,12 @@ dedupeStat :: HashIdx -> JStat -> JStat
dedupeStat hi = go
where
go (BlockStat ss) = BlockStat (map go ss)
- go s@(DeclStat (TxtI i))
+ go s@(DeclStat (TxtI i) _)
| not (isCanon hi i) = mempty
- | otherwise = s
+ | otherwise = s
go (AssignStat v@(ValExpr (JVar (TxtI i))) e)
| not (isCanon hi i) = mempty
- | otherwise = AssignStat v (identsE' (toCanonI hi) e)
+ | otherwise = AssignStat v (identsE' (toCanonI hi) e)
-- rewrite identifiers in e
go s = identsS' (toCanonI hi) s
@@ -806,7 +800,7 @@ identsV' f (JFunc args s) = JFunc (fmap f args) (identsS' f s)
identsV' _ UnsatVal{} = error "identsV': UnsatVal"
identsS' :: (Ident -> Ident) -> JStat -> JStat
-identsS' f (DeclStat i) = DeclStat $! f i
+identsS' f (DeclStat i e) = DeclStat (f i) e
identsS' f (ReturnStat e) = ReturnStat $! identsE' f e
identsS' f (IfStat e s1 s2) = IfStat (identsE' f e) (identsS' f s1) (identsS' f s2)
identsS' f (WhileStat b e s) = WhileStat b (identsE' f e) (identsS' f s)
=====================================
compiler/GHC/StgToJS/Linker/Types.hs
=====================================
@@ -43,28 +43,22 @@ import System.IO
import Prelude
--- | return a list of fresh @Ident@
+-- | Return a list of fresh local @Ident@
+--
+-- Prefix them with 'h$$' such that these will be compacted by the compactor.
newLocals :: [Ident]
-newLocals = filter (not . isJsKeyword) $
- map (TxtI . mkFastString) $
- map (:[]) chars0 ++ concatMap mkIdents [1..]
+newLocals = mkIdents 0
where
- mkIdents n = [c0:cs | c0 <- chars0, cs <- replicateM n chars]
- chars0 = ['a'..'z']++['A'..'Z']
- chars = chars0++['0'..'9']
-
--- | Rename @newLocals@ to 'h$$' such that these will be compacted by the
--- compactor.
-renamedVars :: [Ident]
-renamedVars = map (\(TxtI xs) -> TxtI ("h$$"<>xs)) newLocals
-
+ mkIdent s = TxtI (mkFastString ("h$$" <> s))
+ mkIdents n = [mkIdent (c0:cs) | c0 <- chars, cs <- replicateM n chars] ++ mkIdents (n+1)
+ chars = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
--------------------------------------------------------------------------------
-- CompactorState
--------------------------------------------------------------------------------
data CompactorState = CompactorState
- { csIdentSupply :: [Ident] -- ^ ident supply for new names
+ { csIdentSupply :: ![Ident] -- ^ ident supply for new names
, csNameMap :: !(UniqMap FastString Ident) -- ^ renaming mapping for internal names
, csEntries :: !(UniqMap FastString Int) -- ^ entry functions (these get listed in the metadata init
-- array)
@@ -91,7 +85,7 @@ data StringTable = StringTable
-- | The empty @CompactorState@
emptyCompactorState :: CompactorState
-emptyCompactorState = CompactorState renamedVars
+emptyCompactorState = CompactorState newLocals
mempty
mempty
0
@@ -121,14 +115,6 @@ entries :: Functor f
entries f cs = fmap (\x -> cs { csEntries = x }) (f $ csEntries cs)
{-# INLINE entries #-}
--- | Update @csIdentSupply@ in @CompactorState@
-identSupply :: Functor f
- => ([Ident] -> f [Ident])
- -> CompactorState
- -> f CompactorState
-identSupply f cs = fmap (\x -> cs { csIdentSupply = x }) (f $ csIdentSupply cs)
-{-# INLINE identSupply #-}
-
-- | Update @csLabels@ in @CompactorState@
labels :: Functor f
=> (UniqMap FastString Int -> f (UniqMap FastString Int))
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -32,7 +32,6 @@ import qualified Data.ByteString.Char8 as Char8
import Data.ByteString (ByteString)
import GHC.Driver.Session
-import GHC.Settings.Config (cProjectVersion)
import GHC.Data.ShortText
import GHC.Unit.State
@@ -43,25 +42,10 @@ import GHC.StgToJS.Types
import Prelude
import GHC.Platform
import Data.List (isPrefixOf)
-import System.Directory (createDirectoryIfMissing)
import System.IO
import Data.Char (isSpace)
-import qualified Data.ByteString as B
import qualified Control.Exception as Exception
--- | Given a FilePath and payload, write a file to disk creating any directories
--- along the way if needed.
-writeBinaryFile :: FilePath -> ByteString -> IO ()
-writeBinaryFile file bs = do
- createDirectoryIfMissing True (takeDirectory file)
- withBinaryFile file WriteMode $ \h -> mapM_ (B.hPut h) (chunks bs)
- where
- -- split the ByteString into a nonempty list of chunks of at most 1GiB
- chunks :: ByteString -> [ByteString]
- chunks b =
- let (b1, b2) = B.splitAt 1073741824 b
- in b1 : if B.null b1 then [] else chunks b2
-
-- | Retrieve library directories provided by the @UnitId@ in @UnitState@
getInstalledPackageLibDirs :: UnitState -> UnitId -> [FilePath]
getInstalledPackageLibDirs us = fmap unpack . maybe mempty unitLibraryDirs . lookupUnitId us
@@ -70,10 +54,6 @@ getInstalledPackageLibDirs us = fmap unpack . maybe mempty unitLibraryDirs . loo
getInstalledPackageHsLibs :: UnitState -> UnitId -> [String]
getInstalledPackageHsLibs us = fmap unpack . maybe mempty unitLibraries . lookupUnitId us
--- | A constant holding the compiler version
-getCompilerVersion :: String
-getCompilerVersion = cProjectVersion
-
-- | A constant holding the JavaScript executable Filename extension
jsexeExtension :: String
jsexeExtension = "jsexe"
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -404,7 +404,7 @@ instance Binary ExpFun where
get bh = ExpFun <$> get bh <*> get bh <*> get bh
instance Binary JStat where
- put_ bh (DeclStat i) = putByte bh 1 >> put_ bh i
+ put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e
put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e
put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2
put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s
@@ -420,7 +420,7 @@ instance Binary JStat where
put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml
put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml
get bh = getByte bh >>= \case
- 1 -> DeclStat <$> get bh
+ 1 -> DeclStat <$> get bh <*> get bh
2 -> ReturnStat <$> get bh
3 -> IfStat <$> get bh <*> get bh <*> get bh
4 -> WhileStat <$> get bh <*> get bh <*> get bh
=====================================
compiler/GHC/StgToJS/Printer.hs
=====================================
@@ -81,13 +81,26 @@ prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs)
-- recognize common patterns in a block and convert them to more idiomatic/concise javascript
prettyBlock' :: RenderJs -> [JStat] -> [Doc]
+-- return/...
+prettyBlock' r ( x@(ReturnStat _)
+ : xs
+ )
+ | not (null xs)
+ = prettyBlock' r [x]
+-- declare/assign
+prettyBlock' r ( (DeclStat i Nothing)
+ : (AssignStat (ValExpr (JVar i')) v)
+ : xs
+ )
+ | i == i'
+ = prettyBlock' r (DeclStat i (Just v) : xs)
+
-- resugar for loops with/without var declaration
-prettyBlock' r ( (DeclStat i)
- : (AssignStat (ValExpr (JVar i')) v0)
- : (WhileStat False p (BlockStat bs))
- : xs
- )
- | i == i' && not (null flat) && isForUpdStat (last flat)
+prettyBlock' r ( (DeclStat i (Just v0))
+ : (WhileStat False p (BlockStat bs))
+ : xs
+ )
+ | not (null flat) && isForUpdStat (last flat)
= mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs
where
flat = flattenBlocks bs
@@ -101,20 +114,12 @@ prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0)
flat = flattenBlocks bs
-- global function (does not preserve semantics but works for GHCJS)
-prettyBlock' r ( (DeclStat i)
- : (AssignStat (ValExpr (JVar i')) (ValExpr (JFunc is b)))
+prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b))))
: xs
)
- | i == i' = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
+ = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
(jsToDocR r b)
) : prettyBlock' r xs
--- declare/assign
-prettyBlock' r ( (DeclStat i)
- : (AssignStat (ValExpr (JVar i')) v)
- : xs
- )
- | i == i' = (text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v) : prettyBlock' r xs
-
-- modify/assign operators
prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1))))
: xs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0015d2d96866b09142cf58fcc27ef4ffbfcda9bc...21ef7cfbc466fbd92a80390ef2b575e8a713f12f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0015d2d96866b09142cf58fcc27ef4ffbfcda9bc...21ef7cfbc466fbd92a80390ef2b575e8a713f12f
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/20221012/1d047935/attachment-0001.html>
More information about the ghc-commits
mailing list