[Git][ghc/ghc][wip/T22998] 3 commits: Handle top-level Addr# literals in the bytecode compiler

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Tue Feb 21 11:30:40 UTC 2023



Simon Peyton Jones pushed to branch wip/T22998 at Glasgow Haskell Compiler / GHC


Commits:
26243de1 by Alexis King at 2023-02-20T15:27:17-05:00
Handle top-level Addr# literals in the bytecode compiler

Fixes #22376.

- - - - -
0196cc2b by romes at 2023-02-20T15:27:52-05:00
fix: Explicitly flush stdout on plugin

Because of #20791, the plugins tests often fail.  This is a temporary
fix to stop the tests from failing due to unflushed outputs on windows
and the explicit flush should be removed when #20791 is fixed.

- - - - -
47f549b7 by Simon Peyton Jones at 2023-02-21T11:31:54+00:00
Take more care with unlifted bindings in the specialiser

As #22998 showed, we were floating an unlifted binding to top
level, which breaks a Core invariant.

The fix is easy, albeit a little bit conservative.  See
Note [Care with unlifted bindings] in GHC.Core.Opt.Specialise

- - - - -


20 changed files:

- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/StgToByteCode.hs
- + testsuite/tests/bytecode/T22376/A.hs
- + testsuite/tests/bytecode/T22376/B.hs
- + testsuite/tests/bytecode/T22376/T22376.hs
- + testsuite/tests/bytecode/T22376/T22376.stdout
- + testsuite/tests/bytecode/T22376/all.T
- testsuite/tests/plugins/all.T
- testsuite/tests/plugins/echo-plugin/Echo.hs
- testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
- + testsuite/tests/simplCore/should_run/T22998.hs
- + testsuite/tests/simplCore/should_run/T22998.stdout
- testsuite/tests/simplCore/should_run/all.T


Changes:

=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -97,7 +97,7 @@ assembleBCOs
   -> Profile
   -> [ProtoBCO Name]
   -> [TyCon]
-  -> [RemotePtr ()]
+  -> AddrEnv
   -> Maybe ModBreaks
   -> IO CompiledByteCode
 assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
@@ -105,27 +105,40 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
   -- fixed for an interpreter
   itblenv <- mkITbls interp profile tycons
   bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
-  (bcos',ptrs) <- mallocStrings interp bcos
+  bcos'   <- mallocStrings interp bcos
   return CompiledByteCode
     { bc_bcos = bcos'
     , bc_itbls =  itblenv
     , bc_ffis = concatMap protoBCOFFIs proto_bcos
-    , bc_strs = top_strs ++ ptrs
+    , bc_strs = top_strs
     , bc_breaks = modbreaks
     }
 
--- Find all the literal strings and malloc them together.  We want to
--- do this because:
+-- Note [Allocating string literals]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Our strategy for handling top-level string literal bindings is described in
+-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,
+-- but not all Addr# literals in a program are guaranteed to be lifted to the
+-- top level. Our strategy for handling local Addr# literals is somewhat simpler:
+-- after assembling, we find all the BCONPtrStr arguments in the program, malloc
+-- memory for them, and bake the resulting addresses into the instruction stream
+-- in the form of BCONPtrWord arguments.
 --
---  a) It should be done when we compile the module, not each time we relink it
---  b) For -fexternal-interpreter It's more efficient to malloc the strings
---     as a single batch message, especially when compiling in parallel.
+-- Since we do this when assembling, we only allocate the memory when we compile
+-- the module, not each time we relink it. However, we do want to take care to
+-- malloc the memory all in one go, since that is more efficient with
+-- -fexternal-interpreter, especially when compiling in parallel.
 --
-mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
+-- Note that, as with top-level string literal bindings, this memory is never
+-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for
+-- top-level string literal bindings] in GHC.StgToByteCode for some discussion
+-- about why.
+--
+mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
 mallocStrings interp ulbcos = do
   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
   ptrs <- interpCmd interp (MallocStrings bytestrings)
-  return (evalState (mapM splice ulbcos) ptrs, ptrs)
+  return (evalState (mapM splice ulbcos) ptrs)
  where
   splice bco at UnlinkedBCO{..} = do
     lits <- mapM spliceLit unlinkedBCOLits
@@ -162,7 +175,7 @@ assembleOneBCO interp profile pbco = do
   -- TODO: the profile should be bundled with the interpreter: the rts ways are
   -- fixed for an interpreter
   ubco <- assembleBCO (profilePlatform profile) pbco
-  ([ubco'], _ptrs) <- mallocStrings interp [ubco]
+  [ubco'] <- mallocStrings interp [ubco]
   return ubco'
 
 assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
@@ -411,6 +424,10 @@ assembleI platform i = case i of
   PUSH_UBX lit nws         -> do np <- literal lit
                                  emit bci_PUSH_UBX [Op np, SmallOp nws]
 
+  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
+  PUSH_ADDR nm             -> do np <- lit [BCONPtrAddr nm]
+                                 emit bci_PUSH_UBX [Op np, SmallOp 1]
+
   PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
   PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
   PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []


=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -112,6 +112,10 @@ data BCInstr
         -- type, and it appears impossible to get hold of the bits of
         -- an addr, even though we need to assemble BCOs.
 
+   -- Push a top-level Addr#. This is a pseudo-instruction assembled to PUSH_UBX,
+   -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
+   | PUSH_ADDR Name
+
    -- various kinds of application
    | PUSH_APPLY_N
    | PUSH_APPLY_V
@@ -284,6 +288,7 @@ instance Outputable BCInstr where
    ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
    ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
    ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+   ppr (PUSH_ADDR nm)        = text "PUSH_ADDR" <+> ppr nm
    ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
    ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
    ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"
@@ -397,6 +402,7 @@ bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
 bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
 bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
 bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
+bciStackUse PUSH_ADDR{}           = 1
 bciStackUse PUSH_APPLY_N{}        = 1
 bciStackUse PUSH_APPLY_V{}        = 1
 bciStackUse PUSH_APPLY_F{}        = 1


=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -8,10 +8,7 @@
 
 -- | Bytecode assembler and linker
 module GHC.ByteCode.Linker
-  ( ClosureEnv
-  , emptyClosureEnv
-  , extendClosureEnv
-  , linkBCO
+  ( linkBCO
   , lookupStaticPtr
   , lookupIE
   , nameToCLabel
@@ -35,6 +32,8 @@ import GHC.Unit.Types
 import GHC.Data.FastString
 import GHC.Data.SizedSeq
 
+import GHC.Linker.Types
+
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Outputable
@@ -53,45 +52,34 @@ import GHC.Exts
   Linking interpretables into something we can run
 -}
 
-type ClosureEnv = NameEnv (Name, ForeignHValue)
-
-emptyClosureEnv :: ClosureEnv
-emptyClosureEnv = emptyNameEnv
-
-extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
-extendClosureEnv cl_env pairs
-  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
-
-{-
-  Linking interpretables into something we can run
--}
-
 linkBCO
   :: Interp
-  -> ItblEnv
-  -> ClosureEnv
+  -> LinkerEnv
   -> NameEnv Int
   -> RemoteRef BreakArray
   -> UnlinkedBCO
   -> IO ResolvedBCO
-linkBCO interp ie ce bco_ix breakarray
+linkBCO interp le bco_ix breakarray
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   -- fromIntegral Word -> Word64 should be a no op if Word is Word64
   -- otherwise it will result in a cast to longlong on 32bit systems.
-  lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)
-  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)
+  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)
+  ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0)
   return (ResolvedBCO isLittleEndian arity insns bitmap
               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
               (addListToSS emptySS ptrs))
 
-lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
-lookupLiteral interp ie ptr = case ptr of
+lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
+lookupLiteral interp le ptr = case ptr of
   BCONPtrWord lit -> return lit
   BCONPtrLbl  sym -> do
     Ptr a# <- lookupStaticPtr interp sym
     return (W# (int2Word# (addr2Int# a#)))
   BCONPtrItbl nm -> do
-    Ptr a# <- lookupIE interp ie nm
+    Ptr a# <- lookupIE interp (itbl_env le) nm
+    return (W# (int2Word# (addr2Int# a#)))
+  BCONPtrAddr nm -> do
+    Ptr a# <- lookupAddr interp (addr_env le) nm
     return (W# (int2Word# (addr2Int# a#)))
   BCONPtrStr _ ->
     -- should be eliminated during assembleBCOs
@@ -124,6 +112,20 @@ lookupIE interp ie con_nm =
                                       (unpackFS sym_to_find1 ++ " or " ++
                                        unpackFS sym_to_find2)
 
+-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
+lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
+lookupAddr interp ae addr_nm = do
+  case lookupNameEnv ae addr_nm of
+    Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
+    Nothing -> do -- try looking up in the object files.
+      let sym_to_find = nameToCLabel addr_nm "bytes"
+                          -- see Note [Bytes label] in GHC.Cmm.CLabel
+      m <- lookupSymbol interp sym_to_find
+      case m of
+        Just ptr -> return ptr
+        Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
+                     (unpackFS sym_to_find)
+
 lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
 lookupPrimOp interp primop = do
   let sym_to_find = primopToCLabel primop "closure"
@@ -134,18 +136,17 @@ lookupPrimOp interp primop = do
 
 resolvePtr
   :: Interp
-  -> ItblEnv
-  -> ClosureEnv
+  -> LinkerEnv
   -> NameEnv Int
   -> RemoteRef BreakArray
   -> BCOPtr
   -> IO ResolvedBCOPtr
-resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
+resolvePtr interp le bco_ix breakarray ptr = case ptr of
   BCOPtrName nm
     | Just ix <- lookupNameEnv bco_ix nm
     -> return (ResolvedBCORef ix) -- ref to another BCO in this group
 
-    | Just (_, rhv) <- lookupNameEnv ce nm
+    | Just (_, rhv) <- lookupNameEnv (closure_env le) nm
     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
 
     | otherwise
@@ -161,7 +162,7 @@ resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
     -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
 
   BCOPtrBCO bco
-    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco
+    -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco
 
   BCOPtrBreakArray
     -> return (ResolvedBCOPtrBreakArray breakarray)


=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -14,6 +14,7 @@ module GHC.ByteCode.Types
   , ByteOff(..), WordOff(..)
   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
   , ItblEnv, ItblPtr(..)
+  , AddrEnv, AddrPtr(..)
   , CgBreakInfo(..)
   , ModBreaks (..), BreakIndex, emptyModBreaks
   , CCostCentre
@@ -51,7 +52,7 @@ data CompiledByteCode = CompiledByteCode
   { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
   , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
   , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
-  , bc_strs   :: [RemotePtr ()] -- malloc'd strings
+  , bc_strs   :: AddrEnv        -- malloc'd top-level strings
   , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
                                  -- creating breakpoints, for some reason)
   }
@@ -69,7 +70,7 @@ seqCompiledByteCode CompiledByteCode{..} =
   rnf bc_bcos `seq`
   seqEltsNameEnv rnf bc_itbls `seq`
   rnf bc_ffis `seq`
-  rnf bc_strs `seq`
+  seqEltsNameEnv rnf bc_strs `seq`
   rnf (fmap seqModBreaks bc_breaks)
 
 newtype ByteOff = ByteOff Int
@@ -131,11 +132,14 @@ voidPrimCallInfo :: NativeCallInfo
 voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0
 
 type ItblEnv = NameEnv (Name, ItblPtr)
+type AddrEnv = NameEnv (Name, AddrPtr)
         -- We need the Name in the range so we know which
         -- elements to filter out when unloading a module
 
 newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)
   deriving (Show, NFData)
+newtype AddrPtr = AddrPtr (RemotePtr ())
+  deriving (NFData)
 
 data UnlinkedBCO
    = UnlinkedBCO {
@@ -166,6 +170,12 @@ data BCONPtr
   = BCONPtrWord  {-# UNPACK #-} !Word
   | BCONPtrLbl   !FastString
   | BCONPtrItbl  !Name
+  -- | A reference to a top-level string literal; see
+  -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
+  | BCONPtrAddr  !Name
+  -- | Only used internally in the assembler in an intermediate representation;
+  -- should never appear in a fully-assembled UnlinkedBCO.
+  -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.
   | BCONPtrStr   !ByteString
 
 instance NFData BCONPtr where


=====================================
compiler/GHC/Core.hs
=====================================
@@ -366,68 +366,32 @@ a Coercion, (sym c).
 
 Note [Core letrec invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The right hand sides of all top-level and recursive @let at s
-/must/ be of lifted type (see "Type#type_classification" for
-the meaning of /lifted/ vs. /unlifted/).
+The Core letrec invariant:
 
-There is one exception to this rule, top-level @let at s are
-allowed to bind primitive string literals: see
-Note [Core top-level string literals].
+    The right hand sides of all
+      /top-level/ or /recursive/
+    bindings must be of lifted type
 
-Note [Core top-level string literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As an exception to the usual rule that top-level binders must be lifted,
-we allow binding primitive string literals (of type Addr#) of type Addr# at the
-top level. This allows us to share string literals earlier in the pipeline and
-crucially allows other optimizations in the Core2Core pipeline to fire.
-Consider,
+    There is one exception to this rule, top-level @let at s are
+    allowed to bind primitive string literals: see
+    Note [Core top-level string literals].
 
-  f n = let a::Addr# = "foo"#
-        in \x -> blah
+See "Type#type_classification" in GHC.Core.Type
+for the meaning of "lifted" vs. "unlifted").
 
-In order to be able to inline `f`, we would like to float `a` to the top.
-Another option would be to inline `a`, but that would lead to duplicating string
-literals, which we want to avoid. See #8472.
-
-The solution is simply to allow top-level unlifted binders. We can't allow
-arbitrary unlifted expression at the top-level though, unlifted binders cannot
-be thunks, so we just allow string literals.
-
-We allow the top-level primitive string literals to be wrapped in Ticks
-in the same way they can be wrapped when nested in an expression.
-CoreToSTG currently discards Ticks around top-level primitive string literals.
-See #14779.
-
-Also see Note [Compilation plan for top-level string literals].
-
-Note [Compilation plan for top-level string literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a summary on how top-level string literals are handled by various
-parts of the compilation pipeline.
-
-* In the source language, there is no way to bind a primitive string literal
-  at the top level.
-
-* In Core, we have a special rule that permits top-level Addr# bindings. See
-  Note [Core top-level string literals]. Core-to-core passes may introduce
-  new top-level string literals.
-
-* In STG, top-level string literals are explicitly represented in the syntax
-  tree.
-
-* A top-level string literal may end up exported from a module. In this case,
-  in the object file, the content of the exported literal is given a label with
-  the _bytes suffix.
+For the non-top-level, non-recursive case see Note [Core let-can-float invariant].
 
 Note [Core let-can-float invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The let-can-float invariant:
 
-    The right hand side of a non-recursive 'Let'
-    /may/ be of unlifted type, but only if
+    The right hand side of a /non-top-level/, /non-recursive/ binding
+    may be of unlifted type, but only if
     the expression is ok-for-speculation
     or the 'Let' is for a join point.
 
+    (For top-level or recursive lets see Note [Core letrec invariant].)
+
 This means that the let can be floated around
 without difficulty. For example, this is OK:
 
@@ -466,6 +430,53 @@ we need to allow lots of things in the arguments of a call.
 
 TL;DR: we relaxed the let/app invariant to become the let-can-float invariant.
 
+Note [Core top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As an exception to the usual rule that top-level binders must be lifted,
+we allow binding primitive string literals (of type Addr#) of type Addr# at the
+top level. This allows us to share string literals earlier in the pipeline and
+crucially allows other optimizations in the Core2Core pipeline to fire.
+Consider,
+
+  f n = let a::Addr# = "foo"#
+        in \x -> blah
+
+In order to be able to inline `f`, we would like to float `a` to the top.
+Another option would be to inline `a`, but that would lead to duplicating string
+literals, which we want to avoid. See #8472.
+
+The solution is simply to allow top-level unlifted binders. We can't allow
+arbitrary unlifted expression at the top-level though, unlifted binders cannot
+be thunks, so we just allow string literals.
+
+We allow the top-level primitive string literals to be wrapped in Ticks
+in the same way they can be wrapped when nested in an expression.
+CoreToSTG currently discards Ticks around top-level primitive string literals.
+See #14779.
+
+Also see Note [Compilation plan for top-level string literals].
+
+Note [Compilation plan for top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is a summary on how top-level string literals are handled by various
+parts of the compilation pipeline.
+
+* In the source language, there is no way to bind a primitive string literal
+  at the top level.
+
+* In Core, we have a special rule that permits top-level Addr# bindings. See
+  Note [Core top-level string literals]. Core-to-core passes may introduce
+  new top-level string literals.
+
+  See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString
+
+* In STG, top-level string literals are explicitly represented in the syntax
+  tree.
+
+* A top-level string literal may end up exported from a module. In this case,
+  in the object file, the content of the exported literal is given a label with
+  the _bytes suffix.
+
 Note [NON-BOTTOM-DICTS invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is a global invariant (not checkable by Lint) that


=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Core
 import GHC.Core.Make      ( mkLitRubbish )
 import GHC.Core.Unify     ( tcMatchTy )
 import GHC.Core.Rules
-import GHC.Core.Utils     ( exprIsTrivial
+import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable
                           , mkCast, exprType
                           , stripTicksTop, mkInScopeSetBndrs )
 import GHC.Core.FVs
@@ -1500,7 +1500,10 @@ specBind top_lvl env (NonRec fn rhs) do_body
                          = [mkDB $ NonRec b r | (b,r) <- pairs]
                            ++ fromOL dump_dbs
 
-       ; if float_all then
+             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)
+             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]
+
+       ; if float_all && can_float_this_one then
              -- Rather than discard the calls mentioning the bound variables
              -- we float this (dictionary) binding along with the others
               return ([], body', all_free_uds `snocDictBinds` final_binds)
@@ -1861,6 +1864,28 @@ even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to
 the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to
 preserve laziness.
 
+Note [Care with unlifted bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#22998)
+    f x = let x::ByteArray# = <some literal>
+              n::Natural    = NB x
+          in wombat @192827 (n |> co)
+where
+  co :: Natural ~ KnownNat 192827
+  wombat :: forall (n:Nat). KnownNat n => blah
+
+Left to itself, the specialiser would float the bindings for `x` and `n` to top
+level, so we can specialise `wombat`.  But we can't have a top-level ByteArray#
+(see Note [Core letrec invariant] in GHC.Core).  Boo.
+
+This is pretty exotic, so we take a simple way out: in specBind (the NonRec
+case) do not float the binding itself unless it satisfies exprIsTopLevelBindable.
+This is conservative: maybe the RHS of `x` has a free var that would stop it
+floating to top level anyway; but that is hard to spot (since we don't know what
+the non-top-level in-scope binders are) and rare (since the binding must satisfy
+Note [Core let-can-float invariant] in GHC.Core).
+
+
 Note [Specialising Calls]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have a function with a complicated type:


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -141,8 +141,11 @@ getLoaderState interp = readMVar (loader_state (interpLoader interp))
 
 emptyLoaderState :: LoaderState
 emptyLoaderState = LoaderState
-   { closure_env = emptyNameEnv
-   , itbl_env    = emptyNameEnv
+   { linker_env = LinkerEnv
+     { closure_env = emptyNameEnv
+     , itbl_env    = emptyNameEnv
+     , addr_env    = emptyNameEnv
+     }
    , pkgs_loaded = init_pkgs
    , bcos_loaded = emptyModuleEnv
    , objs_loaded = emptyModuleEnv
@@ -157,17 +160,16 @@ emptyLoaderState = LoaderState
 
 extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
 extendLoadedEnv interp new_bindings =
-  modifyLoaderState_ interp $ \pls at LoaderState{..} -> do
-    let new_ce = extendClosureEnv closure_env new_bindings
-    return $! pls{ closure_env = new_ce }
+  modifyLoaderState_ interp $ \pls -> do
+    return $! modifyClosureEnv pls $ \ce ->
+      extendClosureEnv ce new_bindings
     -- strictness is important for not retaining old copies of the pls
 
 deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
 deleteFromLoadedEnv interp to_remove =
   modifyLoaderState_ interp $ \pls -> do
-    let ce = closure_env pls
-    let new_ce = delListFromNameEnv ce to_remove
-    return pls{ closure_env = new_ce }
+    return $ modifyClosureEnv pls $ \ce ->
+      delListFromNameEnv ce to_remove
 
 -- | Load the module containing the given Name and get its associated 'HValue'.
 --
@@ -185,7 +187,7 @@ loadName interp hsc_env name = do
            then throwGhcExceptionIO (ProgramError "")
            else return (pls', links, pkgs)
 
-    case lookupNameEnv (closure_env pls) name of
+    case lookupNameEnv (closure_env (linker_env pls)) name of
       Just (_,aa) -> return (pls,(aa, links, pkgs))
       Nothing     -> assertPpr (isExternalName name) (ppr name) $
                      do let sym_to_find = nameToCLabel name "closure"
@@ -247,10 +249,7 @@ withExtendedLoadedEnv interp new_env action
         -- package), so the reset action only removes the names we
         -- added earlier.
           reset_old_env = liftIO $
-            modifyLoaderState_ interp $ \pls ->
-                let cur = closure_env pls
-                    new = delListFromNameEnv cur (map fst new_env)
-                in return pls{ closure_env = new }
+            deleteFromLoadedEnv interp (map fst new_env)
 
 
 -- | Display the loader state.
@@ -594,13 +593,11 @@ loadExpr interp hsc_env span root_ul_bco = do
       then throwGhcExceptionIO (ProgramError "")
       else do
         -- Load the expression itself
-        let ie = itbl_env pls
-            ce = closure_env pls
-
         -- Load the necessary packages and linkables
-        let nobreakarray = error "no break array"
+        let le = linker_env pls
+            nobreakarray = error "no break array"
             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
-        resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco
+        resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco
         bco_opts <- initBCOOpts (hsc_dflags hsc_env)
         [root_hvref] <- createBCOs interp bco_opts [resolved]
         fhv <- mkFinalizedHValue interp root_hvref
@@ -944,15 +941,16 @@ loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
         then throwGhcExceptionIO (ProgramError "")
         else do
           -- Link the expression itself
-          let ie = plusNameEnv (itbl_env pls) bc_itbls
-              ce = closure_env pls
+          let le  = linker_env pls
+              le2 = le { itbl_env = plusNameEnv (itbl_env le) bc_itbls
+                       , addr_env = plusNameEnv (addr_env le) bc_strs }
 
           -- Link the necessary packages and linkables
           bco_opts <- initBCOOpts (hsc_dflags hsc_env)
-          new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]
+          new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc]
           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
-          let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
-                         , itbl_env    = ie }
+          let ce2  = extendClosureEnv (closure_env le2) nms_fhvs
+              !pls2 = pls { linker_env = le2 { closure_env = ce2 } }
           return (pls2, (nms_fhvs, links_needed, units_needed))
   where
     free_names = uniqDSetToList $
@@ -1170,11 +1168,12 @@ dynLinkBCOs bco_opts interp pls bcos = do
             cbcs      = concatMap byteCodeOfObject unlinkeds
 
 
-            ies        = map bc_itbls cbcs
-            gce       = closure_env pls
-            final_ie  = foldr plusNameEnv (itbl_env pls) ies
+            le1 = linker_env pls
+            ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs)
+            ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)
+            le2 = le1 { itbl_env = ie2, addr_env = ae2 }
 
-        names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs
+        names_and_refs <- linkSomeBCOs bco_opts interp le2 cbcs
 
         -- We only want to add the external ones to the ClosureEnv
         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -1184,21 +1183,20 @@ dynLinkBCOs bco_opts interp pls bcos = do
         -- Wrap finalizers on the ones we want to keep
         new_binds <- makeForeignNamedHValueRefs interp to_add
 
-        return pls1 { closure_env = extendClosureEnv gce new_binds,
-                      itbl_env    = final_ie }
+        let ce2 = extendClosureEnv (closure_env le2) new_binds
+        return $! pls1 { linker_env = le2 { closure_env = ce2 } }
 
 -- Link a bunch of BCOs and return references to their values
 linkSomeBCOs :: BCOOpts
              -> Interp
-             -> ItblEnv
-             -> ClosureEnv
+             -> LinkerEnv
              -> [CompiledByteCode]
              -> IO [(Name,HValueRef)]
                         -- The returned HValueRefs are associated 1-1 with
                         -- the incoming unlinked BCOs.  Each gives the
                         -- value of the corresponding unlinked BCO
 
-linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []
+linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods []
  where
   fun CompiledByteCode{..} inner accum =
     case bc_breaks of
@@ -1211,7 +1209,7 @@ linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []
     let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
         names = map (unlinkedBCOName . snd) flat
         bco_ix = mkNameEnv (zip names [0..])
-    resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco
+    resolved <- sequence [ linkBCO interp le bco_ix breakarray bco
                          | (breakarray, bco) <- flat ]
     hvrefs <- createBCOs interp bco_opts resolved
     return (zip names hvrefs)
@@ -1301,15 +1299,11 @@ unload_wkr interp keep_linkables pls at LoaderState{..}  = do
   let -- Note that we want to remove all *local*
       -- (i.e. non-isExternal) names too (these are the
       -- temporary bindings from the command line).
-      keep_name :: (Name, a) -> Bool
-      keep_name (n,_) = isExternalName n &&
-                        nameModule n `elemModuleEnv` remaining_bcos_loaded
-
-      itbl_env'     = filterNameEnv keep_name itbl_env
-      closure_env'  = filterNameEnv keep_name closure_env
+      keep_name :: Name -> Bool
+      keep_name n = isExternalName n &&
+                    nameModule n `elemModuleEnv` remaining_bcos_loaded
 
-      !new_pls = pls { itbl_env = itbl_env',
-                       closure_env = closure_env',
+      !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
                        bcos_loaded = remaining_bcos_loaded,
                        objs_loaded = remaining_objs_loaded }
 


=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -10,6 +10,12 @@ module GHC.Linker.Types
    ( Loader (..)
    , LoaderState (..)
    , uninitializedLoader
+   , modifyClosureEnv
+   , LinkerEnv(..)
+   , filterLinkerEnv
+   , ClosureEnv
+   , emptyClosureEnv
+   , extendClosureEnv
    , Linkable(..)
    , LinkableSet
    , mkLinkableSet
@@ -32,12 +38,12 @@ where
 
 import GHC.Prelude
 import GHC.Unit                ( UnitId, Module )
-import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode )
+import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode )
 import GHC.Fingerprint.Type    ( Fingerprint )
 import GHCi.RemoteTypes        ( ForeignHValue )
 
 import GHC.Types.Var           ( Id )
-import GHC.Types.Name.Env      ( NameEnv )
+import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
 import GHC.Types.Name          ( Name )
 
 import GHC.Utils.Outputable
@@ -67,23 +73,16 @@ serves to ensure mutual exclusion between multiple loaded copies of the GHC
 library. The Maybe may be Nothing to indicate that the linker has not yet been
 initialised.
 
-The LoaderState maps Names to actual closures (for interpreted code only), for
+The LinkerEnv maps Names to actual closures (for interpreted code only), for
 use during linking.
 -}
 
 newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }
 
 data LoaderState = LoaderState
-    { closure_env :: ClosureEnv
+    { linker_env :: !LinkerEnv
         -- ^ Current global mapping from Names to their true values
 
-    , itbl_env    :: !ItblEnv
-        -- ^ The current global mapping from RdrNames of DataCons to
-        -- info table addresses.
-        -- When a new Unlinked is linked into the running image, or an existing
-        -- module in the image is replaced, the itbl_env must be updated
-        -- appropriately.
-
     , bcos_loaded :: !LinkableSet
         -- ^ The currently loaded interpreted modules (home package)
 
@@ -102,7 +101,44 @@ data LoaderState = LoaderState
 uninitializedLoader :: IO Loader
 uninitializedLoader = Loader <$> newMVar Nothing
 
+modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState
+modifyClosureEnv pls f =
+    let le = linker_env pls
+        ce = closure_env le
+    in pls { linker_env = le { closure_env = f ce } }
+
+data LinkerEnv = LinkerEnv
+  { closure_env :: !ClosureEnv
+      -- ^ Current global mapping from closure Names to their true values
+
+  , itbl_env    :: !ItblEnv
+      -- ^ The current global mapping from RdrNames of DataCons to
+      -- info table addresses.
+      -- When a new Unlinked is linked into the running image, or an existing
+      -- module in the image is replaced, the itbl_env must be updated
+      -- appropriately.
+
+  , addr_env    :: !AddrEnv
+      -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
+      -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
+  }
+
+filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
+filterLinkerEnv f le = LinkerEnv
+  { closure_env = filterNameEnv (f . fst) (closure_env le)
+  , itbl_env    = filterNameEnv (f . fst) (itbl_env le)
+  , addr_env    = filterNameEnv (f . fst) (addr_env le)
+  }
+
 type ClosureEnv = NameEnv (Name, ForeignHValue)
+
+emptyClosureEnv :: ClosureEnv
+emptyClosureEnv = emptyNameEnv
+
+extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
+extendClosureEnv cl_env pairs
+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+
 type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
 
 data LoadedPkgInfo


=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Types.Literal
 import GHC.Builtin.PrimOps
 import GHC.Builtin.PrimOps.Ids (primOpId)
 import GHC.Core.Type
+import GHC.Core.TyCo.Compare (eqType)
 import GHC.Types.RepType
 import GHC.Core.DataCon
 import GHC.Core.TyCon
@@ -64,7 +65,7 @@ import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
 import GHC.Data.Bitmap
 import GHC.Data.OrdList
 import GHC.Data.Maybe
-import GHC.Types.Var.Env
+import GHC.Types.Name.Env (mkNameEnv)
 import GHC.Types.Tickish
 
 import Data.List ( genericReplicate, genericLength, intersperse
@@ -105,7 +106,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
                 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
                 (const ()) $ do
         -- Split top-level binds into strings and others.
-        -- See Note [generating code for top-level string literal bindings].
+        -- See Note [Generating code for top-level string literal bindings].
         let (strings, lifted_binds) = partitionEithers $ do  -- list monad
                 bnd <- binds
                 case bnd of
@@ -116,7 +117,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
         stringPtrs <- allocateTopStrings interp strings
 
         (BcM_State{..}, proto_bcos) <-
-           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
+           runBc hsc_env this_mod mb_modBreaks $ do
              let flattened_binds = concatMap flattenBind (reverse lifted_binds)
              mapM schemeTopBind flattened_binds
 
@@ -127,7 +128,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
            "Proto-BCOs" FormatByteCode
            (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
-        cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs)
+        cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
           (case modBreaks of
              Nothing -> Nothing
              Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
@@ -147,28 +148,49 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
         interp  = hscInterp hsc_env
         profile = targetProfile dflags
 
+-- | see Note [Generating code for top-level string literal bindings]
 allocateTopStrings
   :: Interp
   -> [(Id, ByteString)]
-  -> IO [(Var, RemotePtr ())]
+  -> IO AddrEnv
 allocateTopStrings interp topStrings = do
   let !(bndrs, strings) = unzip topStrings
   ptrs <- interpCmd interp $ MallocStrings strings
-  return $ zip bndrs ptrs
-
-{-
-Note [generating code for top-level string literal bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a summary on how the byte code generator deals with top-level string
-literals:
-
-1. Top-level string literal bindings are separated from the rest of the module.
-
-2. The strings are allocated via interpCmd, in allocateTopStrings
-
-3. The mapping from binders to allocated strings (topStrings) are maintained in
-   BcM and used when generating code for variable references.
--}
+  return $ mkNameEnv (zipWith mk_entry bndrs ptrs)
+  where
+    mk_entry bndr ptr = let nm = getName bndr
+                        in (nm, (nm, AddrPtr ptr))
+
+{- Note [Generating code for top-level string literal bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in Note [Compilation plan for top-level string literals]
+in GHC.Core, the core-to-core optimizer can introduce top-level Addr#
+bindings to represent string literals. The creates two challenges for
+the bytecode compiler: (1) compiling the bindings themselves, and
+(2) compiling references to such bindings. Here is a summary on how
+we deal with them:
+
+  1. Top-level string literal bindings are separated from the rest of
+     the module. Memory for them is allocated immediately, via
+     interpCmd, in allocateTopStrings, and the resulting AddrEnv is
+     recorded in the bc_strs field of the CompiledByteCode result.
+
+  2. When we encounter a reference to a top-level string literal, we
+     generate a PUSH_ADDR pseudo-instruction, which is assembled to
+     a PUSH_UBX instruction with a BCONPtrAddr argument.
+
+  3. The loader accumulates string literal bindings from loaded
+     bytecode in the addr_env field of the LinkerEnv.
+
+  4. The BCO linker resolves BCONPtrAddr references by searching both
+     the addr_env (to find literals defined in bytecode) and the native
+     symbol table (to find literals defined in native code).
+
+This strategy works alright, but it does have one significant problem:
+we never free the memory that we allocate for the top-level strings.
+In theory, we could explicitly free it when BCOs are unloaded, but
+this comes with its own complications; see #22400 for why. For now,
+we just accept the leak, but it would nice to find something better. -}
 
 -- -----------------------------------------------------------------------------
 -- Compilation schema for the bytecode generator
@@ -1774,26 +1796,25 @@ pushAtom d p (StgVarArg var)
         -- slots on to the top of the stack.
 
    | otherwise  -- var must be a global variable
-   = do topStrings <- getTopStrings
-        platform <- targetPlatform <$> getDynFlags
-        case lookupVarEnv topStrings var of
-            Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
-              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
-            Nothing
-              -- PUSH_G doesn't tag constructors. So we use PACK here
-              -- if we are dealing with nullary constructor.
-              | Just con <- isDataConWorkId_maybe var
-              -> do
-                  massert (sz == wordSize platform)
-                  massert (isNullaryRepDataCon con)
-                  return (unitOL (PACK con 0), sz)
-              | otherwise
-              -> do
-                  let
-                  massert (sz == wordSize platform)
-                  return (unitOL (PUSH_G (getName var)), sz)
-              where
-                !sz = idSizeCon platform var
+   = do platform <- targetPlatform <$> getDynFlags
+        let !szb = idSizeCon platform var
+        massert (szb == wordSize platform)
+
+        -- PUSH_G doesn't tag constructors. So we use PACK here
+        -- if we are dealing with nullary constructor.
+        case isDataConWorkId_maybe var of
+          Just con -> do
+            massert (isNullaryRepDataCon con)
+            return (unitOL (PACK con 0), szb)
+
+          Nothing
+            -- see Note [Generating code for top-level string literal bindings]
+            | isUnliftedType (idType var) -> do
+              massert (idType var `eqType` addrPrimTy)
+              return (unitOL (PUSH_ADDR (getName var)), szb)
+
+            | otherwise -> do
+              return (unitOL (PUSH_G (getName var)), szb)
 
 
 pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
@@ -2162,8 +2183,6 @@ data BcM_State
                                          -- Should be free()d when it is GCd
         , modBreaks   :: Maybe ModBreaks -- info about breakpoints
         , breakInfo   :: IntMap CgBreakInfo
-        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
-          -- See Note [generating code for top-level string literal bindings].
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
@@ -2174,11 +2193,10 @@ ioToBc io = BcM $ \st -> do
   return (st, x)
 
 runBc :: HscEnv -> Module -> Maybe ModBreaks
-      -> IdEnv (RemotePtr ())
       -> BcM r
       -> IO (BcM_State, r)
-runBc hsc_env this_mod modBreaks topStrings (BcM m)
-   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)
+runBc hsc_env this_mod modBreaks (BcM m)
+   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -2247,8 +2265,5 @@ newBreakInfo ix info = BcM $ \st ->
 getCurrentModule :: BcM Module
 getCurrentModule = BcM $ \st -> return (st, thisModule st)
 
-getTopStrings :: BcM (IdEnv (RemotePtr ()))
-getTopStrings = BcM $ \st -> return (st, topStrings st)
-
 tickFS :: FastString
 tickFS = fsLit "ticked"


=====================================
testsuite/tests/bytecode/T22376/A.hs
=====================================
@@ -0,0 +1,6 @@
+module A where
+import B
+
+foo :: String
+foo = f "bc"
+{-# NOINLINE foo #-}


=====================================
testsuite/tests/bytecode/T22376/B.hs
=====================================
@@ -0,0 +1,4 @@
+module B where
+
+f :: String -> String
+f = ("a" ++)


=====================================
testsuite/tests/bytecode/T22376/T22376.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH.Syntax (lift)
+import A
+
+main :: IO ()
+main = putStrLn $(lift foo)


=====================================
testsuite/tests/bytecode/T22376/T22376.stdout
=====================================
@@ -0,0 +1 @@
+abc


=====================================
testsuite/tests/bytecode/T22376/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T22376', [req_interp, extra_files(['A.hs', 'B.hs'])], multimod_compile_and_run,
+     ['T22376', '-O1 -fwrite-if-simplified-core -fbyte-code-and-object-code -fprefer-byte-code'])


=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -294,26 +294,22 @@ test('T20803b',
 
 test('test-echo-in-turn',
      [extra_files(['echo-plugin/']),
-      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-turn TOP={top}'),
-      when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))],
+      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-turn TOP={top}')],
      makefile_test, [])
 
 test('test-echo-in-line',
      [extra_files(['echo-plugin/']),
-      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-line TOP={top}'),
-      when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))],
+      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-line TOP={top}')],
      makefile_test, [])
 
 test('test-echo-in-turn-many-args',
      [extra_files(['echo-plugin/']),
-      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-turn-many-args TOP={top}'),
-      when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))],
+      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-turn-many-args TOP={top}')],
      makefile_test, [])
 
 test('test-echo-in-line-many-args',
      [extra_files(['echo-plugin/']),
-      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-line-many-args TOP={top}'),
-      when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))],
+      pre_cmd('$MAKE -s --no-print-directory -C echo-plugin package.test-echo-in-line-many-args TOP={top}')],
      makefile_test, [])
 
 test('plugins-external',


=====================================
testsuite/tests/plugins/echo-plugin/Echo.hs
=====================================
@@ -5,6 +5,7 @@ import GHC.Tc.Plugin
 import GHC.Tc.Utils.Monad
 import qualified GHC.Tc.Utils.Monad as Utils
 import GHC.Types.Unique.FM ( emptyUFM )
+import System.IO
 
 plugin :: Plugin
 plugin = mkPureOptTcPlugin optCallCount
@@ -27,6 +28,10 @@ optCallCount opts = Just $
             n <- unsafeTcPluginTcM $ readMutVar c
             let msg = if null opts then "" else mconcat opts
             tcPluginIO . putStrLn $ "Echo TcPlugin " ++ msg ++ "#" ++ show n
+
+            -- TODO: Remove #20791
+            tcPluginIO $ hFlush stdout
+
             unsafeTcPluginTcM $ writeMutVar c (n + 1)
             return $ TcPluginOk [] []
 


=====================================
testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
=====================================
@@ -10,6 +10,7 @@ import GHC.Hs.Lit
 import GHC.Driver.Hooks
 import GHC.Tc.Utils.Monad
 import GHC.Parser.Annotation
+import System.IO
 
 plugin :: Plugin
 plugin = defaultPlugin { driverPlugin = hooksP }
@@ -28,6 +29,10 @@ hooksP opts hsc_env = do
 fakeRunMeta :: [CommandLineOption] -> MetaHook TcM
 fakeRunMeta opts (MetaE r) _ = do
   liftIO . putStrLn $ "Options = " ++ show opts
+
+  -- TODO: Remove #20791
+  liftIO $ hFlush stdout
+
   pure $ r zero
 
   where zero :: LHsExpr GhcPs


=====================================
testsuite/tests/simplCore/should_run/T22998.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+module Main where
+
+import Data.Proxy (Proxy(Proxy))
+import GHC.TypeLits (natVal)
+
+main :: IO ()
+main = print x
+  where
+    x = natVal @18446744073709551616 Proxy + natVal @18446744073709551616 Proxy


=====================================
testsuite/tests/simplCore/should_run/T22998.stdout
=====================================
@@ -0,0 +1 @@
+36893488147419103232


=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -107,3 +107,4 @@ test('T21229', normal, compile_and_run, ['-O'])
 test('T21575', normal, compile_and_run, ['-O'])
 test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
 test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836
+test('T22998', normal, compile_and_run, ['-O0 -fspecialise -dcore-lint'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46372a1a171f2c7325c7c27eb447c9b8eea30f4c...47f549b7027a40c9ddeb7d16620e629be2071e79

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46372a1a171f2c7325c7c27eb447c9b8eea30f4c...47f549b7027a40c9ddeb7d16620e629be2071e79
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/20230221/d7c21c11/attachment-0001.html>


More information about the ghc-commits mailing list