[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