[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: base: Add build-order import of GHC.Types in GHC.IO.Handle.Types

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sat Jun 3 13:29:08 UTC 2023



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


Commits:
4a4eb761 by Ben Gamari at 2023-06-02T23:53:21-04:00
base: Add build-order import of GHC.Types in GHC.IO.Handle.Types

For reasons similar to those described in Note [Depend on
GHC.Num.Integer].

Fixes #23411.

- - - - -
f53ac0ae by Sylvain Henry at 2023-06-02T23:54:01-04:00
JS: fix and enhance non-minimized code generation (#22455)

Flag -ddisable-js-minimizer was producing invalid code. Fix that and
also a few other things to generate nicer JS code for debugging.

The added test checks that we don't regress when using the flag.

- - - - -
e4827476 by Andrey Mokhov at 2023-06-03T09:28:55-04:00
[hadrian] Fix multiline synopsis rendering

- - - - -
b022caf1 by Bodigrim at 2023-06-03T09:28:59-04:00
Elaborate on performance properties of Data.List.++

- - - - -


14 changed files:

- compiler/GHC/JS/Make.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Opt.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- hadrian/src/Hadrian/Utilities.hs
- libraries/base/GHC/Base.hs
- libraries/base/GHC/IO/Handle/Types.hs-boot
- + testsuite/tests/javascript/T22455.hs
- + testsuite/tests/javascript/T22455.stdout
- testsuite/tests/javascript/all.T


Changes:

=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.JS.Make
   -- $intro_funcs
   , var
   , jString
-  , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally
+  , jLam, jFun, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally
   -- * Combinators
   -- $combinators
   , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)
@@ -249,6 +249,15 @@ jLam f = ValExpr . UnsatVal . IS $ do
            (block,is) <- runIdentSupply $ toSat_ f []
            return $ JFunc is block
 
+-- | Create a new function. The result is a 'GHC.JS.Syntax.JStat'.
+-- Usage:
+--
+-- > jFun fun_name $ \x -> ...
+jFun :: ToSat a => Ident -> a -> JStat
+jFun n f = UnsatBlock . IS $ do
+           (block,is) <- runIdentSupply $ toSat_ f []
+           return $ FuncStat n is block
+
 -- | Introduce a new variable into scope for the duration
 -- of the enclosed expression. The result is a block statement.
 -- Usage:


=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -60,7 +60,6 @@ module GHC.JS.Ppr
   , jsToDoc
   , pprStringLit
   , interSemi
-  , addSemi
   , braceNest
   , hangBrace
   )
@@ -138,15 +137,25 @@ instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
 
 defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
 defRenderJsS r = \case
-  IfStat cond x y -> hangBrace (text "if" <+?> parens (jsToDocR r cond))
-                      (jnest $ optBlock r x)
-                      <+?> mbElse
+  IfStat cond x y -> jcat
+                        [ hangBrace (text "if" <+?> parens (jsToDocR r cond)) (optBlock r x)
+                        , mbElse
+                        ]
         where mbElse | y == BlockStat []  = empty
-                     | otherwise = hangBrace (text "else") (jnest $ optBlock r y)
+                     | otherwise = hangBrace (text "else") (optBlock r y)
   DeclStat x Nothing  -> text "var" <+> jsToDocR r x
+    -- special treatment for functions, otherwise there is too much left padding
+    -- (more than the length of the expression assigned to). E.g.
+    --
+    --    var long_variable_name = (function()
+    --                               {
+    --                               ...
+    --                             });
+    --
+  DeclStat x (Just (ValExpr f@(JFunc {}))) -> jhang (text "var" <+> jsToDocR r x <+?> char '=') (jsToDocR r f)
   DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e
-  WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (jnest $ optBlock r b)
-  WhileStat True  p b -> hangBrace (text "do") (jnest $ optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)
+  WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (optBlock r b)
+  WhileStat True  p b -> hangBrace (text "do") (optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)
   BreakStat l         -> addSemi $ maybe (text "break")    (\(LexicalFastString s) -> (text "break"    <+> ftext s)) l
   ContinueStat l      -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
   LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s
@@ -154,10 +163,10 @@ defRenderJsS r = \case
           printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss
           printBS x = jsToDocR r x
 
-  ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (jnest $ optBlock r sb)
+  ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (optBlock r sb)
     where
       forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1)
-  ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jnest $ optBlock r b)
+  ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (optBlock r b)
         where txt | each = "for each"
                   | otherwise = "for"
   SwitchStat e l d     -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases
@@ -168,33 +177,35 @@ defRenderJsS r = \case
   ApplStat e es     -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es)
   FuncStat i is b   -> hangBrace (text "function" <+> jsToDocR r i
                                   <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is))
-                             (jnest $ optBlock r b)
+                             (optBlock r b)
   TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally
         where mbCatch | s1 == BlockStat [] = empty
-                      | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (jnest $ optBlock r s1)
+                      | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1)
               mbFinally | s2 == BlockStat [] = empty
-                        | otherwise = hangBrace (text "finally") (jnest $ optBlock r s2)
+                        | otherwise = hangBrace (text "finally") (optBlock r s2)
   AssignStat i op x    -> case x of
     -- special treatment for functions, otherwise there is too much left padding
     -- (more than the length of the expression assigned to). E.g.
     --
-    --    var long_variable_name = (function()
+    --    long_variable_name = (function()
     --                               {
     --                               ...
     --                             });
     --
-    ValExpr (JFunc is b) -> jsToDocR r i <> ftext (aOpText op) <> text " function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is) <> braceNest (jsToDocR r b)
-    _                      -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x
+    ValExpr f@(JFunc {}) -> jhang (jsToDocR r i <> ftext (aOpText op)) (jsToDocR r f)
+    _                    -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x
   UOpStat op x
     | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
     | isPre op                 -> ftext (uOpText op) <+> optParens r x
     | otherwise                -> optParens r x <+> ftext (uOpText op)
   BlockStat xs -> jsToDocR r xs
 
+-- | Remove one Block layering if we know we already have braces around the
+-- statement
 optBlock :: JsRender doc => RenderJs doc -> JStat -> doc
 optBlock r x = case x of
   BlockStat{} -> jsToDocR r x
-  _           -> addSemi $ jsToDocR r x
+  _           -> addSemi (jsToDocR r x)
 
 optParens :: JsRender doc => RenderJs doc -> JExpr -> doc
 optParens r x = case x of
@@ -338,9 +349,6 @@ encodeJsonChar = \case
 interSemi :: JsRender doc => [doc] -> doc
 interSemi = foldl ($$$) empty . punctuateFinal semi semi
 
-addSemi :: IsLine doc => doc -> doc
-addSemi x = x <> semi <> char '\n'
-
 -- | The structure `{body}`, optionally indented over multiple lines
 {-# INLINE braceNest #-}
 braceNest :: JsRender doc => doc -> doc
@@ -349,7 +357,11 @@ braceNest x = lbrace $$$ jnest x $$$ rbrace
 -- | The structure `hdr {body}`, optionally indented over multiple lines
 {-# INLINE hangBrace #-}
 hangBrace :: JsRender doc => doc -> doc -> doc
-hangBrace hdr body = hdr <+?> braceNest body
+hangBrace hdr body = jcat [ hdr <> char ' ' <> char '{', jnest body, char '}' ]
+
+{-# INLINE jhang #-}
+jhang :: JsRender doc => doc -> doc -> doc
+jhang hdr body = jcat [ hdr, jnest body]
 
 -- | JsRender controls the differences in whitespace between HLine and SDoc.
 -- Generally, this involves the indentation and newlines in the human-readable
@@ -365,16 +377,21 @@ class IsLine doc => JsRender doc where
   jcat      :: [doc] -> doc
   -- | Optionally indent the following
   jnest     :: doc -> doc
+  -- | Append semi-colon (and line-break in HLine mode)
+  addSemi   :: doc -> doc
 
 instance JsRender SDoc where
   (<+?>) = (<+>)
   {-# INLINE (<+?>) #-}
-  ($$$)  = ($$)
+  ($$$)  = ($+$)
   {-# INLINE ($$$) #-}
   jcat               = vcat
   {-# INLINE jcat #-}
   jnest              = nest 2
   {-# INLINE jnest #-}
+  addSemi x = x <> semi
+  {-# INLINE addSemi #-}
+
 
 instance JsRender HLine where
   (<+?>) = (<>)
@@ -385,3 +402,6 @@ instance JsRender HLine where
   {-# INLINE jcat #-}
   jnest              = id
   {-# INLINE jnest #-}
+  addSemi x = x <> semi <> char '\n'
+  -- we add a line-break to avoid issues with lines too long in minified outputs
+  {-# INLINE addSemi #-}


=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -590,7 +590,7 @@ genericStackApply cfg = closure info body
 --
 genericFastApply :: StgToJSConfig -> JStat
 genericFastApply s =
-   TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c ->
+   jFun (TxtI "h$ap_gen_fast") \tag -> jVar \c ->
       [traceRts s (jString "h$ap_gen_fast: " + tag)
       , c |= closureEntry r1
       , SwitchStat (entryClosureType c)
@@ -802,12 +802,12 @@ stackApply s fun_name nargs nvars =
 -- h$ap_n_r_fast is entered if a function of unknown arity is called, n
 -- arguments are already in r registers
 fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
-fastApply s fun_name nargs nvars = func ||= body0
+fastApply s fun_name nargs nvars = body0
   where
       -- special case for h$ap_0_0_fast
       body0 = if nargs == 0 && nvars == 0
-        then jLam (enter s r1)
-        else toJExpr (JFunc myFunArgs body)
+        then jFun func (enter s r1)
+        else FuncStat func myFunArgs body
 
       func    = TxtI fun_name
 
@@ -875,7 +875,7 @@ fastApply s fun_name nargs nvars = func ||= body0
 
 zeroApply :: StgToJSConfig -> JStat
 zeroApply s = mconcat
-  [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c)
+  [ jFun (TxtI "h$e") (\c -> (r1 |= c) <> enter s c)
   ]
 
 -- carefully enter a closure that might be a thunk or a function
@@ -973,13 +973,13 @@ selectors s =
 
     mkSel :: FastString -> (JExpr -> JExpr) -> JStat
     mkSel name sel = mconcat
-      [TxtI createName ||= jLam \r -> mconcat
+      [jFun (TxtI createName) \r -> mconcat
           [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))
           , ifS (isThunk r .||. isBlackhole r)
               (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)]))
               (returnS (sel r))
           ]
-      , TxtI resName ||= jLam \r -> mconcat
+      , jFun (TxtI resName) \r -> mconcat
           [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))
           , returnS (sel r)
           ]
@@ -1106,7 +1106,7 @@ papGen cfg =
 -- general utilities
 -- move the first n registers, starting at R2, m places up (do not use with negative m)
 moveRegs2 :: JStat
-moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch
+moveRegs2 = jFun (TxtI "h$moveRegs2") moveSwitch
   where
     moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m)
     -- fast cases


=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -116,7 +116,7 @@ setObjInfo debug obj t name fields a size regs static
 closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
         -> JStat       -- ^ rhs
         -> JStat
-closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci
+closure ci body = (jFun (ciVar ci) body) `mappend` closureInfoStat False ci
 
 conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
 conClosure symbol name layout constr =


=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -366,4 +366,4 @@ genToplevelRhs i rhs = case rhs of
                                  sr)
     ccId <- costCentreStackLbl cc
     emitStatic idt static ccId
-    return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body)))
+    return $ (FuncStat eid [] (ll <> upd <> setcc <> body))


=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -198,12 +198,7 @@ link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun ex
       -- link generated RTS parts into rts.js
       unless (lcNoRts lc_cfg) $ do
         withFile (out </> "rts.js") WriteMode $ \h -> do
-         if csPrettyRender cfg
-          then printSDoc defaultJsContext (Ppr.PageMode True) h (rtsDeclsText $$ rtsText cfg)
-          else do
-            bh <- newBufHandle h
-            bPutHDoc bh defaultJsContext (line rtsDeclsText $$ line (rtsText cfg))
-            bFlush bh
+          void $ hPutJS (csPrettyRender cfg) h (rts cfg)
 
       -- link dependencies' JS files into lib.js
       withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
@@ -307,6 +302,24 @@ data CompactedModuleCode = CompactedModuleCode
   , cmc_exports :: !B.ByteString        -- ^ rendered exports
   }
 
+-- | Output JS statements and return the output size in bytes.
+hPutJS :: Bool -> Handle -> Sat.JStat -> IO Integer
+hPutJS render_pretty h = \case
+  Sat.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
+    -- Append an empty line to correctly end the file in a newline
+    hPutChar h '\n'
+    after <- hTell h
+    pure $! (after - before)
+
 -- | Link modules and pretty-print them into the given Handle
 renderLinker
   :: Handle
@@ -321,18 +334,7 @@ renderLinker h render_pretty mods jsFiles = do
 
   let
     putBS   = B.hPut h
-    putJS x = do
-      before <- hTell h
-      if render_pretty
-        then do
-          printSDoc defaultJsContext (Ppr.PageMode True) h (pretty x)
-        else do
-          bh <- newBufHandle h
-          -- Append an empty line to correctly end the file in a newline
-          bPutHDoc bh defaultJsContext ((line $ pretty x) $$ empty)
-          bFlush bh
-      after <- hTell h
-      pure $! (after - before)
+    putJS   = hPutJS render_pretty h
 
   ---------------------------------------------------------
   -- Pretty-print JavaScript code for all the dependencies.


=====================================
compiler/GHC/StgToJS/Linker/Opt.hs
=====================================
@@ -20,7 +20,7 @@
 -----------------------------------------------------------------------------
 module GHC.StgToJS.Linker.Opt
   ( pretty
-  , ghcjsRenderJs
+  , optRenderJs
   )
 where
 
@@ -39,11 +39,17 @@ import Data.List (sortOn)
 import Data.Char (isAlpha,isDigit,ord)
 import qualified Data.ByteString.Short as SBS
 
-pretty :: JsRender doc => JStat -> doc
-pretty = jsToDocR ghcjsRenderJs
-
-ghcjsRenderJs :: RenderJs doc
-ghcjsRenderJs = defaultRenderJs
+pretty :: JsRender doc => Bool -> JStat -> doc
+pretty render_pretty = \case
+  BlockStat []      -> empty
+  s | render_pretty -> jsToDocR defaultRenderJs [s]
+    | otherwise     -> jsToDocR optRenderJs [s]
+                        -- render as a list of statements to ensure that
+                        -- semicolons are added.
+
+-- | Render JS with code size minimization enabled
+optRenderJs :: RenderJs doc
+optRenderJs = defaultRenderJs
   { renderJsV = ghcjsRenderJsV
   , renderJsS = ghcjsRenderJsS
   , renderJsI = ghcjsRenderJsI


=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
-
-{-# OPTIONS_GHC -O0 #-}
+{-# LANGUAGE BlockArguments    #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -24,7 +23,11 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.StgToJS.Rts.Rts where
+module GHC.StgToJS.Rts.Rts
+  ( rts
+  , assignRegs
+  )
+where
 
 import GHC.Prelude
 
@@ -42,11 +45,8 @@ import GHC.StgToJS.Regs
 import GHC.StgToJS.Types
 import GHC.StgToJS.Stack
 
-import GHC.StgToJS.Linker.Opt
-
 import GHC.Data.FastString
 import GHC.Types.Unique.Map
-import GHC.JS.Ppr
 
 import Data.Array
 import Data.Monoid
@@ -56,8 +56,8 @@ import qualified Data.Bits          as Bits
 -- | The garbageCollector resets registers and result variables.
 garbageCollector :: JStat
 garbageCollector =
-  mconcat [ TxtI "h$resetRegisters"  ||= jLam (mconcat $ map resetRegister [minBound..maxBound])
-          , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound])
+  mconcat [ jFun (TxtI "h$resetRegisters")  (mconcat $ map resetRegister [minBound..maxBound])
+          , jFun (TxtI "h$resetResultVars") (mconcat $ map resetResultVar [minBound..maxBound])
           ]
 
 -- | Reset the register 'r' in JS Land. Note that this "resets" by setting the
@@ -233,8 +233,8 @@ declRegs =
 -- | JS payload to define getters and setters on the registers.
 regGettersSetters :: JStat
 regGettersSetters =
-  mconcat [ TxtI "h$getReg" ||= jLam (\n   -> SwitchStat n getRegCases mempty)
-          , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty)
+  mconcat [ jFun (TxtI "h$getReg") (\n   -> SwitchStat n getRegCases mempty)
+          , jFun (TxtI "h$setReg") (\n v -> SwitchStat n (setRegCases v) mempty)
           ]
   where
     getRegCases =
@@ -292,17 +292,16 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo
     mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE"
                       in  s ||= toJExpr c
     closureTypeName :: JStat
-    closureTypeName =
-      TxtI "h$closureTypeName" ||= jLam (\c ->
-                                           mconcat (map (ifCT c) [minBound..maxBound])
-                                          <> returnS (jString "InvalidClosureType"))
+    closureTypeName = jFun (TxtI "h$closureTypeName") \c ->
+                        mconcat (map (ifCT c) [minBound..maxBound])
+                        <> returnS (jString "InvalidClosureType")
 
     ifCT :: JExpr -> ClosureType -> JStat
     ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
 
 -- | JS payload declaring the RTS functions.
-rtsDecls :: Sat.JStat
-rtsDecls = satJStat (Just "h$RTSD") $
+rtsDecls :: JStat
+rtsDecls =
   mconcat [ TxtI "h$currentThread"   ||= null_                   -- thread state object for current thread
           , TxtI "h$stack"           ||= null_                   -- stack for the current thread
           , TxtI "h$sp"              ||= 0                       -- stack pointer for the current thread
@@ -315,17 +314,12 @@ rtsDecls = satJStat (Just "h$RTSD") $
           , declRegs
           , declRets]
 
--- | print the embedded RTS to a String
-rtsText :: forall doc. JsRender doc => StgToJSConfig -> doc
-rtsText = pretty @doc . jsOptimize . rts
-
--- | print the RTS declarations to a String.
-rtsDeclsText :: forall doc. JsRender doc => doc
-rtsDeclsText = pretty @doc . jsOptimize $ rtsDecls
-
--- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
+-- | Generated RTS code
 rts :: StgToJSConfig -> Sat.JStat
-rts = satJStat (Just "h$RTS") . rts'
+rts cfg = jsOptimize $ satJStat (Just "h$RTS") $ mconcat
+  [ rtsDecls
+  , rts' cfg
+  ]
 
 -- | JS Payload which defines the embedded RTS.
 rts' :: StgToJSConfig -> JStat
@@ -349,8 +343,8 @@ rts' s =
           , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV
           , TxtI "h$vt_obj"    ||= toJExpr ObjV
           , TxtI "h$vt_arr"    ||= toJExpr ArrV
-          , TxtI "h$bh"        ||= jLam (bhStats s True)
-          , TxtI "h$bh_lne"    ||= jLam (\x frameSize -> bhLneStats s x frameSize)
+          , jFun (TxtI "h$bh")     (bhStats s True)
+          , jFun (TxtI "h$bh_lne") (\x frameSize -> bhLneStats s x frameSize)
           , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
                (appS "throw" [jString "oops: entered black hole"])
           , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)


=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -574,22 +574,36 @@ renderCreateFileLink linkTarget link' = do
     where
         link = unifyPath link'
 
+-- | Render a multiline string, prefixing the first line with a header.
+renderMultiLineString :: String -> String -> [String]
+renderMultiLineString header string =
+    [ linePrefix index ++ line | (index, line) <- zip [0..] (lines string) ]
+  where
+    linePrefix :: Int -> String
+    linePrefix index
+        | index == 0 = header
+        | otherwise  = replicate (length header) ' '
+
+-- | Render a (possibly multiline) synopsis, making sure it ends with a dot.
+renderSynopsis :: String -> String -> [String]
+renderSynopsis header synopsis
+    | null synopsis = []
+    | otherwise = renderMultiLineString header (endWithADot synopsis)
+  where
+    endWithADot :: String -> String
+    endWithADot s = dropWhileEnd isPunctuation s ++ "."
+
 -- | Render the successful build of a program.
 renderProgram :: String -> String -> String -> String
 renderProgram name bin synopsis = renderBox $
-    [ "Successfully built program " ++ name
-    , "Executable: " ++ bin ] ++
-    [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
+    [ "Successfully built program " ++ name, "Executable: " ++ bin ] ++
+    renderSynopsis "Program synopsis: " synopsis
 
 -- | Render the successful build of a library.
 renderLibrary :: String -> String -> String -> String
 renderLibrary name lib synopsis = renderBox $
-    [ "Successfully built library " ++ name
-    , "Library: " ++ lib ] ++
-    [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
-
-endWithADot :: String -> String
-endWithADot s = dropWhileEnd isPunctuation s ++ "."
+    [ "Successfully built library " ++ name, "Library: " ++ lib ] ++
+    renderSynopsis "Library synopsis: " synopsis
 
 -- | Render the given set of lines in an ASCII box. The minimum width and
 -- whether to use Unicode symbols are hardcoded in the function's body.


=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -1461,8 +1461,13 @@ The rules for map work like this.
 --
 -- If the first list is not finite, the result is the first list.
 --
--- WARNING: This function takes linear time in the number of elements of the
--- first list.
+-- This function takes linear time in the number of elements of the
+-- __first__ list. Thus it is better to associate repeated
+-- applications of '(++)' to the right (which is the default behaviour):
+-- @xs ++ (ys ++ zs)@ or simply @xs ++ ys ++ zs@, but not @(xs ++ ys) ++ zs at .
+-- For the same reason 'Data.List.concat' @=@ 'Data.List.foldr' '(++)' @[]@
+-- has linear performance, while 'Data.List.foldl' '(++)' @[]@ is prone
+-- to quadratic slowdown.
 
 (++) :: [a] -> [a] -> [a]
 {-# NOINLINE [2] (++) #-}


=====================================
libraries/base/GHC/IO/Handle/Types.hs-boot
=====================================
@@ -2,4 +2,7 @@
 
 module GHC.IO.Handle.Types ( Handle ) where
 
+-- See Note [Depend on GHC.Num.Integer] in GHC.Base
+import GHC.Types ()
+
 data Handle


=====================================
testsuite/tests/javascript/T22455.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "Hello World"


=====================================
testsuite/tests/javascript/T22455.stdout
=====================================
@@ -0,0 +1 @@
+Hello World


=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -17,3 +17,4 @@ test('js-callback04', js_skip, compile_and_run, [''])
 test('js-callback05', js_skip, compile_and_run, [''])
 
 test('T23346', normal, compile_and_run, [''])
+test('T22455', normal, compile_and_run, ['-ddisable-js-minifier'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f442f113eba70491eeb21636485e2dd480d7c2b0...b022caf1b80442c58cdb6ca97913b442d923d92a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f442f113eba70491eeb21636485e2dd480d7c2b0...b022caf1b80442c58cdb6ca97913b442d923d92a
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/20230603/2ee696d9/attachment-0001.html>


More information about the ghc-commits mailing list