[Git][ghc/ghc][wip/js-staging] 3 commits: Ppr: add hangBrace helper
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Wed Aug 31 23:20:35 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
9350d2ae by Sylvain Henry at 2022-08-31T22:13:48+02:00
Ppr: add hangBrace helper
- - - - -
5e90ac04 by Sylvain Henry at 2022-09-01T01:11:36+02:00
Only declare ccs var in profiling mode
- - - - -
2b782512 by Sylvain Henry at 2022-09-01T01:12:20+02:00
Don't consider recursive bindings as inline nor as evaluated
Fix mdo001
- - - - -
5 changed files:
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Printer.hs
- compiler/GHC/StgToJS/StgUtils.hs
Changes:
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -23,8 +23,7 @@ module GHC.JS.Ppr
, pprStringLit
, flattenBlocks
, braceNest
- , braceNest'
- , braceNest''
+ , hangBrace
)
where
@@ -88,12 +87,13 @@ renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx)
braceNest :: Doc -> Doc
braceNest x = char '{' <+> nest 2 x $$ char '}'
-braceNest' :: Doc -> Doc
-braceNest' x = nest 2 (char '{' $+$ x) $$ char '}'
-
--- somewhat more compact (egyptian style) braces
-braceNest'' :: Doc -> Doc
-braceNest'' x = nest 2 (char '{' $$ x) $$ char '}'
+-- | Hang with braces:
+--
+-- hdr {
+-- body
+-- }
+hangBrace :: Doc -> Doc -> Doc
+hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]
class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
instance JsToDoc JStat where jsToDocR r = renderJsS r r
@@ -107,12 +107,14 @@ instance JsToDoc [JStat] where
defRenderJsS :: RenderJs -> JStat -> Doc
defRenderJsS r = \case
- IfStat cond x y -> text "if" <> parens (jsToDocR r cond) $$ braceNest' (jsToDocR r x) $$ mbElse
+ IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond))
+ (jsToDocR r x)
+ $$ mbElse
where mbElse | y == BlockStat [] = PP.empty
- | otherwise = text "else" $$ braceNest' (jsToDocR r y)
+ | otherwise = hangBrace (text "else") (jsToDocR r y)
DeclStat x -> text "var" <+> jsToDocR r x
- WhileStat False p b -> text "while" <> parens (jsToDocR r p) $$ braceNest' (jsToDocR r b)
- WhileStat True p b -> (text "do" $$ braceNest' (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
+ 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
BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l
ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
@@ -124,19 +126,19 @@ defRenderJsS r = \case
interSemi [] = []
interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs
- ForInStat each i e b -> text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e) $$ braceNest' (jsToDocR r b)
+ ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b)
where txt | each = "for each"
| otherwise = "for"
- SwitchStat e l d -> text "switch" <+> parens (jsToDocR r e) $$ braceNest' cases
+ SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases
where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)]
cases = vcat l'
ReturnStat e -> text "return" <+> jsToDocR r e
ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es)
- TryStat s i s1 s2 -> text "try" $$ braceNest' (jsToDocR r s) $$ mbCatch $$ mbFinally
+ TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally
where mbCatch | s1 == BlockStat [] = PP.empty
- | otherwise = text "catch" <> parens (jsToDocR r i) $$ braceNest' (jsToDocR r s1)
+ | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1)
mbFinally | s2 == BlockStat [] = PP.empty
- | otherwise = text "finally" $$ braceNest' (jsToDocR r s2)
+ | otherwise = hangBrace (text "finally") (jsToDocR r s2)
AssignStat i x -> case x of
-- special treatment for functions, otherwise there is too much left padding
-- (more than the length of the expression assigned to). E.g.
@@ -198,7 +200,7 @@ defRenderJsV r = \case
-- nonDetEltsUniqMap doesn't introduce non-determinism here
-- because we sort the elements lexically
$ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m)
- JFunc is b -> parens $ text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) $$ braceNest' (jsToDocR r b)
+ JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
UnsatVal f -> jsToDocR r $ pseudoSaturate f
defRenderJsI :: RenderJs -> Ident -> Doc
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -170,7 +170,7 @@ genApp ctx i args
-- case of Id without args and known to be already evaluated: return fields
-- individually
| [] <- args
- , ctxIsEvaluated ctx i || isStrictId i
+ , ctxIsEvaluated ctx i || isStrictType (idType i)
= do
a <- storeIdFields i (ctxTarget ctx)
-- optional runtime assert for detecting unexpected thunks (unevaluated)
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -518,7 +518,7 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStat, ExprResult)
genCase ctx bnd e at alts l
- | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = freshIdent >>= \ccsVar -> do
+ | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
$ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
@@ -529,15 +529,17 @@ genCase ctx bnd e at alts l
ExprCont -> pprPanic "genCase: expression was not inline"
(pprStgExpr panicStgPprOpts e)
- ww = mempty -- if snd (isInlineExpr emptyUniqSet e) then mempty else [j| h$log('danger will robinson'); |]
(aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts
- saveCCS <- ifProfiling (toJExpr ccsVar |= toJExpr jCurrentCCS)
- restoreCCS <- ifProfiling (toJExpr jCurrentCCS |= toJExpr ccsVar)
+ (declCCS,saveCCS,restoreCCS) <- ifProfilingM $ do
+ ccsVar <- freshIdent
+ pure ( DeclStat ccsVar
+ , toJExpr ccsVar |= toJExpr jCurrentCCS
+ , toJExpr jCurrentCCS |= toJExpr ccsVar
+ )
return ( mconcat
- [ DeclStat ccsVar
+ [ declCCS
, mconcat (map DeclStat bndi)
, saveCCS
- , ww
, ej
, restoreCCS
, aj
@@ -940,7 +942,7 @@ allocDynAll haveDecl middle cls = do
dec i | haveDecl = DeclStat i
| otherwise = mempty
checkObjs | csAssertRts settings = mconcat $
- map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i] {-[j| h$checkObj(`i`); |]-}) cls
+ map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls
| otherwise = mempty
objs <- makeObjs
=====================================
compiler/GHC/StgToJS/Printer.hs
=====================================
@@ -105,9 +105,8 @@ prettyBlock' r ( (DeclStat i)
: (AssignStat (ValExpr (JVar i')) (ValExpr (JFunc is b)))
: xs
)
- | i == i' = (text "function" <+> jsToDocR r i
- <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)
- $$ braceNest' (jsToDocR r b)
+ | i == i' = (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)
@@ -140,7 +139,8 @@ prettyBlock' _ [] = []
-- build the for block
mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
-mkFor r decl i v0 p s1 sb = text "for" <> forCond <+> braceNest'' (jsToDocR r $ BlockStat sb)
+mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond)
+ (jsToDocR r $ BlockStat sb)
where
c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0
| otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0
=====================================
compiler/GHC/StgToJS/StgUtils.hs
=====================================
@@ -255,8 +255,8 @@ isInlineApp v i = \case
_ | isJoinId i -> False
[] -> isUnboxedTupleType (idType i) ||
isStrictType (idType i) ||
- i `elementOfUniqSet` v ||
- isStrictId i
+ i `elementOfUniqSet` v
+
[StgVarArg a]
| DataConWrapId dc <- idDetails i
, isNewTyCon (dataConTyCon dc)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/577b4845277443f721e394bd41621aee393efe9f...2b782512356aeded56d8191f1fe51348fecb69be
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/577b4845277443f721e394bd41621aee393efe9f...2b782512356aeded56d8191f1fe51348fecb69be
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/20220831/bdeba6a8/attachment-0001.html>
More information about the ghc-commits
mailing list