[Git][ghc/ghc][master] Add support for textual output of bytecode file content
by Marge Bot (＠marge-bot) 15 Aug '26
by Marge Bot (＠marge-bot) 15 Aug '26
15 Aug '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
12f64118 by Wolfgang Jeltsch at 2026-08-15T06:31:12-04:00
Add support for textual output of bytecode file content
- - - - -
16 changed files:
- + changelog.d/show-byte-code
- compiler/GHC/ByteCode/Serialize.hs
- + compiler/GHC/ByteCode/Show.hs
- compiler/ghc.cabal.in
- docs/users_guide/using.rst
- ghc/GHC/Driver/Session/Mode.hs
- ghc/Main.hs
- + testsuite/tests/show-bytecode/Example.hs
- + testsuite/tests/show-bytecode/Makefile
- + testsuite/tests/show-bytecode/all.T
- + testsuite/tests/show-bytecode/normalize
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs
- + testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs
Changes:
=====================================
changelog.d/show-byte-code
=====================================
@@ -0,0 +1,8 @@
+section: bytecode
+synopsis: Add support for textual output of bytecode file content
+issues: #26909
+mrs: !16386
+description: {
+ There is now an option `--show-byte-code` for outputting relevant
+ content of a bytecode file in textual form.
+}
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -6,7 +6,7 @@
{- | This module implements the serialization of bytecode objects to and from disk.
-}
module GHC.ByteCode.Serialize
- ( writeBinByteCode, readBinByteCode
+ ( writeBinByteCode, readBinByteCode, readOnDiskModuleByteCode
, ModuleByteCode(..)
, BytecodeLibX(..)
, BytecodeLib
=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -0,0 +1,577 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module implements the output of textual information about the contents
+-- of bytecode files. It is the backbone of the @--show-byte-code@ option.
+module GHC.ByteCode.Show (showByteCode) where
+
+-- The output generated by 'showByteCode' shall follow some general guidelines.
+-- See Note [Guidelines for the output of @--show-byte-code@] for details.
+
+-- Prelude
+import GHC.Prelude
+
+-- Bytecode
+import GHC.ByteCode.Types
+ (
+ FFIInfo (..),
+ BCONPtr (..),
+ BCOPtr (..),
+ UnlinkedBCO (..),
+ ByteCodeHpcInfo (..),
+ CompiledByteCode (..)
+ )
+import GHC.ByteCode.Breakpoints
+ (
+ InternalBreakpointId (..),
+ InternalBreakLoc (..),
+ CgBreakInfo (..),
+ InternalModBreaks (..)
+ )
+import GHC.ByteCode.Binary (OnDiskModuleByteCode (..))
+import GHC.ByteCode.Serialize (readOnDiskModuleByteCode)
+
+-- GHC apart from bytecode
+import GHC.Data.Strict qualified as Strict (Maybe, maybe)
+import GHC.Data.FastString (unpackFS)
+import GHC.Data.FlatBag (FlatBag, elemsFlatBag)
+import GHC.Fingerprint (Fingerprint)
+import GHC.Types.SrcLoc (noSrcSpan)
+import GHC.Types.Name (Name)
+import GHC.Types.Name.Occurrence (OccName, HasOccName, occName, parenSymOcc)
+import GHC.Types.Tickish (BreakTickIndex, BreakpointId (..))
+import GHC.Types.SptEntry (SptEntry (..))
+import GHC.Types.Error (MessageClass (MCDump))
+import GHC.Utils.Panic.Plain (assert)
+import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString, utf8DecodeByteString)
+import GHC.Utils.Logger (Logger, logMsg)
+import GHC.Utils.Binary (BinSrcSpan (..))
+import GHC.Utils.Outputable
+ (
+ Outputable,
+ defaultDumpStyle,
+ SDoc,
+ text,
+ (<>),
+ (<+>),
+ hsep,
+ quotes,
+ vcat,
+ hang,
+ ppr,
+ withPprStyle
+ )
+import GHC.Unit.Types (Module, moduleName)
+import GHC.Iface.Type (IfaceType, IfaceTvBndr, IfaceIdBndr)
+import GHC.HsToCore.Breakpoints (ModBreaks (..))
+import GHC.Driver.Env.Types (HscEnv)
+import GHCi.FFI (FFIType)
+import GHCi.Message (ConInfoTable (..))
+import Language.Haskell.Syntax.Module.Name (moduleNameString)
+
+-- Basic things
+import Control.Arrow ((>>>))
+import Data.Bool (bool)
+import Data.List (zipWith4)
+import Data.ByteString (ByteString)
+import Data.ByteString.Short (ShortByteString)
+import Data.IntMap (IntMap)
+import Data.IntMap qualified as IntMap (toList)
+import Data.Array (bounds, indices, elems)
+import Numeric (showHex)
+import GHC.Exts (Int (I#), Word (W#), int2Word#)
+
+{-
+
+Note [Guidelines for the output of @--show-byte-code@]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The output of @--show-byte-code@ shall be shaped according to the following
+rules:
+
+ * The output is not a complete textual representation of the contents of a
+ bytecode file. Parts that are likely of little or no interest to a human
+ reader are left out. An example of such a “missing” part is the array of
+ instructions in a bytecode object.
+
+ * The shape of the output corresponds to a forest, whose structure closely
+ follows the structure of the bytecode representation within the compiler.
+ The textual representation of each subtree of this forest is generated using
+ the 'entry' operation defined in this module.
+
+ * Single quotes are put around items (using the 'quotes' operation) where this
+ makes it easier to distinguish the items from surrounding text. Examples of
+ items with quotes around them are names and types. Integer and string
+ literals are output without quotes, because they stick out by themselves.
+
+ * Infix operators are output with parentheses around them. To ensure that this
+ is always the case, all textual representations of 'OccName' and 'Name'
+ values are generated using the 'pprNameProperly' operation, defined in this
+ module, instead of the 'pprNameProperly' operation.
+
+-}
+
+-- | Outputs textual information about the contents of a bytecode file.
+showByteCode :: Logger -> HscEnv -> FilePath -> IO ()
+showByteCode logger env path = do
+ byteCode <- readOnDiskModuleByteCode env path
+ logMsg logger
+ MCDump
+ noSrcSpan
+ (withPprStyle defaultDumpStyle $ pprOnDiskModuleByteCode byteCode)
+
+-- | Constructs textual information about the contents of a bytecode file.
+pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc
+pprOnDiskModuleByteCode OnDiskModuleByteCode {..}
+ = vcat [
+ pprModule $ odgbc_module,
+ pprOnDiskModuleByteCodeHash $ odgbc_hash,
+ pprCompiledByteCode odgbc_module $ odgbc_compiled_byte_code
+ ]
+
+-- | Constructs textual information about a module.
+pprModule :: Module -> SDoc
+pprModule = entry (text "module") . ppr
+
+-- | Constructs textual information about the hash of a module.
+pprOnDiskModuleByteCodeHash :: Fingerprint -> SDoc
+pprOnDiskModuleByteCodeHash = entry (text "hash") . ppr
+
+-- | Constructs textual information about bytecode.
+pprCompiledByteCode :: Module -- ^ The enclosing module
+ -> CompiledByteCode -- ^ The bytecode
+ -> SDoc -- ^ The textual information
+pprCompiledByteCode enclosing_module CompiledByteCode {..}
+ = vcat [
+ pprByteCodeObjects enclosing_module $ bc_bcos,
+ pprDataConstructorInfoTables $ bc_itbls,
+ pprTopLevelStrings $ bc_strs,
+ pprBreakpoints enclosing_module $ bc_breaks,
+ pprStaticPointerTableEntries $ bc_spt_entries,
+ pprHPCInfo enclosing_module $ bc_hpc_info
+ ]
+
+-- | Constructs textual information about bytecode objects.
+pprByteCodeObjects :: Module -- ^ The enlosing module
+ -> FlatBag UnlinkedBCO -- ^ The bytecode objects
+ -> SDoc -- ^ The textual information
+pprByteCodeObjects enclosing_module = entry (text "objects") .
+ vcatOrNone .
+ map (pprByteCodeObject enclosing_module) .
+ elemsFlatBag
+
+-- | Constructs textual information about a single bytecode object.
+pprByteCodeObject :: Module -- ^ The enclosing module
+ -> UnlinkedBCO -- ^ The bytecode object
+ -> SDoc -- ^ The textual information
+pprByteCodeObject enclosing_module byte_code_object = case byte_code_object of
+ UnlinkedBCO {..}
+ -> entry (text "object" <+> quotes (pprNameProperly unlinkedBCOName)) $
+ vcat [
+ pprArity $ unlinkedBCOArity,
+ pprLiterals enclosing_module $ unlinkedBCOLits,
+ pprUsedItems enclosing_module $ unlinkedBCOPtrs
+ ]
+ UnlinkedStaticCon {..}
+ -> entry (
+ text "static-construction object" <+>
+ quotes (pprNameProperly unlinkedStaticConName)
+ )
+ $
+ vcat [
+ pprDataConstructor $ unlinkedStaticConDataConName,
+ pprLiftedness $ not unlinkedStaticConIsUnlifted,
+ pprLiterals enclosing_module $ unlinkedStaticConLits,
+ pprUsedItems enclosing_module $ unlinkedStaticConPtrs
+ ]
+
+-- | Constructs textual information about the arity of a bytecode object.
+pprArity :: Int -> SDoc
+pprArity = entry (text "arity") . ppr
+
+-- | Constructs textual information about the data constructor of a
+-- static-construction bytecode object.
+pprDataConstructor :: Name -> SDoc
+pprDataConstructor = entry (text "data constructor") . pprNameProperly
+
+-- | Constructs textual information about the liftedness of a
+-- static-construction bytecode object.
+pprLiftedness :: Bool -> SDoc
+pprLiftedness = entry (text "lifted") . noOrYes
+
+-- | Constructs textual information about literals.
+pprLiterals :: Module -- ^ The enclosing module
+ -> FlatBag BCONPtr -- ^ The literals
+ -> SDoc -- ^ The textual information
+pprLiterals enclosing_module = entry (text "literals") .
+ vcatOrNone .
+ map (pprLiteral enclosing_module) .
+ elemsFlatBag
+
+-- | Constructs textual information about a single literal.
+pprLiteral :: Module -- ^ The enclosing module
+ -> BCONPtr -- ^ The literal
+ -> SDoc -- ^ The textual information
+pprLiteral enclosing_module literal = case literal of
+ BCONPtrWord word
+ -> text "word" <+>
+ ppr word
+ BCONPtrLbl label
+ -> text "label" <+>
+ quotes (ppr label)
+ BCONPtrItbl infoTableName
+ -> text "info table of" <+>
+ quotes (pprNameProperly infoTableName)
+ BCONPtrAddr addrName
+ -> text "address" <+>
+ quotes (pprNameProperly addrName)
+ BCONPtrStr encoded_string
+ -> text "top-level string" <+>
+ text (show (utf8DecodeByteString encoded_string))
+ BCONPtrFS string
+ -> text "top-level string" <+>
+ text (show (unpackFS string))
+ BCONPtrFFIInfo ffiInfo
+ -> text "foreign function of type" <+>
+ quotes (pprFFIInfo ffiInfo)
+ BCONPtrCostCentre breakpointID
+ -> text "cost center of breakpoint" <+>
+ pprInternalBreakpointID enclosing_module breakpointID
+
+-- | Constructs textual information about FFI info.
+pprFFIInfo :: FFIInfo -> SDoc
+pprFFIInfo FFIInfo {..}
+ = hsep (map (pprFFIType >>> (<+> text "->")) ffiInfoArgs) <+>
+ pprFFIType ffiInfoRet
+
+-- | Constructs textual information about an FFI type.
+pprFFIType :: FFIType -> SDoc
+pprFFIType ffi_type = assert (take 3 ident == "FFI") $ text (drop 3 ident) where
+
+ ident :: String
+ ident = show ffi_type
+
+-- | Constructs textual information about the ID of a bytecode breakpoint.
+pprInternalBreakpointID
+ :: Module -- ^ The enclosing module
+ -> InternalBreakpointId -- ^ The ID of the bytecode breakpoint
+ -> SDoc -- ^ The textual information
+pprInternalBreakpointID enclosing_module InternalBreakpointId {..}
+ | ibi_info_mod == enclosing_module = index_doc
+ | otherwise = index_doc <+>
+ text "in" <+>
+ quotes (ppr ibi_info_mod)
+ where
+
+ index_doc :: SDoc
+ index_doc = ppr ibi_info_index
+
+-- | Constructs textual information about used items.
+pprUsedItems :: Module -- ^ The enclosing module
+ -> FlatBag BCOPtr -- ^ The used items
+ -> SDoc -- ^ The textual information
+pprUsedItems enclosing_module = entry (text "used items") .
+ vcatOrNone .
+ map (pprUsedItem enclosing_module) .
+ elemsFlatBag
+
+-- | Constructs textual information about a single used item.
+pprUsedItem :: Module -- ^ The enclosing module
+ -> BCOPtr -- ^ The used item
+ -> SDoc -- ^ The textual information
+pprUsedItem enclosing_module used_item = case used_item of
+ BCOPtrName name
+ -> text "named item" <+> quotes (pprNameProperly name)
+ BCOPtrPrimOp primOp
+ -> text "primitive operation" <+> quotes (ppr primOp)
+ BCOPtrBCO byte_code_object
+ -> pprByteCodeObject enclosing_module byte_code_object
+ BCOPtrBreakArray breakArrayModule
+ -> text "break array of module" <+> quotes (ppr breakArrayModule)
+
+-- | Constructs textual information about data constructor info tables.
+pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc
+pprDataConstructorInfoTables = entry (text "data constructor info tables") .
+ vcatOrNone .
+ map (uncurry pprDataConstructorInfoTable)
+
+-- | Constructs textual information about a single data constructor info table.
+pprDataConstructorInfoTable :: Name -> ConInfoTable -> SDoc
+pprDataConstructorInfoTable data_constr_name ConInfoTable {..}
+ = entry (text "info table of" <+> quotes (pprNameProperly data_constr_name)) $
+ vcat [
+ pprPointerWordCount $ conItblPtrs,
+ pprNonPointerWordCount $ conItblNPtrs
+ ]
+
+-- | Constructs textual information about a number of pointer words.
+pprPointerWordCount :: Int -> SDoc
+pprPointerWordCount = entry (text "number of words for pointers") . ppr
+
+-- | Constructs textual information about a number of non-pointer words.
+pprNonPointerWordCount :: Int -> SDoc
+pprNonPointerWordCount = entry (text "number of words for non-pointers") . ppr
+
+-- | Constructs textual information about top-level strings.
+pprTopLevelStrings :: [(Name, ByteString)] -> SDoc
+pprTopLevelStrings = entry (text "top-level strings") .
+ vcatOrNone .
+ map (uncurry pprTopLevelString)
+
+-- | Constructs textual information about a single top-level string.
+pprTopLevelString :: Name -> ByteString -> SDoc
+pprTopLevelString string_name encoded_string
+ = entry (pprNameProperly string_name) $
+ text $
+ show $
+ utf8DecodeByteString $
+ encoded_string
+
+-- | Constructs textual information about breakpoints.
+pprBreakpoints :: Module -- ^ The enclosing module
+ -> Maybe InternalModBreaks -- ^ The breakpoints
+ -> SDoc -- ^ The textual information
+pprBreakpoints enclosing_module
+ = entry (text "breakpoints") .
+ maybe (text "<none>") (pprActualBreakpoints enclosing_module)
+
+-- | Constructs textual information about actual breakpoints.
+pprActualBreakpoints :: Module -- ^ The enclosing module
+ -> InternalModBreaks -- ^ The actual breakpoints
+ -> SDoc -- ^ The textual information
+pprActualBreakpoints enclosing_module InternalModBreaks {..}
+ = vcat [
+ pprSourceBreakpoints enclosing_module $ imodBreaks_modBreaks,
+ pprByteCodeBreakpoints enclosing_module $ imodBreaks_breakInfo
+ ]
+
+-- | Constructs textual information about source breakpoints.
+pprSourceBreakpoints :: Module -- ^ The enclosing module
+ -> ModBreaks -- ^ The source breakpoints
+ -> SDoc -- ^ The textual information
+pprSourceBreakpoints enclosing_module ModBreaks {..}
+ = entry (text "source breakpoints") $
+ assert (modBreaks_module == enclosing_module) $
+ assert (bounds modBreaks_locs_ == bounds modBreaks_decls) $
+ assert (bounds modBreaks_locs_ == bounds modBreaks_vars) $
+ vcatOrNone $
+ zipWith4 pprSourceBreakpoint (indices modBreaks_locs_)
+ (elems modBreaks_locs_)
+ (elems modBreaks_decls)
+ (elems modBreaks_vars)
+ -- The cost center infos in 'modBreaks_ccs', when present, just contain
+ -- textual representations of the declaration paths in 'modBreaks_decls' and
+ -- the source spans in 'modBreaks_locs_' and are therefore never shown.
+
+-- | Constructs textual information about a single source breakpoint.
+pprSourceBreakpoint
+ :: BreakTickIndex -- ^ The index of the source breakpoint
+ -> BinSrcSpan -- ^ The source span of the source breakpoint
+ -> [String] -- ^ The names declared by the surrounding declarations
+ -> [OccName] -- ^ The free variables of the source breakpoint
+ -> SDoc -- ^ The textual information
+pprSourceBreakpoint ix src_span declaration_path free_vars
+ = entry (text "source breakpoint" <+> ppr ix) $
+ vcat [
+ pprSrcSpan $ src_span,
+ pprDeclarationPath $ declaration_path,
+ pprFreeVariables $ free_vars
+ ]
+
+-- | Constructs textual information about a source span.
+pprSrcSpan :: BinSrcSpan -> SDoc
+pprSrcSpan = entry (text "source span") . ppr . unBinSrcSpan
+
+-- | Constructs textual information about a declaration path, which is the list
+-- of names declared by the declarations surrounding a source breakpoint.
+pprDeclarationPath :: [String] -> SDoc
+pprDeclarationPath = entry (text "declaration path") . vcatOrEmpty . map text
+
+-- | Constructs textual information about free variables.
+pprFreeVariables :: [OccName] -> SDoc
+pprFreeVariables = entry (text "free variables") .
+ vcatOrNone .
+ map pprNameProperly
+
+-- | Constructs textual information about bytecode breakpoints.
+pprByteCodeBreakpoints :: Module -- ^ The enclosing module
+ -> IntMap CgBreakInfo -- ^ The bytecode breakpoints
+ -> SDoc -- ^ The textual information
+pprByteCodeBreakpoints enclosing_module
+ = entry (text "bytecode breakpoints") .
+ vcatOrNone .
+ map (uncurry (pprByteCodeBreakpoint enclosing_module)) .
+ IntMap.toList
+
+-- | Constructs textual information about a single bytecode breakpoint.
+pprByteCodeBreakpoint :: Module -- ^ The enclosing module
+ -> Int -- ^ The index of the bytecode breakpoint
+ -> CgBreakInfo -- ^ The bytecode breakpoint
+ -> SDoc -- ^ The textual information
+pprByteCodeBreakpoint enclosing_module ix CgBreakInfo {..}
+ = entry (text "bytecode breakpoint" <+> ppr ix) $
+ vcat [
+ pprType $ cgb_resty,
+ pprTypeVariables $ cgb_tyvars,
+ pprVariables $ cgb_vars,
+ pprCorrespondingSourceBreakpoint enclosing_module $ cgb_tick_id
+ ]
+ -- That the 'cgb_resty' field holds the type of the breakpoint is apparent
+ -- from the fact that this field is set by
+ -- 'GHC.StgToByteCode.dehydrateCgBreakInfo' using one of its arguments and
+ -- 'GHC.StgToByteCode.dehydrateCgBreakInfo' is always invoked with this
+ -- argument set to the extension field of 'Breakpoint', which in turn holds
+ -- the type of the breakpoint according to Note [Tickish passes] and the
+ -- comment on the instance declaration of @XBreakpoint 'TickishPassStg@.
+
+-- | Constructs textual information about a type.
+pprType :: IfaceType -> SDoc
+pprType = entry (text "type") . ppr
+
+-- | Constructs textual information about type variables.
+pprTypeVariables :: [IfaceTvBndr] -> SDoc
+pprTypeVariables = entry (text "type variables") .
+ vcatOrNone .
+ map pprTypeVariableBinder
+
+-- | Constructs textual information about a type variable binder.
+pprTypeVariableBinder :: IfaceTvBndr -> SDoc
+pprTypeVariableBinder (name, kind) = ppr name <+> text "::" <+> ppr kind
+
+-- | Constructs textual information about variables.
+pprVariables :: [Maybe (IfaceIdBndr, Word)] -> SDoc
+pprVariables = entry (text "variables") . vcatOrNone . map pprVariable
+
+-- | Constructs textual information about a single variable.
+pprVariable :: Maybe (IfaceIdBndr, Word) -> SDoc
+pprVariable = maybe (text "<unknown>") (pprVariableBinder . fst)
+
+-- | Constructs textual information about a variable binder.
+pprVariableBinder :: IfaceIdBndr -> SDoc
+pprVariableBinder (multiplicity, name, type_)
+ = text "%" <> ppr multiplicity <+>
+ ppr name <+> text "::" <+> ppr type_
+
+-- | Constructs textual information about a source breakpoint corresponding to a
+-- bytecode breakpoint.
+pprCorrespondingSourceBreakpoint :: Module
+ -- ^ The enclosing module
+ -> Either InternalBreakLoc BreakpointId
+ -- ^ A reference to the source breakpoint
+ -> SDoc
+ -- ^ The textual information
+pprCorrespondingSourceBreakpoint enclosing_module
+ = entry (text "corresponding source breakpoint") .
+ pprBreakpointID enclosing_module .
+ either internalBreakLoc id
+
+-- | Constructs textual information about the ID of a source breakpoint.
+pprBreakpointID :: Module -- ^ The enclosing module
+ -> BreakpointId -- ^ The ID of the source breakpoint
+ -> SDoc -- ^ The textual information
+pprBreakpointID enclosing_module BreakpointId {..}
+ | bi_tick_mod == enclosing_module = index_doc
+ | otherwise = index_doc <+>
+ text "in" <+>
+ quotes (ppr bi_tick_mod)
+ where
+
+ index_doc :: SDoc
+ index_doc = ppr bi_tick_index
+
+-- | Constructs textual information about static-pointer table entries.
+pprStaticPointerTableEntries :: [SptEntry] -> SDoc
+pprStaticPointerTableEntries = entry (text "static-pointer table entries") .
+ vcatOrNone .
+ map pprStaticPointerTableEntry
+
+-- | Constructs textual information about a single static-pointer table entry.
+pprStaticPointerTableEntry :: SptEntry -> SDoc
+pprStaticPointerTableEntry (SptEntry name fingerprint)
+ = entry (ppr fingerprint) (pprNameProperly name)
+
+-- | Constructs textual information about HPC info.
+pprHPCInfo :: Module -- ^ The enclosing module
+ -> Strict.Maybe ByteCodeHpcInfo -- ^ The HPC info
+ -> SDoc -- ^ The textual information
+pprHPCInfo enclosing_module
+ = entry (text "HPC information") .
+ Strict.maybe (text "<none>") (pprActualHPCInfo enclosing_module)
+
+-- | Constructs textual information about actual HPC info.
+pprActualHPCInfo :: Module -- ^ The enclosing module
+ -> ByteCodeHpcInfo -- ^ The actual HPC info
+ -> SDoc -- ^ The textual information
+pprActualHPCInfo enclosing_module ByteCodeHpcInfo {..}
+ = assert (
+ utf8DecodeShortByteString bchi_module_name
+ ==
+ moduleNameString (moduleName enclosing_module)
+ )
+ $
+ vcat [
+ pprHPCInfoHash $ bchi_hash,
+ pprTickBox $ bchi_tickbox_name,
+ pprTickCount $ bchi_tick_count
+ ]
+
+-- | Constructs textual information about the hash of HPC info.
+pprHPCInfoHash :: Int -> SDoc
+pprHPCInfoHash = entry (text "hash") . pprFixedSizeNatural . intToWord
+
+-- | Constructs textual information about a tick box.
+pprTickBox :: ShortByteString -> SDoc
+pprTickBox = entry (text "tick box") . text . utf8DecodeShortByteString
+
+-- | Constructs textual information about a number of ticks.
+pprTickCount :: Int -> SDoc
+pprTickCount = entry (text "number of ticks") . ppr
+
+-- | Constructs the Haskell representation of a name. This includes putting
+-- parentheses around operators. The given name is supposed to be of type
+-- 'OccName' or 'Name'.
+pprNameProperly :: (HasOccName a, Outputable a) => a -> SDoc
+pprNameProperly name = parenSymOcc (occName name) (ppr name)
+
+-- | Constructs a hexadecimal representation of a natural number such that the
+-- number of hexadecimal digits fits the number of bits used to represent the
+-- natural number.
+pprFixedSizeNatural :: (Integral a, FiniteBits a) => a -> SDoc
+pprFixedSizeNatural num
+ = assert (num >= 0) $
+ text $ replicate (digit_count - length unpadded) '0' ++ unpadded
+ where
+
+ digit_count :: Int
+ digit_count = (finiteBitSize num + 3) `div` 4
+
+ unpadded :: String
+ unpadded = showHex num ""
+
+-- | Turns an 'Int' value into the 'Word' value with the same representation.
+intToWord :: Int -> Word
+intToWord (I# int#) = W# (int2Word# int#)
+
+-- | Constructs a textual representation of a boolean, interpreting 'True' and
+-- 'False' as “yes” and “no”, respectively.
+noOrYes :: Bool -> SDoc
+noOrYes = text . bool "no" "yes"
+
+-- | Constructs an entry in a list of textual data representations.
+entry :: SDoc -- ^ The title of the entry
+ -> SDoc -- ^ The contents of the entry
+ -> SDoc -- ^ The entry
+entry title contents = hang (title <> text ":") 2 contents
+
+-- | Composes documents vertically in general, but presents an empty document
+-- list as @<none>@.
+vcatOrNone :: [SDoc] -> SDoc
+vcatOrNone [] = text "<none>"
+vcatOrNone docs = vcat docs
+
+-- | Composes documents vertically in general, but presents an empty document
+-- list as @<empty>@.
+vcatOrEmpty :: [SDoc] -> SDoc
+vcatOrEmpty [] = text "<empty>"
+vcatOrEmpty docs = vcat docs
=====================================
compiler/ghc.cabal.in
=====================================
@@ -220,6 +220,7 @@ Library
GHC.ByteCode.Linker
GHC.ByteCode.Recomp.Binary
GHC.ByteCode.Serialize
+ GHC.ByteCode.Show
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
=====================================
docs/users_guide/using.rst
=====================================
@@ -453,6 +453,13 @@ The available mode flags are:
Read an interface file and dump relevent parts of it as text to ``stdout``.
+.. ghc-flag:: --show-byte-code ⟨file⟩
+ :shortdesc: display contents of a bytecode file.
+ :type: mode
+ :category: modes
+
+ Read a bytecode file and dump relevant parts of it as text to ``stdout``.
+
.. ghc-flag:: --supported-extensions
--supported-languages
:shortdesc: display the supported language extensions
=====================================
ghc/GHC/Driver/Session/Mode.hs
=====================================
@@ -77,6 +77,7 @@ isShowGhciUsageMode _ = False
data PostLoadMode
= ShowInterface FilePath -- ghc --show-iface
+ | ShowByteCode FilePath -- ghc --show-byte-code
| DoMkDependHS -- ghc -M
| StopBefore StopPhase -- ghc -E | -C | -S
-- StopBefore StopLn is the default
@@ -101,6 +102,9 @@ showUnitsMode = mkPostLoadMode ShowPackages
showInterfaceMode :: FilePath -> Mode
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+showByteCodeMode :: FilePath -> Mode
+showByteCodeMode fp = mkPostLoadMode (ShowByteCode fp)
+
stopBeforeMode :: StopPhase -> Mode
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
@@ -231,9 +235,11 @@ mode_flags =
replaceSpace ' ' = '-'
replaceSpace c = c
] ++
- ------- interfaces ----------------------------------------------------
- [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
+ ------- textual output of generated data -----------------------------
+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
"--show-iface"))
+ , defFlag "-show-byte-code" (HasArg (\f -> setMode (showByteCodeMode f)
+ "--show-byte-code"))
------- primary modes ------------------------------------------------
, defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f
=====================================
ghc/Main.hs
=====================================
@@ -73,6 +73,8 @@ import GHC.SysTools.BaseDir
import GHC.Iface.Load
import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
+import GHC.ByteCode.Show ( showByteCode )
+
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Iface.Errors.Ppr
@@ -267,6 +269,7 @@ main' postLoadMode units dflags0 args flagWarnings = do
(hsc_units hsc_env)
(hsc_NC hsc_env)
f
+ ShowByteCode f -> liftIO $ showByteCode logger hsc_env f
DoMake -> doMake units srcs
DoMkDependHS -> doMkDependHS (map fst srcs)
StopBefore p -> liftIO (oneShot hsc_env p srcs)
=====================================
testsuite/tests/show-bytecode/Example.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE StaticPointers #-}
+
+-- | This module uses in particular the following features:
+--
+-- * Local variables defined in `where` clauses
+-- * Integer literals
+-- * Infix operators
+-- * Recursion
+-- * Static pointers
+-- * Algebraic-datatype declarations
+-- * Foreign import declarations
+module Example where
+
+import Numeric.Natural (Natural)
+import Foreign.Ptr (Ptr)
+import Foreign.C.Types (CChar, CSize (CSize))
+import GHC.StaticPtr (StaticPtr)
+
+fibonaccis :: [Natural]
+fibonaccis = 0 : positiveFibonaccis where
+
+ positiveFibonaccis :: [Natural]
+ positiveFibonaccis = 1 : zipWith (+) fibonaccis positiveFibonaccis
+
+fibonaccisPtr :: StaticPtr [Natural]
+fibonaccisPtr = static fibonaccis
+
+divides :: Integral a => a -> a -> Bool
+k `divides` n = n `mod` k == 0
+
+primes :: [Natural]
+primes = 2 : filter isPrime [3 ..] where
+
+ isPrime :: Natural -> Bool
+ isPrime n = not (any (`divides` n) (takeWhile ((<= n) . (^ 2)) primes))
+
+primesPtr :: StaticPtr [Natural]
+primesPtr = static primes
+
+data BinTree a b = Leaf a | Node (BinTree a b) b (BinTree a b)
+
+data PerfectTree a = PerfectTree a | Nested (PerfectTree (a, a))
+
+foreign import ccall "string.h strlen"
+ cstrlen :: Ptr CChar -> IO CSize
=====================================
testsuite/tests/show-bytecode/Makefile
=====================================
@@ -0,0 +1,18 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+compile = '$(TEST_HC)' $(TEST_HC_OPTS) -fbyte-code -fwrite-byte-code -no-link
+show = '$(TEST_HC)' $(TEST_HC_OPTS) --show-byte-code
+
+show-bytecode-vanilla:
+ $(compile) Example.hs
+ $(show) Example.gbc | ./normalize
+
+show-bytecode-breakpoints:
+ $(compile) -fbreak-points Example.hs
+ $(show) Example.gbc | ./normalize
+
+show-bytecode-hpc:
+ $(compile) -fhpc Example.hs
+ $(show) Example.gbc | ./normalize
=====================================
testsuite/tests/show-bytecode/all.T
=====================================
@@ -0,0 +1,18 @@
+test(
+ 'show-bytecode-vanilla',
+ extra_files(['Example.hs', 'normalize']),
+ makefile_test,
+ []
+)
+test(
+ 'show-bytecode-breakpoints',
+ extra_files(['Example.hs', 'normalize']),
+ makefile_test,
+ []
+)
+test(
+ 'show-bytecode-hpc',
+ [js_skip, extra_files(['Example.hs', 'normalize'])],
+ makefile_test,
+ []
+)
=====================================
testsuite/tests/show-bytecode/normalize
=====================================
@@ -0,0 +1,29 @@
+#!/usr/bin/env bash
+
+set -e -o pipefail
+
+# Make the test output independent of unstable compiler-generated data
+stabilize ()
+{
+ sed -E -e '
+ s/_r[[:alnum:]]+/_@name_suffix@/g
+ s/^( *hash: )[[:xdigit:]]+/\1@hash@/
+ s/^( *)[[:xdigit:]]+:/\1@hash@:/
+ s/word [[:digit:]]{2}[[:digit:]]*/word @large_word@/g
+ '
+}
+
+# Make the test output independent of the word size
+universalize ()
+{
+ sed -E -e '
+ s/W[[:digit:]]+#/W@word_size@#/
+ s/UInt[[:digit:]]+/UInt@word_size@/
+ ' |
+ uniq
+ # The invocation of `uniq` is merely for collapsing adjacent entries of
+ # `word @large_word@`, whose number may depend on the word size.
+}
+
+# Run all phases
+stabilize | universalize
=====================================
testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout
=====================================
@@ -0,0 +1,828 @@
+[1 of 1] Compiling Example ( Example.hs, Example.gbc )
+module: Example
+hash: @hash@
+objects:
+ object ‘primesPtr’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 0
+ used items:
+ break array of module ‘Example’
+ named item ‘static_ptr1’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr1’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ named item ‘primes’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘primes’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 2
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 1
+ used items:
+ break array of module ‘Example’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 3
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘$fEnumNatural’
+ named item ‘enumFrom’
+ named item ‘isPrime_@name_suffix@’
+ named item ‘filter’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 2
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘isPrime_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 9
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 8
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 7
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 6
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 5
+ word 2
+ info table of ‘IS’
+ used items:
+ break array of module ‘Example’
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fIntegralInteger’
+ named item ‘$fNumNatural’
+ named item ‘(^)’
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 4
+ used items:
+ break array of module ‘Example’
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fOrdNatural’
+ named item ‘(<=)’
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘(.)’
+ named item ‘primes’
+ named item ‘takeWhile’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 3
+ used items:
+ break array of module ‘Example’
+ object ‘pap_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ named item ‘$fIntegralNatural’
+ named item ‘divides’
+ named item ‘$fFoldableList’
+ named item ‘any’
+ named item ‘not’
+ object ‘fibonaccisPtr’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 10
+ used items:
+ break array of module ‘Example’
+ named item ‘static_ptr’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ named item ‘fibonaccis’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘fibonaccis’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 11
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘fibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 0
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘positiveFibonaccis_@name_suffix@’
+ object ‘positiveFibonaccis_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 13
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 12
+ used items:
+ break array of module ‘Example’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘(+)’
+ named item ‘positiveFibonaccis_@name_suffix@’
+ named item ‘fibonaccis’
+ named item ‘zipWith’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 1
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘$dTypeable2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$dTypeable_@name_suffix@’
+ named item ‘$dTypeable1_@name_suffix@’
+ named item ‘mkTrAppChecked’
+ object ‘$dTypeable1_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcList’
+ named item ‘mkTrCon’
+ object ‘$dTypeable_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcNatural’
+ named item ‘mkTrCon’
+ object ‘cstrlen’:
+ arity: 2
+ literals: <none>
+ used items:
+ object ‘ds1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘strlen’
+ word 0
+ foreign function of type ‘Pointer -> UInt@word_size@’
+ used items:
+ object ‘wild_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘W@word_size@#’
+ used items: <none>
+ static-construction object ‘$tc'Nested’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Nested2_@name_suffix@’
+ named item ‘$krep17_@name_suffix@’
+ static-construction object ‘$tc'Nested2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Nested1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep17_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep16_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep16_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep15_@name_suffix@’
+ static-construction object ‘$krep15_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep4_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tc'PerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'PerfectTree2_@name_suffix@’
+ named item ‘$krep14_@name_suffix@’
+ static-construction object ‘$tc'PerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'PerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep14_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep13_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep12_@name_suffix@’
+ static-construction object ‘$krep12_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcPerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcPerfectTree2_@name_suffix@’
+ named item ‘krepStarArr’
+ static-construction object ‘$tcPerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcPerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$tc'Node’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Node2_@name_suffix@’
+ named item ‘$krep11_@name_suffix@’
+ static-construction object ‘$tc'Node2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Node1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep11_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ named item ‘$krep10_@name_suffix@’
+ static-construction object ‘$krep10_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘$krep9_@name_suffix@’
+ static-construction object ‘$krep9_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$tc'Leaf’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Leaf2_@name_suffix@’
+ named item ‘$krep8_@name_suffix@’
+ static-construction object ‘$tc'Leaf2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Leaf1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep8_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$krep7_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcBinTree’
+ named item ‘$krep6_@name_suffix@’
+ static-construction object ‘$krep6_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep5_@name_suffix@’
+ static-construction object ‘$krep5_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcBinTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcBinTree2_@name_suffix@’
+ named item ‘krepStarArrStarArr’
+ static-construction object ‘$tcBinTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcBinTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep4_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcTuple2’
+ named item ‘$krep3_@name_suffix@’
+ static-construction object ‘$krep3_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep2_@name_suffix@’
+ static-construction object ‘$krep2_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$krep1_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ static-construction object ‘$krep_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ static-construction object ‘$trModule’:
+ data constructor: Module
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$trModule2_@name_suffix@’
+ named item ‘$trModule4_@name_suffix@’
+ static-construction object ‘$trModule4_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule3_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$trModule2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule1_@name_suffix@’
+ used items: <none>
+ object ‘divides’:
+ arity: 3
+ literals: <none>
+ used items:
+ object ‘$dReal_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dNum_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dEq_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dEq1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘bcprep_@name_suffix@’:
+ arity: 5
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 15
+ used items:
+ break array of module ‘Example’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 0
+ info table of ‘IS’
+ used items: named item ‘fromInteger’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 3
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 14
+ used items:
+ break array of module ‘Example’
+ named item ‘mod’
+ named item ‘(==)’
+ named item ‘$p1Ord’
+ named item ‘$p2Real’
+ named item ‘$p1Real’
+ named item ‘$p1Integral’
+ object ‘Node’:
+ arity: 3
+ literals: info table of ‘Node’
+ used items: <none>
+ object ‘Leaf’:
+ arity: 1
+ literals: info table of ‘Leaf’
+ used items: <none>
+ object ‘Nested’:
+ arity: 1
+ literals: info table of ‘Nested’
+ used items: <none>
+ object ‘PerfectTree’:
+ arity: 1
+ literals: info table of ‘PerfectTree’
+ used items: <none>
+data constructor info tables:
+ info table of ‘PerfectTree’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Nested’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Leaf’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Node’:
+ number of words for pointers: 3
+ number of words for non-pointers: 0
+top-level strings:
+ $tc'Nested1_@name_suffix@: "'Nested"
+ $tc'PerfectTree1_@name_suffix@: "'PerfectTree"
+ $tcPerfectTree1_@name_suffix@: "PerfectTree"
+ $tc'Node1_@name_suffix@: "'Node"
+ $tc'Leaf1_@name_suffix@: "'Leaf"
+ $tcBinTree1_@name_suffix@: "BinTree"
+ $trModule3_@name_suffix@: "Example"
+ $trModule1_@name_suffix@: "main"
+breakpoints:
+ source breakpoints:
+ source breakpoint 0:
+ source span: Example.hs:29:17-25
+ declaration path: divides
+ free variables:
+ k
+ n
+ source breakpoint 1:
+ source span: Example.hs:29:17-30
+ declaration path: divides
+ free variables:
+ k
+ n
+ source breakpoint 2:
+ source span: Example.hs:35:27-37
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 3:
+ source span: Example.hs:35:53-56
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 4:
+ source span: Example.hs:35:62-64
+ declaration path:
+ primes
+ isPrime
+ free variables: <none>
+ source breakpoint 5:
+ source span: Example.hs:35:52-65
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 6:
+ source span: Example.hs:35:41-73
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 7:
+ source span: Example.hs:35:22-74
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 8:
+ source span: Example.hs:35:17-75
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 9:
+ source span: Example.hs:32:14-34
+ declaration path: primes
+ free variables: isPrime
+ source breakpoint 10:
+ source span: Example.hs:32:10-34
+ declaration path: primes
+ free variables: isPrime
+ source breakpoint 11:
+ source span: Example.hs:38:13-25
+ declaration path: primesPtr
+ free variables: <none>
+ source breakpoint 12:
+ source span: Example.hs:23:30-70
+ declaration path:
+ fibonaccis
+ positiveFibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 13:
+ source span: Example.hs:23:26-70
+ declaration path:
+ fibonaccis
+ positiveFibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 14:
+ source span: Example.hs:20:14-35
+ declaration path: fibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 15:
+ source span: Example.hs:26:17-33
+ declaration path: fibonaccisPtr
+ free variables: <none>
+ bytecode breakpoints:
+ bytecode breakpoint 0:
+ type: StaticPtr [Natural]
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 11
+ bytecode breakpoint 1:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 9
+ bytecode breakpoint 2:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 10
+ bytecode breakpoint 3:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 2
+ bytecode breakpoint 4:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 3
+ bytecode breakpoint 5:
+ type: Natural -> Natural
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 4
+ bytecode breakpoint 6:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 5
+ bytecode breakpoint 7:
+ type: [Natural]
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 6
+ bytecode breakpoint 8:
+ type: Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 7
+ bytecode breakpoint 9:
+ type: Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 8
+ bytecode breakpoint 10:
+ type: StaticPtr [Natural]
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 15
+ bytecode breakpoint 11:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 14
+ bytecode breakpoint 12:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 12
+ bytecode breakpoint 13:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 13
+ bytecode breakpoint 14:
+ type: a
+ type variables: a :: *
+ variables:
+ %'Many eta :: a
+ %'Many eta1 :: a
+ corresponding source breakpoint: 0
+ bytecode breakpoint 15:
+ type: Bool
+ type variables: a :: *
+ variables:
+ %'Many eta :: a
+ %'Many eta1 :: a
+ corresponding source breakpoint: 1
+static-pointer table entries:
+ @hash@: static_ptr
+ @hash@: static_ptr1
+HPC information: <none>
+
=====================================
testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs
=====================================
@@ -0,0 +1,832 @@
+[1 of 1] Compiling Example ( Example.hs, Example.gbc )
+module: Example
+hash: @hash@
+objects:
+ object ‘primesPtr’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 0
+ used items:
+ break array of module ‘Example’
+ named item ‘static_ptr1’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr1’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ named item ‘primes’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘primes’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 2
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 1
+ used items:
+ break array of module ‘Example’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 3
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘$fEnumNatural’
+ named item ‘enumFrom’
+ named item ‘isPrime_@name_suffix@’
+ named item ‘filter’
+ object ‘primes_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 2
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘isPrime_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 9
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 8
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 7
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 6
+ used items:
+ break array of module ‘Example’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 5
+ word 2
+ info table of ‘IS’
+ used items:
+ break array of module ‘Example’
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fIntegralInteger’
+ named item ‘$fNumNatural’
+ named item ‘(^)’
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 4
+ used items:
+ break array of module ‘Example’
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fOrdNatural’
+ named item ‘(<=)’
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘(.)’
+ named item ‘primes’
+ named item ‘takeWhile’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 3
+ used items:
+ break array of module ‘Example’
+ object ‘pap_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ named item ‘$fIntegralNatural’
+ named item ‘divides’
+ named item ‘$fFoldableList’
+ named item ‘any’
+ named item ‘not’
+ object ‘fibonaccisPtr’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 10
+ used items:
+ break array of module ‘Example’
+ named item ‘static_ptr’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ named item ‘fibonaccis’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘fibonaccis’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 11
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘fibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 0
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘positiveFibonaccis_@name_suffix@’
+ object ‘positiveFibonaccis_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 13
+ info table of ‘(:)’
+ used items:
+ break array of module ‘Example’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 12
+ used items:
+ break array of module ‘Example’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘(+)’
+ named item ‘positiveFibonaccis_@name_suffix@’
+ named item ‘fibonaccis’
+ named item ‘zipWith’
+ object ‘positiveFibonaccis_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 1
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘$dTypeable2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$dTypeable_@name_suffix@’
+ named item ‘$dTypeable1_@name_suffix@’
+ named item ‘mkTrAppChecked’
+ object ‘$dTypeable1_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcList’
+ named item ‘mkTrCon’
+ object ‘$dTypeable_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcNatural’
+ named item ‘mkTrCon’
+ object ‘cstrlen’:
+ arity: 2
+ literals: <none>
+ used items: named item ‘cstrlen1_@name_suffix@’
+ object ‘cstrlen1_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ object ‘ds1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘strlen’
+ word 0
+ foreign function of type ‘Pointer -> UInt@word_size@’
+ used items:
+ object ‘wild_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘W@word_size@#’
+ used items: <none>
+ static-construction object ‘$tc'Nested’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Nested2_@name_suffix@’
+ named item ‘$krep17_@name_suffix@’
+ static-construction object ‘$tc'Nested2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Nested1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep17_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep16_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep16_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep15_@name_suffix@’
+ static-construction object ‘$krep15_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep4_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tc'PerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'PerfectTree2_@name_suffix@’
+ named item ‘$krep14_@name_suffix@’
+ static-construction object ‘$tc'PerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'PerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep14_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep13_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep12_@name_suffix@’
+ static-construction object ‘$krep12_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcPerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcPerfectTree2_@name_suffix@’
+ named item ‘krepStarArr’
+ static-construction object ‘$tcPerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcPerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$tc'Node’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Node2_@name_suffix@’
+ named item ‘$krep11_@name_suffix@’
+ static-construction object ‘$tc'Node2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Node1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep11_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ named item ‘$krep10_@name_suffix@’
+ static-construction object ‘$krep10_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘$krep9_@name_suffix@’
+ static-construction object ‘$krep9_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$tc'Leaf’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Leaf2_@name_suffix@’
+ named item ‘$krep8_@name_suffix@’
+ static-construction object ‘$tc'Leaf2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Leaf1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep8_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$krep7_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcBinTree’
+ named item ‘$krep6_@name_suffix@’
+ static-construction object ‘$krep6_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep5_@name_suffix@’
+ static-construction object ‘$krep5_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcBinTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcBinTree2_@name_suffix@’
+ named item ‘krepStarArrStarArr’
+ static-construction object ‘$tcBinTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcBinTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep4_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcTuple2’
+ named item ‘$krep3_@name_suffix@’
+ static-construction object ‘$krep3_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep2_@name_suffix@’
+ static-construction object ‘$krep2_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$krep1_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ static-construction object ‘$krep_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ static-construction object ‘$trModule’:
+ data constructor: Module
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$trModule2_@name_suffix@’
+ named item ‘$trModule4_@name_suffix@’
+ static-construction object ‘$trModule4_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule3_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$trModule2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule1_@name_suffix@’
+ used items: <none>
+ object ‘divides’:
+ arity: 3
+ literals: <none>
+ used items:
+ object ‘$dReal_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dNum_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dEq_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘$dEq1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘bcprep_@name_suffix@’:
+ arity: 5
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 15
+ used items:
+ break array of module ‘Example’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 0
+ info table of ‘IS’
+ used items: named item ‘fromInteger’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 3
+ literals:
+ top-level string "Example"
+ top-level string "main"
+ cost center of breakpoint 14
+ used items:
+ break array of module ‘Example’
+ named item ‘mod’
+ named item ‘(==)’
+ named item ‘$p1Ord’
+ named item ‘$p2Real’
+ named item ‘$p1Real’
+ named item ‘$p1Integral’
+ object ‘Node’:
+ arity: 3
+ literals: info table of ‘Node’
+ used items: <none>
+ object ‘Leaf’:
+ arity: 1
+ literals: info table of ‘Leaf’
+ used items: <none>
+ object ‘Nested’:
+ arity: 1
+ literals: info table of ‘Nested’
+ used items: <none>
+ object ‘PerfectTree’:
+ arity: 1
+ literals: info table of ‘PerfectTree’
+ used items: <none>
+data constructor info tables:
+ info table of ‘PerfectTree’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Nested’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Leaf’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Node’:
+ number of words for pointers: 3
+ number of words for non-pointers: 0
+top-level strings:
+ $tc'Nested1_@name_suffix@: "'Nested"
+ $tc'PerfectTree1_@name_suffix@: "'PerfectTree"
+ $tcPerfectTree1_@name_suffix@: "PerfectTree"
+ $tc'Node1_@name_suffix@: "'Node"
+ $tc'Leaf1_@name_suffix@: "'Leaf"
+ $tcBinTree1_@name_suffix@: "BinTree"
+ $trModule3_@name_suffix@: "Example"
+ $trModule1_@name_suffix@: "main"
+breakpoints:
+ source breakpoints:
+ source breakpoint 0:
+ source span: Example.hs:29:17-25
+ declaration path: divides
+ free variables:
+ k
+ n
+ source breakpoint 1:
+ source span: Example.hs:29:17-30
+ declaration path: divides
+ free variables:
+ k
+ n
+ source breakpoint 2:
+ source span: Example.hs:35:27-37
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 3:
+ source span: Example.hs:35:53-56
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 4:
+ source span: Example.hs:35:62-64
+ declaration path:
+ primes
+ isPrime
+ free variables: <none>
+ source breakpoint 5:
+ source span: Example.hs:35:52-65
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 6:
+ source span: Example.hs:35:41-73
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 7:
+ source span: Example.hs:35:22-74
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 8:
+ source span: Example.hs:35:17-75
+ declaration path:
+ primes
+ isPrime
+ free variables: n
+ source breakpoint 9:
+ source span: Example.hs:32:14-34
+ declaration path: primes
+ free variables: isPrime
+ source breakpoint 10:
+ source span: Example.hs:32:10-34
+ declaration path: primes
+ free variables: isPrime
+ source breakpoint 11:
+ source span: Example.hs:38:13-25
+ declaration path: primesPtr
+ free variables: <none>
+ source breakpoint 12:
+ source span: Example.hs:23:30-70
+ declaration path:
+ fibonaccis
+ positiveFibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 13:
+ source span: Example.hs:23:26-70
+ declaration path:
+ fibonaccis
+ positiveFibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 14:
+ source span: Example.hs:20:14-35
+ declaration path: fibonaccis
+ free variables: positiveFibonaccis
+ source breakpoint 15:
+ source span: Example.hs:26:17-33
+ declaration path: fibonaccisPtr
+ free variables: <none>
+ bytecode breakpoints:
+ bytecode breakpoint 0:
+ type: StaticPtr [Natural]
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 11
+ bytecode breakpoint 1:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 9
+ bytecode breakpoint 2:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 10
+ bytecode breakpoint 3:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 2
+ bytecode breakpoint 4:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 3
+ bytecode breakpoint 5:
+ type: Natural -> Natural
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 4
+ bytecode breakpoint 6:
+ type: Natural -> Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 5
+ bytecode breakpoint 7:
+ type: [Natural]
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 6
+ bytecode breakpoint 8:
+ type: Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 7
+ bytecode breakpoint 9:
+ type: Bool
+ type variables: <none>
+ variables: %'Many n :: Natural
+ corresponding source breakpoint: 8
+ bytecode breakpoint 10:
+ type: StaticPtr [Natural]
+ type variables: <none>
+ variables: <none>
+ corresponding source breakpoint: 15
+ bytecode breakpoint 11:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 14
+ bytecode breakpoint 12:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 12
+ bytecode breakpoint 13:
+ type: [Natural]
+ type variables: <none>
+ variables: <unknown>
+ corresponding source breakpoint: 13
+ bytecode breakpoint 14:
+ type: a
+ type variables: a :: *
+ variables:
+ %'Many eta :: a
+ %'Many eta1 :: a
+ corresponding source breakpoint: 0
+ bytecode breakpoint 15:
+ type: Bool
+ type variables: a :: *
+ variables:
+ %'Many eta :: a
+ %'Many eta1 :: a
+ corresponding source breakpoint: 1
+static-pointer table entries:
+ @hash@: static_ptr
+ @hash@: static_ptr1
+HPC information: <none>
+
=====================================
testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
=====================================
@@ -0,0 +1,658 @@
+[1 of 1] Compiling Example ( Example.hs, Example.gbc )
+module: Example
+hash: @hash@
+objects:
+ object ‘primesPtr’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ named item ‘static_ptr1’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr1’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘primes’
+ object ‘primes2_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 3
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘$fEnumNatural’
+ named item ‘enumFrom’
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘isPrime_@name_suffix@’
+ named item ‘filter’
+ object ‘isPrime_@name_suffix@’:
+ arity: 1
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘primes’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ named item ‘$fIntegralInteger’
+ named item ‘$fNumNatural’
+ named item ‘(^)’
+ object ‘v1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 2
+ info table of ‘IS’
+ used items: <none>
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ named item ‘$fOrdNatural’
+ named item ‘(<=)’
+ object ‘v1_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: <none>
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘(.)’
+ named item ‘takeWhile’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘pap_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ named item ‘$fIntegralNatural’
+ named item ‘divides’
+ object ‘v1_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: <none>
+ object ‘pap_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘$fFoldableList’
+ named item ‘any’
+ named item ‘not’
+ object ‘primes’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ info table of ‘(:)’
+ used items:
+ named item ‘primes2_@name_suffix@’
+ named item ‘primes1_@name_suffix@’
+ object ‘primes1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 2
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘fibonaccisPtr’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ named item ‘static_ptr’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘fibonaccis’
+ object ‘positiveFibonaccis1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ info table of ‘(:)’
+ used items:
+ named item ‘positiveFibonaccis2_@name_suffix@’
+ named item ‘positiveFibonaccis_@name_suffix@’
+ object ‘positiveFibonaccis2_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘positiveFibonaccis2_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘positiveFibonaccis1_@name_suffix@’
+ object ‘positiveFibonaccis2_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘fibonaccis’
+ object ‘positiveFibonaccis2_sat_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘(+)’
+ named item ‘zipWith’
+ object ‘fibonaccis’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ info table of ‘(:)’
+ used items:
+ named item ‘fibonaccis2_@name_suffix@’
+ named item ‘fibonaccis1_@name_suffix@’
+ object ‘fibonaccis2_@name_suffix@’:
+ arity: 0
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: named item ‘positiveFibonaccis1_@name_suffix@’
+ object ‘positiveFibonaccis_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 1
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘fibonaccis1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 0
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ object ‘$dTypeable2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$dTypeable_@name_suffix@’
+ named item ‘$dTypeable1_@name_suffix@’
+ named item ‘mkTrAppChecked’
+ object ‘$dTypeable1_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcList’
+ named item ‘mkTrCon’
+ object ‘$dTypeable_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcNatural’
+ named item ‘mkTrCon’
+ object ‘cstrlen’:
+ arity: 2
+ literals: <none>
+ used items:
+ object ‘ds1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘strlen’
+ word 0
+ foreign function of type ‘Pointer -> UInt@word_size@’
+ used items:
+ object ‘wild_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘W@word_size@#’
+ used items: <none>
+ static-construction object ‘$tc'Nested’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Nested2_@name_suffix@’
+ named item ‘$krep17_@name_suffix@’
+ static-construction object ‘$tc'Nested2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Nested1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep17_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep16_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep16_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep15_@name_suffix@’
+ static-construction object ‘$krep15_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep4_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tc'PerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'PerfectTree2_@name_suffix@’
+ named item ‘$krep14_@name_suffix@’
+ static-construction object ‘$tc'PerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'PerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep14_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep13_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep12_@name_suffix@’
+ static-construction object ‘$krep12_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcPerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcPerfectTree2_@name_suffix@’
+ named item ‘krepStarArr’
+ static-construction object ‘$tcPerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcPerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$tc'Node’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Node2_@name_suffix@’
+ named item ‘$krep11_@name_suffix@’
+ static-construction object ‘$tc'Node2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Node1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep11_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ named item ‘$krep10_@name_suffix@’
+ static-construction object ‘$krep10_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘$krep9_@name_suffix@’
+ static-construction object ‘$krep9_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$tc'Leaf’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Leaf2_@name_suffix@’
+ named item ‘$krep8_@name_suffix@’
+ static-construction object ‘$tc'Leaf2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Leaf1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep8_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$krep7_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcBinTree’
+ named item ‘$krep6_@name_suffix@’
+ static-construction object ‘$krep6_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep5_@name_suffix@’
+ static-construction object ‘$krep5_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcBinTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcBinTree2_@name_suffix@’
+ named item ‘krepStarArrStarArr’
+ static-construction object ‘$tcBinTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcBinTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep4_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcTuple2’
+ named item ‘$krep3_@name_suffix@’
+ static-construction object ‘$krep3_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep2_@name_suffix@’
+ static-construction object ‘$krep2_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$krep1_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ static-construction object ‘$krep_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ static-construction object ‘$trModule’:
+ data constructor: Module
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$trModule2_@name_suffix@’
+ named item ‘$trModule4_@name_suffix@’
+ static-construction object ‘$trModule4_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule3_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$trModule2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule1_@name_suffix@’
+ used items: <none>
+ object ‘divides’:
+ arity: 3
+ literals: <none>
+ used items:
+ object ‘$dReal_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ label ‘_hpc_tickboxes_Example_hpc’
+ word 0
+ info table of ‘IS’
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘fromInteger’
+ named item ‘$p1Real’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 3
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: <none>
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals: label ‘_hpc_tickboxes_Example_hpc’
+ used items: <none>
+ named item ‘mod’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘(==)’
+ named item ‘$p1Ord’
+ named item ‘$p2Real’
+ named item ‘$p1Integral’
+ object ‘Node’:
+ arity: 3
+ literals: info table of ‘Node’
+ used items: <none>
+ object ‘Leaf’:
+ arity: 1
+ literals: info table of ‘Leaf’
+ used items: <none>
+ object ‘Nested’:
+ arity: 1
+ literals: info table of ‘Nested’
+ used items: <none>
+ object ‘PerfectTree’:
+ arity: 1
+ literals: info table of ‘PerfectTree’
+ used items: <none>
+data constructor info tables:
+ info table of ‘PerfectTree’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Nested’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Leaf’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Node’:
+ number of words for pointers: 3
+ number of words for non-pointers: 0
+top-level strings:
+ $tc'Nested1_@name_suffix@: "'Nested"
+ $tc'PerfectTree1_@name_suffix@: "'PerfectTree"
+ $tcPerfectTree1_@name_suffix@: "PerfectTree"
+ $tc'Node1_@name_suffix@: "'Node"
+ $tc'Leaf1_@name_suffix@: "'Leaf"
+ $tcBinTree1_@name_suffix@: "BinTree"
+ $trModule3_@name_suffix@: "Example"
+ $trModule1_@name_suffix@: "main"
+breakpoints: <none>
+static-pointer table entries:
+ @hash@: static_ptr
+ @hash@: static_ptr1
+HPC information:
+ hash: @hash@
+ tick box: _hpc_tickboxes_Example_hpc
+ number of ticks: 45
+
=====================================
testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout
=====================================
@@ -0,0 +1,593 @@
+[1 of 1] Compiling Example ( Example.hs, Example.gbc )
+module: Example
+hash: @hash@
+objects:
+ object ‘primesPtr’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘static_ptr1’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr1’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ named item ‘primes’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘primes2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘primes2_sat_@name_suffix@’
+ named item ‘isPrime_@name_suffix@’
+ named item ‘filter’
+ object ‘isPrime_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 2
+ info table of ‘IS’
+ used items:
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fIntegralInteger’
+ named item ‘$fNumNatural’
+ named item ‘(^)’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fOrdNatural’
+ named item ‘(<=)’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘(.)’
+ named item ‘primes’
+ named item ‘takeWhile’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ named item ‘$fIntegralNatural’
+ named item ‘divides’
+ named item ‘$fFoldableList’
+ named item ‘any’
+ named item ‘not’
+ static-construction object ‘primes’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘primes1_@name_suffix@’
+ named item ‘primes2_@name_suffix@’
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 3
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘$fEnumNatural’
+ named item ‘enumFrom’
+ object ‘primes1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘primes1_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘primes1_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 2
+ used items: <none>
+ object ‘fibonaccisPtr’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘static_ptr’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ named item ‘fibonaccis’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘positiveFibonaccis2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis1_@name_suffix@’
+ named item ‘fibonaccis’
+ named item ‘positiveFibonaccis2_sat_@name_suffix@’
+ named item ‘zipWith’
+ static-construction object ‘positiveFibonaccis1_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis_@name_suffix@’
+ named item ‘positiveFibonaccis2_@name_suffix@’
+ static-construction object ‘fibonaccis’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘fibonaccis1_@name_suffix@’
+ named item ‘positiveFibonaccis1_@name_suffix@’
+ object ‘positiveFibonaccis2_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘(+)’
+ object ‘positiveFibonaccis_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘positiveFibonaccis_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ object ‘fibonaccis1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘fibonaccis1_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘fibonaccis1_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ object ‘$dTypeable2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$dTypeable_@name_suffix@’
+ named item ‘$dTypeable1_@name_suffix@’
+ named item ‘mkTrAppChecked’
+ object ‘$dTypeable1_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcList’
+ named item ‘mkTrCon’
+ object ‘$dTypeable_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcNatural’
+ named item ‘mkTrCon’
+ object ‘cstrlen’:
+ arity: 2
+ literals: <none>
+ used items:
+ object ‘ds1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘strlen’
+ word 0
+ foreign function of type ‘Pointer -> UInt@word_size@’
+ used items:
+ object ‘wild_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘W@word_size@#’
+ used items: <none>
+ static-construction object ‘$tc'Nested’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Nested2_@name_suffix@’
+ named item ‘$krep17_@name_suffix@’
+ static-construction object ‘$tc'Nested2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Nested1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep17_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep16_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep16_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep15_@name_suffix@’
+ static-construction object ‘$krep15_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep4_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tc'PerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'PerfectTree2_@name_suffix@’
+ named item ‘$krep14_@name_suffix@’
+ static-construction object ‘$tc'PerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'PerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep14_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep13_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep12_@name_suffix@’
+ static-construction object ‘$krep12_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcPerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcPerfectTree2_@name_suffix@’
+ named item ‘krepStarArr’
+ static-construction object ‘$tcPerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcPerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$tc'Node’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Node2_@name_suffix@’
+ named item ‘$krep11_@name_suffix@’
+ static-construction object ‘$tc'Node2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Node1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep11_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ named item ‘$krep10_@name_suffix@’
+ static-construction object ‘$krep10_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘$krep9_@name_suffix@’
+ static-construction object ‘$krep9_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$tc'Leaf’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Leaf2_@name_suffix@’
+ named item ‘$krep8_@name_suffix@’
+ static-construction object ‘$tc'Leaf2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Leaf1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep8_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$krep7_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcBinTree’
+ named item ‘$krep6_@name_suffix@’
+ static-construction object ‘$krep6_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep5_@name_suffix@’
+ static-construction object ‘$krep5_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcBinTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcBinTree2_@name_suffix@’
+ named item ‘krepStarArrStarArr’
+ static-construction object ‘$tcBinTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcBinTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep4_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcTuple2’
+ named item ‘$krep3_@name_suffix@’
+ static-construction object ‘$krep3_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep2_@name_suffix@’
+ static-construction object ‘$krep2_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$krep1_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ static-construction object ‘$krep_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ static-construction object ‘$trModule’:
+ data constructor: Module
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$trModule2_@name_suffix@’
+ named item ‘$trModule4_@name_suffix@’
+ static-construction object ‘$trModule4_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule3_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$trModule2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule1_@name_suffix@’
+ used items: <none>
+ object ‘divides’:
+ arity: 3
+ literals: <none>
+ used items:
+ object ‘$dReal_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 0
+ info table of ‘IS’
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘fromInteger’
+ named item ‘$p1Real’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: named item ‘mod’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘(==)’
+ named item ‘$p1Ord’
+ named item ‘$p2Real’
+ named item ‘$p1Integral’
+ object ‘Node’:
+ arity: 3
+ literals: info table of ‘Node’
+ used items: <none>
+ object ‘Leaf’:
+ arity: 1
+ literals: info table of ‘Leaf’
+ used items: <none>
+ object ‘Nested’:
+ arity: 1
+ literals: info table of ‘Nested’
+ used items: <none>
+ object ‘PerfectTree’:
+ arity: 1
+ literals: info table of ‘PerfectTree’
+ used items: <none>
+data constructor info tables:
+ info table of ‘PerfectTree’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Nested’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Leaf’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Node’:
+ number of words for pointers: 3
+ number of words for non-pointers: 0
+top-level strings:
+ $tc'Nested1_@name_suffix@: "'Nested"
+ $tc'PerfectTree1_@name_suffix@: "'PerfectTree"
+ $tcPerfectTree1_@name_suffix@: "PerfectTree"
+ $tc'Node1_@name_suffix@: "'Node"
+ $tc'Leaf1_@name_suffix@: "'Leaf"
+ $tcBinTree1_@name_suffix@: "BinTree"
+ $trModule3_@name_suffix@: "Example"
+ $trModule1_@name_suffix@: "main"
+breakpoints: <none>
+static-pointer table entries:
+ @hash@: static_ptr
+ @hash@: static_ptr1
+HPC information: <none>
+
=====================================
testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs
=====================================
@@ -0,0 +1,597 @@
+[1 of 1] Compiling Example ( Example.hs, Example.gbc )
+module: Example
+hash: @hash@
+objects:
+ object ‘primesPtr’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘static_ptr1’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr1’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ named item ‘primes’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr1_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr1_sat_@name_suffix@’
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr1_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘primes2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘primes2_sat_@name_suffix@’
+ named item ‘isPrime_@name_suffix@’
+ named item ‘filter’
+ object ‘isPrime_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals: <none>
+ used items:
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 2
+ info table of ‘IS’
+ used items:
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fIntegralInteger’
+ named item ‘$fNumNatural’
+ named item ‘(^)’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ object ‘v_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fOrdNatural’
+ named item ‘(<=)’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: <none>
+ named item ‘(.)’
+ named item ‘primes’
+ named item ‘takeWhile’
+ object ‘isPrime_sat_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ named item ‘$fIntegralNatural’
+ named item ‘divides’
+ named item ‘$fFoldableList’
+ named item ‘any’
+ named item ‘not’
+ static-construction object ‘primes’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘primes1_@name_suffix@’
+ named item ‘primes2_@name_suffix@’
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘primes2_sat_@name_suffix@’:
+ arity: 0
+ literals:
+ word 3
+ info table of ‘IS’
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ named item ‘$fEnumNatural’
+ named item ‘enumFrom’
+ object ‘primes1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘primes1_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘primes1_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 2
+ used items: <none>
+ object ‘fibonaccisPtr’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘static_ptr’
+ named item ‘$dTypeable2_@name_suffix@’
+ named item ‘$fIsStaticStaticPtr’
+ static-construction object ‘static_ptr’:
+ data constructor: StaticPtr
+ lifted: yes
+ literals:
+ word @large_word@
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ named item ‘fibonaccis’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: StaticPtrInfo
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "main"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: top-level string "Example"
+ used items:
+ object ‘static_ptr_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘unpackCString#’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: (,)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘static_ptr_sat_@name_suffix@’
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ static-construction object ‘static_ptr_sat_@name_suffix@’:
+ data constructor: I#
+ lifted: yes
+ literals: word @large_word@
+ used items: <none>
+ object ‘positiveFibonaccis2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis1_@name_suffix@’
+ named item ‘fibonaccis’
+ named item ‘positiveFibonaccis2_sat_@name_suffix@’
+ named item ‘zipWith’
+ static-construction object ‘positiveFibonaccis1_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis_@name_suffix@’
+ named item ‘positiveFibonaccis2_@name_suffix@’
+ static-construction object ‘fibonaccis’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘fibonaccis1_@name_suffix@’
+ named item ‘positiveFibonaccis1_@name_suffix@’
+ object ‘positiveFibonaccis2_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$fNumNatural’
+ named item ‘(+)’
+ object ‘positiveFibonaccis_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘positiveFibonaccis_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘positiveFibonaccis_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ object ‘fibonaccis1_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘fibonaccis1_sat_@name_suffix@’
+ named item ‘$fNumNatural’
+ named item ‘fromInteger’
+ static-construction object ‘fibonaccis1_sat_@name_suffix@’:
+ data constructor: IS
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ object ‘$dTypeable2_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ named item ‘$dTypeable_@name_suffix@’
+ named item ‘$dTypeable1_@name_suffix@’
+ named item ‘mkTrAppChecked’
+ object ‘$dTypeable1_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcList’
+ named item ‘mkTrCon’
+ object ‘$dTypeable_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘[]’
+ used items:
+ named item ‘$tcNatural’
+ named item ‘mkTrCon’
+ object ‘cstrlen’:
+ arity: 2
+ literals: <none>
+ used items: named item ‘cstrlen1_@name_suffix@’
+ object ‘cstrlen1_@name_suffix@’:
+ arity: 2
+ literals: <none>
+ used items:
+ object ‘ds1_@name_suffix@’:
+ arity: 0
+ literals:
+ label ‘strlen’
+ word 0
+ foreign function of type ‘Pointer -> UInt@word_size@’
+ used items:
+ object ‘wild_@name_suffix@’:
+ arity: 0
+ literals: info table of ‘W@word_size@#’
+ used items: <none>
+ static-construction object ‘$tc'Nested’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Nested2_@name_suffix@’
+ named item ‘$krep17_@name_suffix@’
+ static-construction object ‘$tc'Nested2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Nested1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep17_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep16_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep16_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep15_@name_suffix@’
+ static-construction object ‘$krep15_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep4_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tc'PerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 1
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'PerfectTree2_@name_suffix@’
+ named item ‘$krep14_@name_suffix@’
+ static-construction object ‘$tc'PerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'PerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep14_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep13_@name_suffix@’
+ static-construction object ‘$krep13_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcPerfectTree’
+ named item ‘$krep12_@name_suffix@’
+ static-construction object ‘$krep12_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcPerfectTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcPerfectTree2_@name_suffix@’
+ named item ‘krepStarArr’
+ static-construction object ‘$tcPerfectTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcPerfectTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$tc'Node’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Node2_@name_suffix@’
+ named item ‘$krep11_@name_suffix@’
+ static-construction object ‘$tc'Node2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Node1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep11_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ named item ‘$krep10_@name_suffix@’
+ static-construction object ‘$krep10_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘$krep9_@name_suffix@’
+ static-construction object ‘$krep9_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$tc'Leaf’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 2
+ used items:
+ named item ‘$trModule’
+ named item ‘$tc'Leaf2_@name_suffix@’
+ named item ‘$krep8_@name_suffix@’
+ static-construction object ‘$tc'Leaf2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tc'Leaf1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep8_@name_suffix@’:
+ data constructor: KindRepFun
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep7_@name_suffix@’
+ static-construction object ‘$krep7_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcBinTree’
+ named item ‘$krep6_@name_suffix@’
+ static-construction object ‘$krep6_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep5_@name_suffix@’
+ static-construction object ‘$krep5_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$tcBinTree’:
+ data constructor: TyCon
+ lifted: yes
+ literals:
+ word @large_word@
+ word 0
+ used items:
+ named item ‘$trModule’
+ named item ‘$tcBinTree2_@name_suffix@’
+ named item ‘krepStarArrStarArr’
+ static-construction object ‘$tcBinTree2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$tcBinTree1_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$krep4_@name_suffix@’:
+ data constructor: KindRepTyConApp
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$tcTuple2’
+ named item ‘$krep3_@name_suffix@’
+ static-construction object ‘$krep3_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘$krep2_@name_suffix@’
+ static-construction object ‘$krep2_@name_suffix@’:
+ data constructor: (:)
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$krep1_@name_suffix@’
+ named item ‘[]’
+ static-construction object ‘$krep1_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 0
+ used items: <none>
+ static-construction object ‘$krep_@name_suffix@’:
+ data constructor: KindRepVar
+ lifted: yes
+ literals: word 1
+ used items: <none>
+ static-construction object ‘$trModule’:
+ data constructor: Module
+ lifted: yes
+ literals: <none>
+ used items:
+ named item ‘$trModule2_@name_suffix@’
+ named item ‘$trModule4_@name_suffix@’
+ static-construction object ‘$trModule4_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule3_@name_suffix@’
+ used items: <none>
+ static-construction object ‘$trModule2_@name_suffix@’:
+ data constructor: TrNameS
+ lifted: yes
+ literals: address ‘$trModule1_@name_suffix@’
+ used items: <none>
+ object ‘divides’:
+ arity: 3
+ literals: <none>
+ used items:
+ object ‘$dReal_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 1
+ literals:
+ word 0
+ info table of ‘IS’
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘fromInteger’
+ named item ‘$p1Real’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 3
+ literals: <none>
+ used items: named item ‘mod’
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items:
+ object ‘divides_sat_@name_suffix@’:
+ arity: 0
+ literals: <none>
+ used items: named item ‘(==)’
+ named item ‘$p1Ord’
+ named item ‘$p2Real’
+ named item ‘$p1Integral’
+ object ‘Node’:
+ arity: 3
+ literals: info table of ‘Node’
+ used items: <none>
+ object ‘Leaf’:
+ arity: 1
+ literals: info table of ‘Leaf’
+ used items: <none>
+ object ‘Nested’:
+ arity: 1
+ literals: info table of ‘Nested’
+ used items: <none>
+ object ‘PerfectTree’:
+ arity: 1
+ literals: info table of ‘PerfectTree’
+ used items: <none>
+data constructor info tables:
+ info table of ‘PerfectTree’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Nested’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Leaf’:
+ number of words for pointers: 1
+ number of words for non-pointers: 0
+ info table of ‘Node’:
+ number of words for pointers: 3
+ number of words for non-pointers: 0
+top-level strings:
+ $tc'Nested1_@name_suffix@: "'Nested"
+ $tc'PerfectTree1_@name_suffix@: "'PerfectTree"
+ $tcPerfectTree1_@name_suffix@: "PerfectTree"
+ $tc'Node1_@name_suffix@: "'Node"
+ $tc'Leaf1_@name_suffix@: "'Leaf"
+ $tcBinTree1_@name_suffix@: "BinTree"
+ $trModule3_@name_suffix@: "Example"
+ $trModule1_@name_suffix@: "main"
+breakpoints: <none>
+static-pointer table entries:
+ @hash@: static_ptr
+ @hash@: static_ptr1
+HPC information: <none>
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12f64118fe35d429b7fb83267070145…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12f64118fe35d429b7fb83267070145…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] 5 commits: loopImports: Don't dup ms_uid in summary imports
by Marge Bot (＠marge-bot) 15 Aug '26
by Marge Bot (＠marge-bot) 15 Aug '26
15 Aug '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c130188d by Rodrigo Mesquita at 2026-08-15T06:29:53-04:00
loopImports: Don't dup ms_uid in summary imports
We were writing the ms_unitid of the mod summary with every single
import of that module
That complicated the code (as though the UnitId in that list could ever
be something else) and also allocates unnecessarily per every mod
import. Very slight allocation decrease measured locally in a few tests:
(MultiComponentModulesRecomp: -0.06%; MultiComponentModulesRecomp100: -0.05%)
Purely a clean up.
- - - - -
c71166a8 by Rodrigo Mesquita at 2026-08-15T06:29:53-04:00
downsweep: make control flow simpler and cache correct
This refactor extracts the control flow of downsweep into a single
function `dfsBuild`, which takes care of iteratively expanding and
traversing all nodes of the in-construction module graph necessary to
build a full `ModuleGraph`.
There are three levels of caching going on, all of which are necessary
to make sure we don't do repeated work (notably, NEVER summarise the
same module twice).
1. `dfsBuild` accumulates the final module graph and never revisits the
same node of the module graph. Cache is keyed by the final
`ModuleGraph`s `NodeKey`s.
2. For Module A in home-unit u1, each import in the list of imports
needs to be *found* (call to `findImportedModuleWithIsBoot`): at this
point, we only have the `ModuleName` of the import, not the `Module`.
This *finding* is somewhat expensive, so we cache it as well
(`ImportsCache`). The cache key is the home-unit to which the module
belongs~[1], the import package qualifier, and the ModuleName.
[1] Different home-units will have different package flags, which means
potentially different `Module` resolution for the same `ModuleName`.
3. The most expensive operation we want to avoid is summarising a
`Module` into a `ModSummary`, which notably involves parsing the
module header from scratch.
The third cache, in essence, maps a `Module` to its `ModSummary`
(named `ModSummaryCache`). This cache upholds the invariant: we NEVER
summarise the same module twice. In practice, the cache key is the
Module's UnitId and the Source path; the reason is we need to
distinguish between `.hs` and `.hs-boot` files, as their summaries
will differ.
Note that (2) can't guarantee this alone: Two ModuleName imports in
separate units can (and likely do) map to the same `Module`.
Note that the previous implementation failed to achieve the
no-duplicate-work summarisation invariant, and we ended up doing a
quadratic amount of processing in scenarios like test
`MultiComponentModules100`.
See also Note [Downsweep Control Flow and Caching]
Fixes #27461
Perf changes:
MultiComponentModules(normal) ghc/alloc 2,097,389,264 1,992,186,736 -5.0% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,173,770 21,293,867,360 -12.4% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,761,394 498,543,984 -17.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,968,240 8,895,404,864 -25.2% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
ebc4047b by Rodrigo Mesquita at 2026-08-15T06:29:53-04:00
implicitRequirementsShallow can never reach HoleUnit
findImportedModule will never return `HoleUnit` for a `ModuleName`
(a `HoleUnit` can only be found as a signature instantiation, never as a
directly *imported* thing)
Therefore, we can drop `[ModuleName]` returned by
`implicitRequirementsShallow`, which makes many things dead code.
Namely, the call to `implicitRequirementsShallow` from
GHC.Driver.Downsweep which was a performance bottleneck (for doing lots
of duplicate work in findImportedModule) is now entirely gone.
Fixes #27053
In an MR with this patch and the downsweep refactor (previous commit), CI says:
MultiComponentModules(normal) ghc/alloc 2,097,396,728 1,943,662,304 -7.3% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,182,136 17,227,574,440 -29.1% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,769,518 449,973,656 -25.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,976,408 4,828,894,160 -59.4% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
85a6ab01 by Rodrigo Mesquita at 2026-08-15T06:29:53-04:00
downsweep: Cache negative results
When traversing a module graph structure, a uniquely identified node
should always expand to the same thing.
I don't see how visiting the same node which failed to be expanded a
first time would ever successfully expand the second time we try to
expand it (eg. when coming from a different edge to it -- it is still
the same node!). The node expansion is local, based just based on the
node itself, not on the path to get there.
Therefore, this patch removes the weird behavior and commentary of
`dfsBuild` wrt to `Nothing` not being cached and being potentially
expanded a second time around to something different, which was
misleading and, ultimately, incorrect.
Now, we have a `MGRes`, which is more explicit about a node being
Skipped just being a node that is ignored whenever it is found (and that
skip is cached) -- and we may want to do this due to failures or due to
just trying nodes which might not work on purpose, like hs-boots.
We uniformly cache positive and negative results and remove the
assumption that there might be an ordering in which the same node
visited at a later time might be expanded differently.
This makes it possible to traverse the module nodes in parallel without
a change in behavior, since there's no longer a hidden ordering
requirement.
- - - - -
56747c3f by Rodrigo Mesquita at 2026-08-15T06:29:53-04:00
Organize and clean-up GHC.Driver.Downsweep
Simply some cosmetic changes, moving definitions around to structure the
module better into its relevant sections
(In go (ns ++ ss), it's not a problem to use ++ because it's a good
producer and we won't have to append fully before processing the next
item in go)
- - - - -
20 changed files:
- + changelog.d/downsweep-refactor
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Unit/Env.hs
- + testsuite/tests/driver/T27461/Main1.hs
- + testsuite/tests/driver/T27461/Main2.hs
- + testsuite/tests/driver/T27461/Makefile
- + testsuite/tests/driver/T27461/T27461a.stderr
- + testsuite/tests/driver/T27461/T27461b.script
- + testsuite/tests/driver/T27461/T27461b.stderr
- + testsuite/tests/driver/T27461/T27461b.stdout
- + testsuite/tests/driver/T27461/all.T
- + testsuite/tests/driver/T27461/src/Bar.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- testsuite/tests/splice-imports/SI35.hs
- utils/check-ppr/Main.hs
Changes:
=====================================
changelog.d/downsweep-refactor
=====================================
@@ -0,0 +1,9 @@
+section: compiler
+synopsis: Significantly improve the performance of downsweep
+issues: #27461
+mrs: !16330
+description: {
+ Rewrite the downsweep pass to make the control flow clearer and fix the
+ caching strategy. Allocations during downsweep in multi-home-unit-heavy and
+ module-heavy tests are reduced by -30% to -60%
+}
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -896,7 +896,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
- (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env textual_imports
+ inst_deps <- liftIO $ implicitRequirementsShallow hsc_env textual_imports
-- So that Finder can find it, even though it doesn't exist...
this_mod <- liftIO $ do
@@ -916,8 +916,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- We have to do something special here:
-- due to merging, requirements may end up with
-- extra imports
- ++ (generatedImport FromBackpackSig . noLoc <$> extra_sig_imports)
- ++ (generatedImport FromBackpackSig . noLoc <$> implicit_sigs),
+ ++ (generatedImport FromBackpackSig . noLoc <$> extra_sig_imports),
-- This is our hack to get the parse tree to the right spot
ms_parsed_mod = Just (HsParsedModule {
hpm_module = hsmod,
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -5,6 +5,8 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
+
+-- | See Note [The ModuleGraph]
module GHC.Driver.Downsweep
( downsweep
, downsweepThunk
@@ -90,7 +92,7 @@ import GHC.Unit.Module.Deps
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Module.Stage
-import Data.Either ( rights, partitionEithers, lefts )
+import Data.Either ( partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -110,19 +112,39 @@ import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
import Control.Monad.Trans.Class
import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.IORef
+import qualified Data.List.NonEmpty as NE
{-
-Note [Downsweep and the ModuleGraph]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [The ModuleGraph]
+~~~~~~~~~~~~~~~~~~~~~~
+The 'ModuleGraph' stores the relationship between all the modules, units, and
+instantiations in the current session, allowing e.g. to answer questions about
+the transitive closure of the imports.
+
+* A /node/ of the `ModuleGraph`, of type `ModuleGraphNode`, corresponds
+ 1-1 with a home-package module of source code, N.hs or N.hs-boot.
+ See the haddocks of `ModuleGraphNode`.
+
+ The `ModuleNodeInfo` field of the `ModuleGraphNode` contains a `ModSummary`
+ that in turn describes where the source file is (its `ModLocation`), when it
+ was read, its contents etc. See Note [Module Types in the ModuleGraph].
-The ModuleGraph stores the relationship between all the modules, units, and
-instantiations in the current session.
+ Each node has a distinct `NodeKey` (an instance of Ord); the function
+ mkNodeKey :: ModuleGraphNode -> NodeKey
+ get the `NodeKey` of a node
-When we do downsweep, we build up a new ModuleGraph, starting from the root
-modules. By following all the dependencies we construct a graph which allows
-us to answer questions about the transitive closure of the imports.
+* An /edge/ of the `ModuleGraph` from N1 to N2 typically corresponds to a
+ direct import of module N2 in module N1: one edge for each import.
+ Imports of modules from non-home-packages are featured in the `ModuleGraph`
+ as `UnitNode`s, or `InstantiationNodes` when backpack is involved.
-The module graph is accessible in the HscEnv.
+ Each node contains a list of all its out-edges or, more precisely, of the
+ `NodeKey`s of its direct dependencies.
+
+Because a node in the `ModuleGraph` describes the precise dependencies of the module, each node has its
+own `UnitId`. Remember, a single module can be compiled against many different versions of a library; but
+once we fix its dependencies we can compile it, and give it a `UnitId`. See Note [About units] in GHC.Unit.
When is this graph constructed?
@@ -139,17 +161,54 @@ When is this graph constructed?
The result is having a uniform graph available for the whole compilation pipeline.
--}
+See Note [Downsweep Control Flow and Caching] for implementation details of
+the algorithm and caching.
+
+Note [Downsweep: building and maintaining the module graph]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The module graph can be built from scratch by starting from a set of /root nodes/
+and exploring their dependencies. This is done by `GHC.Driver.Downsweep.downsweep`.
+
+Another scenario is when we already /have/ a `ModuleGraph` and want to update
+it (e.g. to reflect any file-system changes that have taken place since the
+last invocation of `downsweep`) or augment it by exploring new roots (e.g. for
+incrementally constructing a ModuleGraph using the GHC API; See #27054). So
+`downsweep` takes a `Maybe ModuleGraph` as one of its arguments.
--- This caches the answer to the question, if we are in this unit, what does
--- an import of this module mean.
-type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]
+Downsweep iteratively *expands* each so-called 'DownsweepNode' into a list of
+its dependencies, and recursively traverses all reachable nodes in a
+depth-first order using 'dfsBuild'. A 'DownsweepNode' is *expanded* by 'dsNodeExpand':
-moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
-moduleGraphNodeMap graph
- = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
+ dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+
+Most notably:
+
+ - 'DSMod' (Module-based) nodes can be expanded by preprocessing and
+ parsing the module header, then listing the imports (direct and SOURCE imports)
+ (see 'expandModuleSummary' and 'expandFixedModuleNode')
+
+ - 'DSUnit' is expanded by finding the unit dependencies of that unit by id
+ (see 'expandUnitNode').
+
+Besides its dependencies, expanding a 'DownsweepNode' produces a
+'ModuleGraphNode'. The final 'ModuleGraph' is constructed from the list of
+'ModuleGraphNode's accumulated by expanding all reachable 'DownsweepNode's.
+
+A 'ModuleGraphNode' is essentially the resolved version of 'DownsweepNode':
+it records the payload (e.g. a Module) *and* its dependencies, unlike
+'DownsweepNode' which has the just the payload that is used as a seed (and
+potentially some context information, like the current home-unit)
+
+TL;DR: We recursively traverse 'DownsweepNodes' to discover and build the 'ModuleGraph'.
+
+See also Note [Downsweep Control Flow and Caching] for implementation details.
+See Note [The ModuleGraph] for an overview when we do downsweep.
+-}
-----------------------------------------------------------------------------
+-- * Top-level entry to downsweep
+-----------------------------------------------------------------------------
+
--
-- | Downsweep (dependency analysis) for --make mode
--
@@ -161,7 +220,7 @@ moduleGraphNodeMap graph
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
--- Downsweeping can start from scratch for from a given module graph. In the
+-- Downsweeping can start from scratch or from a given module graph. In the
-- latter case, the given graph is fully included in the resulting graph, even
-- if parts of it are not reachable from any of the given roots. When an import
-- is processed, the source of the imported module is not consulted if this
@@ -177,6 +236,8 @@ moduleGraphNodeMap graph
--
-- It will also turn on code generation for any modules that need it by calling
-- 'enableCodeGenForTH'.
+--
+-- See also Note [The ModuleGraph]
downsweep :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
@@ -194,8 +255,11 @@ downsweep :: HscEnv
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do
- n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
- (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary
+ n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
+ summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld)))
+ imps_cache <- newIORef Map.empty
+ (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg
+ (getRootSummary excl_mods summ_cache imps_cache)
let closure_errs = checkHomeUnitsClosed unit_env
unit_env = hsc_unit_env hsc_env
@@ -203,9 +267,13 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
case all_errs of
[] -> do
- (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
+ (downsweep_errs, downsweep_nodes) <-
+ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph
+ excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
- let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
+ let (other_errs, unit_nodes) = partitionEithers $
+ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) []
+ (hsc_HUG hsc_env)
let all_nodes = downsweep_nodes ++ unit_nodes
let all_errs = downsweep_errs ++ other_errs
@@ -221,22 +289,40 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
return (all_errs, th_configured_nodes)
_ -> return (all_errs, emptyMG)
where
- summary = getRootSummary excl_mods old_summary_map
-
- -- A cache from file paths to the already summarised modules. The same file
- -- can be used in multiple units so the map is also keyed by which unit the
- -- file was used in.
- -- Reuse these if we can because the most expensive part of downsweep is
- -- reading the headers.
- old_summary_map :: M.Map (UnitId, OsPath) ModSummary
- old_summary_map =
- M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries]
-
-- Dependencies arising on a unit (backpack and module linking deps)
unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
unitModuleNodes summaries uid hue =
maybeToList (linkNodes summaries uid hue)
+ -- The linking plan for each module. If we need to do linking for a home unit
+ -- then this function returns a graph node which depends on all the modules in the home unit.
+
+ -- At the moment nothing can depend on these LinkNodes.
+ linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
+ linkNodes summaries uid hue =
+ let dflags = homeUnitEnv_dflags hue
+ ofile = outputFile_ dflags
+
+ unit_nodes :: [NodeKey]
+ unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ no_hs_main = gopt Opt_NoHsMain dflags
+
+ main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
+
+ do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
+
+ in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
+ Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
+ -- This should be an error, not a warning (#10895).
+ | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
+ | otherwise -> Nothing
+
-- | Calculate the module graph starting from a single ModSummary. The result is a
-- thunk, which when forced will perform the downsweep. This is useful in oneshot
-- mode where the module graph may never be needed.
@@ -244,7 +330,9 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."
- ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
+ summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)])
+ imps <- newIORef mempty
+ ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
let dflags = hsc_dflags hsc_env
liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
(initPrintConfig dflags)
@@ -268,80 +356,19 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")
let imps = ic_imports (hsc_IC hsc_env)
- let interactive_mn = icInteractiveModule ic
- -- No sensible value for ModLocation.. if you hit this panic then you probably
- -- need to add proper support for modules without any source files to the driver.
- let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)
- let key = moduleToMnk interactive_mn NotBoot
- let node_type = ModuleNodeFixed key ml
+ interactive_mn = icInteractiveModule ic
-- The existing nodes in the module graph. This will be populated when GHCi runs
-- :load. Any home package modules need to already be in here.
- let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]
-
- (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes
- let interactive_node = ModuleNode module_edges node_type
-
- let all_nodes = M.elems graph
- return $ mkModuleGraph (interactive_node : all_nodes)
-
- where
- --
- mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, UnresolvedImport PkgQual)
- -- A simple edge to a module from the same home unit
- mkEdge (IIModule n) =
- let
- mod_node_key = ModNodeKeyWithUid
- { mnkModuleName = GWIB (moduleName n) NotBoot
- , mnkUnitId =
- -- 'toUnitId' is safe here, as we can't import modules that
- -- don't have a 'UnitId'.
- toUnitId (moduleUnit n)
- }
- mod_node_edge =
- ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key)
- in Left mod_node_edge
- -- A complete import statement
- mkEdge (IIDecl i) =
- let unitId = homeUnitId $ hsc_home_unit hsc_env
- imp = rnUnresolvedImportPkgQual (renameRawPkgQual (hsc_unit_env hsc_env))
- (mkUnresolvedImport i)
- in Right (unitId, imp)
-
-loopFromInteractive :: HscEnv
- -> [Either ModuleNodeEdge (UnitId, UnresolvedImport PkgQual)]
- -> M.Map NodeKey ModuleGraphNode
- -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
-loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
-loopFromInteractive hsc_env (edge:edges) cached_nodes =
- case edge of
- Left edge -> do
- (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
- return (edge : edges, cached_nodes')
- Right (unitId, imp@(UnresolvedImport { ui_level = lvl, ui_boot = is_boot })) -> do
- let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
- let k _ loc mod =
- let key = moduleToMnk mod is_boot
- in return $ FoundHome (ModuleNodeFixed key loc)
- found <- liftIO $ summariseModuleDispatch k hsc_env home_unit imp []
- case found of
- -- Case 1: Home modules have to already be in the cache.
- FoundHome (ModuleNodeFixed mod _) -> do
- let edge = ModuleNodeEdge lvl (NodeKey_Module mod)
- -- Note: Does not perform any further downsweep as the module must already be in the cache.
- (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
- return (edge : edges, cached_nodes')
- -- Case 2: External units may not be in the cache, if we haven't already initialised the
- -- module graph. We can construct the module graph for those here by calling loopUnit.
- External uid -> do
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- cached_nodes' = loopUnit hsc_env' cached_nodes [uid]
- edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)
- (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'
- return (edge : edges, cached_nodes')
- -- And if it's not found.. just carry on and hope.
- _ -> loopFromInteractive hsc_env edges cached_nodes
+ let cached_nodes = Map.fromList [ (mkNodeKey n, NSuccess n) | n <- mg_mss (hsc_mod_graph hsc_env) ]
+ summ_cache <- newIORef mempty
+ imps_cache <- newIORef mempty
+ let env = DownsweepEnv hsc_env DownsweepUseFixed{-or DownsweepUseCompile?-} summ_cache imps_cache []
+ graph <- runDownsweepM env do
+ loopFromInteractive cached_nodes interactive_mn imps
+ let all_nodes = [s | NSuccess s <- M.elems graph ]
+ return $ mkModuleGraph all_nodes
-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
@@ -370,7 +397,9 @@ downsweepInstalledModules hsc_env mods = do
_ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i
nodes <- mapM process installed_mods
- (errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed nodes external_uids
+ summs <- newIORef mempty
+ imps <- newIORef mempty
+ (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids
-- Similarly here, we should really not get any errors, but print them out if we do.
let dflags = hsc_dflags hsc_env
@@ -381,7 +410,35 @@ downsweepInstalledModules hsc_env mods = do
return (mkModuleGraph mg)
+-----------------------------------------------------------------------------
+-- * Orchestrator: downsweepFromRootNodes
+-----------------------------------------------------------------------------
+
+type ModSummaryCache = IORef ModSummaryCacheMap
+type ImportsCache = IORef ImportsCacheMap
+-- | A cache from file paths to the already summarised modules. The same file
+-- can be used in multiple units so the map is actually also keyed by which
+-- unit the file was used in.
+--
+-- We want to reuse ModSummaries as far as possible because the most expensive
+-- part of downsweep is reading and parsing the headers.
+--
+-- See Note [Downsweep Control Flow and Caching]
+type ModSummaryCacheMap
+ -- The cache can't be keyed by 'Module' because that isn't sufficient to
+ -- distinguish .hs from .hs-boot files. Use path+unit instead.
+ = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
+
+-- | A 'ModSummary's provenance during downsweep: an old previously constructed
+-- ModSummary, that might be potentially outdated, or a freshly constructed one
+-- during this downsweep which is certainly up to date?
+data SummProvenance
+ -- | Constructed during this downsweep: trivially up to date
+ = SummFresh
+ -- | Carried over from a previous run: may be stale, must be hash-checked
+ -- (and considered by -fforce-recomp)
+ | SummOld
-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
-- by --make mode, and fixed nodes by oneshot mode.
@@ -394,7 +451,8 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed
-- This function will start at the given roots, and traverse downwards to find
-- all the dependencies, all the way to the leaf units.
downsweepFromRootNodes :: HscEnv
- -> M.Map (UnitId, OsPath) ModSummary
+ -> ModSummaryCache
+ -> ImportsCache
-> Maybe ModuleGraph
-> [ModuleName]
-> Bool
@@ -402,278 +460,368 @@ downsweepFromRootNodes :: HscEnv
-> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
-> [UnitId] -- ^ The starting units
-> IO ([DriverMessages], [ModuleGraphNode])
-downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids
- = do
- let root_map = mkRootMap root_nodes
- checkDuplicates root_map
- let env = DownsweepEnv hsc_env mode old_summaries excl_mods
- (deps', map0) <- runDownsweepM env $ do
- let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
- (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map)
- let all_deps = loopUnit hsc_env module_deps root_uids
- let all_instantiations = getHomeUnitInstantiations hsc_env
- deps' <- loopInstantiations all_instantiations all_deps
- return (deps', map0)
-
-
- let downsweep_errs = lefts $ concat $ M.elems map0
- downsweep_nodes = M.elems deps'
-
- return (downsweep_errs, downsweep_nodes)
- where
- getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
- getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)
-
- -- In a root module, the filename is allowed to diverge from the module
- -- name, so we have to check that there aren't multiple root files
- -- defining the same module (otherwise the duplicates will be silently
- -- ignored, leading to confusing behaviour).
- checkDuplicates
- :: DownsweepCache
- -> IO ()
- checkDuplicates root_map
- | not allow_dup_roots
- , dup_root:_ <- dup_roots = liftIO $ multiRootsErr sec dup_root
- | otherwise = pure ()
- where
- sec = initSourceErrorContext (hsc_dflags hsc_env)
- dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2
- dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
-
-
-calcDeps :: ModSummary -> [(UnitId, UnresolvedImport PkgQual)]
-calcDeps ms =
- -- Add a dependency on the HsBoot file if it exists
- -- This gets passed to the loopImports function which just ignores it if it
- -- can't be found.
- [ (ms_unitid ms, self_boot) | NotBoot <- [isBootSummary ms] ] ++
- [ (ms_unitid ms, e) | e <- ms_imps ms ]
+downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do
+ when (not allow_dup_roots) $
+ case root_duplicates of
+ [] -> return ()
+ (dup_root:_) -> multiRootsErr sec dup_root
+ modifyImpsCache imps_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache
+ let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods
+ deps' <- runDownsweepM env $ do
+ let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
+ module_deps <- loopModuleNodeInfos base_nodes root_nodes
+ all_deps <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids
+ deps' <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env)
+ return deps'
+ f_cache <- readIORef summ_cache
+ let downsweep_errs = lefts (M.elems f_cache)
+ downsweep_nodes = [ s | NSuccess s <- M.elems deps' ]
+
+ return (downsweep_errs, downsweep_nodes)
where
- self_boot = (generatedImport FromSelfBoot (noLoc (ms_mod_name ms)))
- { ui_boot = IsBoot }
-
+ getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
+ getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey
+ (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)
+
+ -- In a root module, the filename is allowed to diverge from the module
+ -- name, so we have to check that there aren't multiple root files
+ -- defining the same module (otherwise the duplicates will be silently
+ -- ignored, leading to confusing behaviour).
+ root_duplicates :: [NE.NonEmpty ModuleNodeInfo]
+ root_duplicates = mapMaybe takes2 (M.elems root_map)
+ where
+ takes2 (a:as@(_:_)) = Just (a NE.:| as) -- Each at least of length 2
+ takes2 _ = Nothing
+
+ root_map = Map.fromListWith (flip (++))
+ [ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s])
+ | s <- root_nodes ]
+
+ moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey (NodeRes ModuleGraphNode)
+ moduleGraphNodeMap graph
+ = M.fromList [(mkNodeKey node, NSuccess node) | node <- mgModSummaries' graph]
+
+ sec = initSourceErrorContext (hsc_dflags hsc_env)
+
+--------------------------------------------------------------------------------
+-- ** 'DownsweepM'
+--------------------------------------------------------------------------------
type DownsweepM a = ReaderT DownsweepEnv IO a
data DownsweepEnv = DownsweepEnv {
downsweep_hsc_env :: HscEnv
, _downsweep_mode :: DownsweepMode
- , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary
+ , _downsweep_summaries_cache :: ModSummaryCache
+ , downsweep_imports_cache :: ImportsCache
, _downsweep_excl_mods :: [ModuleName]
}
+mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
+mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs
+
+addModSummaryCache :: ModSummary -> SummProvenance -> ModSummaryCacheMap -> ModSummaryCacheMap
+addModSummaryCache ms pr fe = upd_fe fe
+ where
+ upd_fe fe
+ | Just src_fn_os <- ml_hs_file_ospath (ms_location ms)
+ = M.insert (ms_unitid ms, src_fn_os) (Right (ms, pr)) fe
+ | otherwise = fe
+
+modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO ()
+modifyImpsCache :: ImportsCache -> (ImportsCacheMap -> ImportsCacheMap) -> IO ()
+modifySummCache r f = atomicModifyIORef' r (\c -> (f c, ()))
+modifyImpsCache r f = atomicModifyIORef' r (\c -> (f c, ()))
+
+-- | A cache from a module import (in given home unit context, with a package
+-- qualifier, and the imported module name (with or without SOURCE)) to the
+-- result of summarising that import (see 'summariseModuleDispatch').
+--
+-- See Note [Downsweep Control Flow and Caching]
+type ImportsCacheMap
+ = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) SummariseResult
+
+-- | Populate the 'ImportsCacheMap' with the root modules.
+mkRootMap :: [ModuleNodeInfo] -> ImportsCacheMap
+mkRootMap summaries = Map.fromList
+ [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), FoundHome s) | s <- summaries ]
+
runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
runDownsweepM env act = runReaderT act env
-
-loopInstantiations :: [(UnitId, InstantiatedUnit)]
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopInstantiations [] done = pure done
-loopInstantiations ((home_uid, iud) :xs) done = do
- hsc_env <- asks downsweep_hsc_env
- let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
- payload = InstantiationNode home_uid iud
- loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
-
-
--- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
-loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode,
- DownsweepCache)
- -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
-loopSummaries [] done = pure done
-loopSummaries (ms:next) (done, summarised)
- | Just {} <- M.lookup k done
- = loopSummaries next (done, summarised)
- -- Didn't work out what the imports mean yet, now do that.
- | otherwise = do
- (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
+loopDownsweepNodes :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [DownsweepNode] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopModuleNodeInfos :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopUnits :: M.Map NodeKey (NodeRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopInstantiations :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopFromInteractive :: M.Map NodeKey (NodeRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
+loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
+loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod
+loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
+loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst)
+loopFromInteractive base_map m = loopDownsweepNodes base_map . (:[]) . DSInteractive m
+
+--------------------------------------------------------------------------------
+-- * Expanding 'DownsweepNode's into payload and node dependencies
+--------------------------------------------------------------------------------
+
+-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
+-- encompasses the types of nodes we can iteratively expand to construct the
+-- full module graph. See 'loopDownsweepNodes'.
+--
+-- See Note [Downsweep Control Flow and Caching]
+data DownsweepNode
+ -- | A module node to expand
+ = DSMod ModuleNodeInfo
+ -- | A unit node to expand
+ | DSUnit
+ { home_context_uid :: UnitId
+ -- ^ The home unit which introduced the dependency on this 'node_uid'. This
+ -- 'node_uid' can only be expanded in the context ('HscEnv') where
+ -- 'home_context_uid' is the active home unit, to make sure the package flags
+ -- are the ones attributed to the home package that introduced this node.
+ , node_uid :: UnitId
+ -- ^ The unit node to expand
+ }
+ -- | FIXME: document the meaning of 'DSInst'
+ | DSInst
+ { home_context_uid :: UnitId
+ , instantiated_ud :: InstantiatedUnit
+ }
+ -- | A group of interactive imports from this interactive Module
+ | DSInteractive Module [InteractiveImport]
+
+instance Outputable DownsweepNode where
+ ppr = \case
+ DSMod (ModuleNodeCompile ms) -> text "DSModC" <+> ppr (ms_mod_name ms)
+ DSMod (ModuleNodeFixed key _) -> text "DSModF" <+> ppr key
+ DSUnit{node_uid} -> text "DSUnit" <+> ppr node_uid
+ DSInst{instantiated_ud} -> text "DSInst" <+> ppr instantiated_ud
+ DSInteractive mod ii -> text "DSInteractive" <+> ppr mod <+> ppr ii
+
+-- | They key by which to cache previously visited 'DownsweepNode's
+dsNodeInfoKey :: DownsweepNode -> NodeKey
+dsNodeInfoKey = \case
+ DSMod (ModuleNodeCompile ms) -> NodeKey_Module (msKey ms)
+ DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod
+ DSUnit{node_uid} -> NodeKey_ExternalUnit node_uid
+ DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud
+ DSInteractive mod _imps -> NodeKey_Module $ moduleToMnk mod NotBoot
+
+dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+dsNodeExpand = \case
+ DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms
+ DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc
+ DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid
+ DSInst{ instantiated_ud
+ , home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid
+ DSInteractive imod iis -> expandInteractiveImports imod iis
+
+expandModuleSummary :: ModSummary -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
+ hsc_env <- asks downsweep_hsc_env
+ let home_uid = ms_unitid ms
+ home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms)
+
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ boot_todo <-
+ if | HsBootFile <- ms_hsc_src ms
+ -> do
+ r <- downsweepSummarise home_unit (generatedImport FromSelfBoot (noLoc (ms_mod_name ms))) Nothing
+ case r of
+ FoundHome s -> pure [DSMod s]
+ _ -> pure []
+ | otherwise -> pure []
+
+ return $ NSuccess
+ ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
+ , boot_todo ++ concat todo
+ )
where
- k = NodeKey_Module (msKey ms)
-
- hs_file_for_boot
- | HsBootFile <- ms_hsc_src ms
- = Just ( ms_unitid ms
- , generatedImport FromSelfBoot (noLoc (ms_mod_name ms)) )
- | otherwise
- = Nothing
-
-loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
-loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
-
-loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
-loopModuleNodeInfo mod_node_info (done, summarised) = do
- case mod_node_info of
- ModuleNodeCompile ms -> do
- loopSummaries [ms] (done, summarised)
- ModuleNodeFixed mod ml -> do
- done' <- loopFixedModule mod ml done
- return (done', summarised)
-
--- NB: loopFixedModule does not take a downsweep cache, because if you
--- ever reach a Fixed node, everything under that also must be fixed.
-loopFixedModule :: ModNodeKeyWithUid -> ModLocation
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedModule key loc done = do
- let nk = NodeKey_Module key
- hsc_env <- asks downsweep_hsc_env
- case M.lookup nk done of
- Just {} -> return done
- Nothing -> do
- -- MP: TODO, we should just read the dependency info from the interface rather than either
- -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
- -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
- read_result <- liftIO $
- -- 1. Check if the interface is already loaded into the EPS by some other
- -- part of the compiler.
- lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
- Just iface -> return (M.Succeeded iface)
- Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
- case read_result of
- M.Succeeded iface -> do
- -- Computer information about this node
- let node_deps = ifaceDeps (mi_deps iface)
- edges = map mkFixedEdge node_deps
- node = ModuleNode edges (ModuleNodeFixed key loc)
- foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
- -- Ignore any failure, we might try to read a .hi-boot file for
- -- example, even if there is not one.
- M.Failed {} ->
- return done
-
-loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedNodeKey _ done (Left key) = do
- loopFixedImports [key] done
-loopFixedNodeKey home_uid done (Right uid) = do
- -- Set active unit so that looking loopUnit finds the correct
- -- -package flags in the unit state.
- hsc_env <- asks downsweep_hsc_env
- let hsc_env' = hscSetActiveUnitId home_uid hsc_env
- return $ loopUnit hsc_env' done [uid]
-
-mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
-mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
-mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
-
-ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
-ifaceDeps deps =
- [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
- | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
- ] ++
- [ Right (tcImportLevel lvl, uid)
- | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
- ]
-
--- Like loopImports, but we already know exactly which module we are looking for.
-loopFixedImports :: [ModNodeKeyWithUid]
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedImports [] done = pure done
-loopFixedImports (key:keys) done = do
- let nk = NodeKey_Module key
- hsc_env <- asks downsweep_hsc_env
- case M.lookup nk done of
- Just {} -> loopFixedImports keys done
- Nothing -> do
+ expandModImport home_uid home_unit imp = do
+ let UnresolvedImport { ui_level = lvl } = imp
+ mb_s <- downsweepSummarise home_unit imp Nothing
+ case mb_s of
+ NotThere -> return
+ ( Nothing, [] )
+ External uid -> return
+ ( Just $ mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+ -- Specify home unit, as each unit might have a different visible package database.
+ , [DSUnit{node_uid = uid, home_context_uid = home_uid}] )
+ FoundInstantiation iud -> return
+ ( Just (mkModuleEdge lvl (NodeKey_Unit iud)), [] )
+ FoundHomeWithError (_uid, _e) -> return
+ ( Nothing, [] )
+ -- the error @e@ is already stored in the summarisation cache,
+ -- (the IORef in DownsweepM) and will get reported at the end.
+ FoundHome s -> return
+ -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
+ ( Just $ mkModuleEdge lvl (NodeKey_Module (mnKey s))
+ , [DSMod s] )
+
+ calcDeps :: ModSummary -> [UnresolvedImport PkgQual]
+ calcDeps ms =
+ -- Add a dependency on the HsBoot file if it exists
+ -- This gets passed to the loopImports function which just ignores it if it
+ -- can't be found.
+ [ self_boot | NotBoot <- [isBootSummary ms] ] ++
+ [ e | e <- ms_imps ms ]
+ where
+ self_boot = (generatedImport FromSelfBoot (noLoc (ms_mod_name ms)))
+ { ui_boot = IsBoot }
+
+-- | Expand a 'ModuleNodeFixed' node
+-- NB: If you ever reach a Fixed node, everything under that also must be fixed.
+expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+expandFixedModuleNode key loc = do
+ hsc_env <- asks downsweep_hsc_env
+ -- MP: TODO, we should just read the dependency info from the interface rather than either
+ -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
+ -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
+ read_result <- liftIO $
+ -- 1. Check if the interface is already loaded into the EPS by some other
+ -- part of the compiler.
+ lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
+ Just iface -> return (M.Succeeded iface)
+ Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+ case read_result of
+ M.Succeeded iface -> do
+ -- Computer information about this node
+ let node_deps = ifaceDeps (mi_deps iface)
+ edges = map mkFixedEdge node_deps
+ node = ModuleNode edges (ModuleNodeFixed key loc)
+ deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps)
+ pure $ NSuccess (node, deps')
+
+ -- Skip any failure, we might try to read a .hi-boot file for
+ -- example, even if there is not one.
+ M.Failed {} ->
+ pure NSkip
+ where
+ mk_dep hsc_env (Left key) = do
+ -- Like expandImports, but we already know exactly which module we are looking for.
read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
case read_result of
InstalledFound loc -> do
- done' <- loopFixedModule key loc done
- loopFixedImports keys done'
+ pure $ Just $ DSMod (ModuleNodeFixed key loc)
_otherwise ->
-- If the finder fails, just keep going, there will be another
- -- error later.
- loopFixedImports keys done
+ -- error later when we try to expand this dependency.
+ pure Nothing
+ mk_dep _ (Right uid_dep) = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ let home_uid = mnkUnitId key
+ pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
+
+ mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
+ mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
+ mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+
+ ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
+ ifaceDeps deps =
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
+ ] ++
+ [ Right (tcImportLevel lvl, uid)
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
+ ]
+
+-- | Expand a unit id under the context of a certain home unit
+expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
+ -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+expandUnitNode node_uid home_context_uid = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ hsc_env <- asks downsweep_hsc_env
+ let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env
+ case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of
+ Just us -> pure $ NSuccess ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)
+
+expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+expandInstantiatedUnit iud home_uid = pure $ NSuccess
+ ( InstantiationNode home_uid iud
+ , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )
+
+expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
+expandInteractiveImports imod imps = do
+ hsc_env <- asks downsweep_hsc_env
+ imps_cache <- asks downsweep_imports_cache
+
+ let
+ -- A simple edge to a module from the same home unit
+ mkEdge (IIModule n) = return $
+ let
+ mod_node_key = ModNodeKeyWithUid
+ { mnkModuleName = GWIB (moduleName n) NotBoot
+ , mnkUnitId =
+ -- 'toUnitId' is safe here, as we can't import modules that
+ -- don't have a 'UnitId'.
+ toUnitId (moduleUnit n)
+ }
+ in (Just $ ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key), [])
+
+ -- A complete import statement
+ mkEdge (IIDecl i) =
+ let unitId = homeUnitId $ hsc_home_unit hsc_env
+ imp = rnUnresolvedImportPkgQual (renameRawPkgQual (hsc_unit_env hsc_env))
+ (mkUnresolvedImport i)
+ UnresolvedImport { ui_level = lvl, ui_boot = is_boot } = imp
+ in do
+ let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
+ let k _ loc mod =
+ let key = moduleToMnk mod is_boot
+ in return $ FoundHome (ModuleNodeFixed key loc)
+
+ found <- liftIO $ summariseModuleDispatch k hsc_env imps_cache home_unit imp []
+ case found of
+ -- Case 1: Home modules have to already be in the cache.
+ FoundHome (ModuleNodeFixed mod _) -> do
+ let edge = ModuleNodeEdge lvl (NodeKey_Module mod)
+ -- Note: Does not perform any further downsweep as the module must already be in the cache.
+ return (Just edge, [])
+ -- Case 2: External units may not be in the cache, if we haven't already initialised the
+ -- module graph. We can construct the module graph for those here by calling loopUnit.
+ External uid -> do
+ let edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)
+ return (Just edge, [DSUnit{node_uid=uid, home_context_uid=homeUnitId home_unit}])
+ -- And if it's not found.. just carry on and hope.
+ _ -> return (Nothing, [])
+
+ (module_edges, todo) <- unzip <$> mapM mkEdge imps
+ pure $ NSuccess
+ ( ModuleNode (catMaybes module_edges) node_type, concat todo )
+ where
+ -- No sensible value for ModLocation.. if you hit this panic then you probably
+ -- need to add proper support for modules without any source files to the driver.
+ ml = pprPanic "modLocation" (ppr imod <+> ppr imps)
+ key = moduleToMnk imod NotBoot
+ node_type = ModuleNodeFixed key ml
+
+--------------------------------------------------------------------------------
+-- * Constructing Module Summaries
+--------------------------------------------------------------------------------
downsweepSummarise :: HomeUnit
-> UnresolvedImport PkgQual
-> Maybe (StringBuffer, UTCTime)
-> DownsweepM SummariseResult
downsweepSummarise home_unit imp maybe_buf = do
- DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
- case mode of
- DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries imp maybe_buf excl_mods
- DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit imp excl_mods
-
-
--- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
--- a new module by doing this.
-loopImports :: [(UnitId, UnresolvedImport PkgQual)]
- -- Work list: process these modules
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepCache
- -- Visited set; the range is a list because
- -- the roots can have the same module names
- -- if allow_dup_roots is True
- -> DownsweepM ([ModuleNodeEdge],
- M.Map NodeKey ModuleGraphNode, DownsweepCache)
- -- The result is the completed NodeMap
-loopImports [] done summarised = return ([], done, summarised)
-loopImports ((home_uid, imp) : ss) done summarised
- | Just summs <- M.lookup cache_key summarised
- = case summs of
- [Right ms] -> do
- let nk = mkModuleEdge lvl (NodeKey_Module (mnKey ms))
- (rest, summarised', done') <- loopImports ss done summarised
- return (nk: rest, summarised', done')
- [Left _err] ->
- loopImports ss done summarised
- _errs -> do
- loopImports ss done summarised
- | otherwise
- = do
- hsc_env <- asks downsweep_hsc_env
- let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- mb_s <- downsweepSummarise home_unit imp Nothing
- case mb_s of
- NotThere -> loopImports ss done summarised
- External uid -> do
- -- Pass an updated hsc_env to loopUnit, as each unit might
- -- have a different visible package database.
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- let done' = loopUnit hsc_env' done [uid]
- (other_deps, done'', summarised') <- loopImports ss done' summarised
- return (mkModuleEdge lvl (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
- FoundInstantiation iud -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (mkModuleEdge lvl (NodeKey_Unit iud) : other_deps, done', summarised')
- FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
- FoundHome s -> do
- (done', summarised') <-
- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
- (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-
- -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (mkModuleEdge lvl (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
- where
- UnresolvedImport { ui_level = lvl, ui_pkg_qual = mb_pkg
- , ui_boot = is_boot, ui_mod_name = wanted_mod } = imp
- cache_key = (home_uid, mb_pkg, GWIB (unLoc wanted_mod) is_boot)
-
-loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
-loopUnit _ cache [] = cache
-loopUnit lcl_hsc_env cache (u:uxs) = do
- let nk = (NodeKey_ExternalUnit u)
- case Map.lookup nk cache of
- Just {} -> loopUnit lcl_hsc_env cache uxs
- Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
- Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
- Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
-
-multiRootsErr :: SourceErrorContext -> [ModuleNodeInfo] -> IO ()
-multiRootsErr _ [] = panic "multiRootsErr"
-multiRootsErr sec summs@(summ1:_)
+ DownsweepEnv hsc_env mode summaries_cache_ref imports_cache_ref excl_mods <- ask
+ liftIO $ case mode of
+ DownsweepUseCompile ->
+ summariseModule hsc_env home_unit summaries_cache_ref imports_cache_ref
+ imp maybe_buf excl_mods
+ DownsweepUseFixed ->
+ summariseModuleInterface hsc_env home_unit imports_cache_ref imp excl_mods
+
+multiRootsErr :: SourceErrorContext -> NE.NonEmpty ModuleNodeInfo -> IO ()
+multiRootsErr sec (summ1 NE.:| summs)
= throwOneError sec $ fmap GhcDriverMessage $
mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files
where
mod = moduleNodeInfoModule summ1
- files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs
+ files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) (summ1:summs)
moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages
moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod)
@@ -696,48 +844,20 @@ instantiationNodes uid unit_state = map (uid,) iuids_to_check
, recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
]
--- The linking plan for each module. If we need to do linking for a home unit
--- then this function returns a graph node which depends on all the modules in the home unit.
-
--- At the moment nothing can depend on these LinkNodes.
-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
-linkNodes summaries uid hue =
- let dflags = homeUnitEnv_dflags hue
- ofile = outputFile_ dflags
-
- unit_nodes :: [NodeKey]
- unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
- -- Issue a warning for the confusing case where the user
- -- said '-o foo' but we're not going to do any linking.
- -- We attempt linking if either (a) one of the modules is
- -- called Main, or (b) the user said -no-hs-main, indicating
- -- that main() is going to come from somewhere else.
- --
- no_hs_main = gopt Opt_NoHsMain dflags
-
- main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
-
- do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
-
- in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
- Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
- -- This should be an error, not a warning (#10895).
- | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
- | otherwise -> Nothing
-
getRootSummary ::
[ModuleName] ->
- M.Map (UnitId, OsPath) ModSummary ->
+ ModSummaryCache ->
+ ImportsCache ->
HscEnv ->
Target ->
IO (Either DriverMessages ModSummary)
-getRootSummary excl_mods old_summary_map hsc_env target
+getRootSummary excl_mods summ_cache imports_cache hsc_env target
| TargetFile file mb_phase <- targetId
= do
let offset_file = augmentByWorkingDirectory dflags file
exists <- liftIO $ doesFileExist offset_file
if exists || isJust maybe_buf
- then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
+ then summariseFile hsc_env home_unit summ_cache offset_file mb_phase
maybe_buf
else
return $ Left $ singleMessage $
@@ -746,7 +866,7 @@ getRootSummary excl_mods old_summary_map hsc_env target
= do
let root_imp = (generatedImport FromTarget (L rootLoc modl))
{ ui_pkg_qual = ThisPkg (homeUnitId home_unit) }
- maybe_summary <- summariseModule hsc_env home_unit old_summary_map root_imp
+ maybe_summary <- summariseModule hsc_env home_unit summ_cache imports_cache root_imp
maybe_buf excl_mods
pure case maybe_summary of
FoundHome (ModuleNodeCompile s) -> Right s
@@ -809,6 +929,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
throwIO e
a -> pure a
+--------------------------------------------------------------------------------
+-- * Check/validate properties and error out
+--------------------------------------------------------------------------------
+
-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
--
@@ -856,6 +980,10 @@ checkHomeUnitsClosed ue
let todo'' = (depends Set.\\ done) `Set.union` todo'
in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
+--------------------------------------------------------------------------------
+-- * Enable Code Gen for Template Haskell
+--------------------------------------------------------------------------------
+
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
@@ -1173,15 +1301,9 @@ Potential TODOS:
generating temporary ones.
-}
--- | Populate the Downsweep cache with the root modules.
-mkRootMap
- :: [ModuleNodeInfo]
- -> DownsweepCache
-mkRootMap summaries = Map.fromListWith (flip (++))
- [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ]
-
-----------------------------------------------------------------------------
--- Summarising modules
+-- * Pre-processing and Summarising and modules
+-----------------------------------------------------------------------------
-- We have two types of summarisation:
--
@@ -1196,33 +1318,39 @@ mkRootMap summaries = Map.fromListWith (flip (++))
summariseFile
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary -- old summaries
+ -> ModSummaryCache
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Maybe (StringBuffer,UTCTime)
-> IO (Either DriverMessages ModSummary)
-summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
- -- we can use a cached summary if one is available and the
- -- source file hasn't changed,
- | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
- = do
- let location = ms_location $ old_summary
-
- src_hash <- get_src_hash
- -- The file exists; we checked in getRootSummary above.
- -- If it gets removed subsequently, then this
- -- getFileHash may fail, but that's the right
- -- behaviour.
-
- -- return the cached summary if the source didn't change
- checkSummaryHash
- hsc_env (new_summary src_fn)
- old_summary location src_hash
-
- | otherwise
- = do src_hash <- get_src_hash
- new_summary src_fn src_hash
+summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf
+ = do file_summ_cache <- readIORef summ_cache_ref
+ case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of
+ Just (Right (chd_summary, SummFresh)) ->
+ -- Fresh: use it straight away
+ pure (Right chd_summary)
+ Just (Right (old_summary, SummOld)) -> do
+ -- we can use a cached summary if one is available and the
+ -- source file hasn't changed,
+ let location = ms_location $ old_summary
+
+ src_hash <- get_src_hash
+ -- The file exists; we checked in getRootSummary above.
+ -- If it gets removed subsequently, then this
+ -- getFileHash may fail, but that's the right
+ -- behaviour.
+
+ -- return the cached summary if the source didn't change
+ res <- checkSummaryHash
+ hsc_env (new_summary src_fn)
+ old_summary location src_hash
+ case res of
+ Right ms -> modifySummCache summ_cache_ref (addModSummaryCache ms SummFresh)
+ Left _ -> pure ()
+ return res
+ _ -> do src_hash <- get_src_hash
+ new_summary src_fn src_hash
where
-- change the main active unit so all operations happen relative to the given unit
hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
@@ -1233,7 +1361,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
Just (buf,_) -> return $ fingerprintStringBuffer buf
Nothing -> liftIO $ getFileHash src_fn
- new_summary src_fn src_hash = runExceptT $ do
+ new_summary src_fn src_hash = do
+ res <- runExceptT $ do
preimps@PreprocessedImports {..}
<- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
@@ -1264,6 +1393,10 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
, nms_mod = mod
, nms_preimps = preimps
}
+ modifySummCache summ_cache_ref $ case res of
+ Left e -> M.insert (homeUnitId home_unit, src_fn_os) (Left e)
+ Right ms -> addModSummaryCache ms SummFresh
+ return res
checkSummaryHash
:: HscEnv
@@ -1316,13 +1449,14 @@ data SummariseResult =
-- --make mode.
summariseModule :: HscEnv
-> HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary
+ -> ModSummaryCache
+ -> ImportsCache
-> UnresolvedImport PkgQual -- ^ The import being summarised
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
-summariseModule hsc_env home_unit old_summaries imp maybe_buf excl_mods =
- summariseModuleDispatch k hsc_env home_unit imp excl_mods
+summariseModule hsc_env home_unit old_summaries imps_cache imp maybe_buf excl_mods =
+ summariseModuleDispatch k hsc_env imps_cache home_unit imp excl_mods
where
k = summariseModuleWithSource home_unit old_summaries (ui_boot imp) maybe_buf
@@ -1331,11 +1465,12 @@ summariseModule hsc_env home_unit old_summaries imp maybe_buf excl_mods =
-- This version always returns a ModuleNodeFixed node.
summariseModuleInterface :: HscEnv
-> HomeUnit
+ -> ImportsCache
-> UnresolvedImport PkgQual -- ^ The import being summarised
-> [ModuleName]
-> IO SummariseResult
-summariseModuleInterface hsc_env home_unit imp excl_mods =
- summariseModuleDispatch k hsc_env home_unit imp excl_mods
+summariseModuleInterface hsc_env home_unit imps_cache imp excl_mods =
+ summariseModuleDispatch k hsc_env imps_cache home_unit imp excl_mods
where
k _hsc_env loc mod = do
-- The finder will return a path to the .hi-boot even if it doesn't actually
@@ -1352,129 +1487,167 @@ summariseModuleInterface hsc_env home_unit imp excl_mods =
summariseModuleDispatch
:: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.
-> HscEnv
+ -> ImportsCache
-> HomeUnit
-> UnresolvedImport PkgQual -- ^ The import being summarised
-> [ModuleName] -- Modules to exclude
-> IO SummariseResult
-summariseModuleDispatch k hsc_env' home_unit imp excl_mods
- | wanted_mod `elem` excl_mods
+summariseModuleDispatch k hsc_env' imps_cache_ref home_unit imp excl_mods
+ | unLoc wanted_mod `elem` excl_mods
= return NotThere
| otherwise = find_it
where
- wanted_mod = unLoc (ui_mod_name imp)
-
-- Temporarily change the currently active home unit so all operations
-- happen relative to it
hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
find_it :: IO SummariseResult
find_it = do
- found <- resolveImport hsc_env imp
- case found of
- Found location mod
- | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->
- -- Home package
- k hsc_env location mod
- | VirtUnit iud <- moduleUnit mod
- , not (isHomeModule home_unit mod)
- -> return $ FoundInstantiation iud
- | otherwise -> return $ External (moduleUnitId mod)
- _ -> return NotThere
- -- Not found
- -- (If it is TRULY not found at all, we'll
- -- error when we actually try to compile)
-
+ imps_cache <- readIORef imps_cache_ref
+ case M.lookup cache_key imps_cache of
+ Just result -> return result
+ Nothing -> do
+ found <- resolveImport hsc_env imp
+ r <- case found of
+ Found location mod
+ | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->
+ -- Home package
+ k hsc_env location mod
+ | VirtUnit iud <- moduleUnit mod
+ , not (isHomeModule home_unit mod)
+ -> return $ FoundInstantiation iud
+ | otherwise -> return $ External (moduleUnitId mod)
+ _ -> return NotThere
+ -- Not found
+ -- (If it is TRULY not found at all, we'll
+ -- error when we actually try to compile)
+ modifyImpsCache imps_cache_ref (M.insert cache_key r)
+ return r
+
+ UnresolvedImport { ui_pkg_qual = mb_pkg, ui_boot = is_boot
+ , ui_mod_name = wanted_mod } = imp
+ cache_key = ( homeUnitId home_unit, mb_pkg
+ , GWIB{ gwib_mod = unLoc wanted_mod, gwib_isBoot = is_boot })
-- | The continuation to summarise a home module if we want to find the source file
-- for it and potentially compile it.
summariseModuleWithSource
:: HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary
- -- ^ Map of old summaries
+ -> ModSummaryCache
+ -- ^ Cache of constructed summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Maybe (StringBuffer, UTCTime)
-> HscEnv
-> ModLocation
-> Module
-> IO SummariseResult
-summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do
- -- Adjust location to point to the hs-boot source file,
- -- hi file, object file, when is_boot says so
- let src_fn = expectJust (ml_hs_file location)
-
- -- Check that it exists
- -- It might have been deleted since the Finder last found it
+summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env location mod = do
+ -- Adjust location to point to the hs-boot source file,
+ -- hi file, object file, when is_boot says so
+ let src_fn = expectJust (ml_hs_file location)
+ summ_cache <- readIORef summ_cache_ref
+
+ -- Reject the cache result if the module name doesn't match the inferred
+ -- module name based on the file name.
+ -- See (W1) in Note [Downsweep Control Flow and Caching]
+ let cached = do
+ p <- ml_hs_file_ospath location
+ res <- M.lookup (moduleUnitId mod, p) summ_cache
+ case res of
+ Right (ms, _) | msKey ms /= moduleToMnk mod is_boot ->
+ -- Module name doesn't match the file path name.
+ -- We fall through to @new_summary@, where this will be
+ -- discovered and the correct error message will be thrown.
+ Nothing
+ _ -> Just res
+
+ case cached of
+ Just (Right (chd_summary, SummFresh)) ->
+ -- Fresh! just return it
+ pure $ FoundHome (ModuleNodeCompile chd_summary)
+
+ Just (Left err) ->
+ -- Failure, don't try to summarise it again
+ pure $ FoundHomeWithError (moduleUnitId mod, err)
+
+ mb_old -> do
+ -- Either Nothing or a potentially old summary, must check.
+
+ -- Check that it exists
+ -- It might have been deleted since the Finder last found it
maybe_h <- fileHashIfExists src_fn
case maybe_h of
-- This situation can also happen if we have found the .hs file but the
-- .hs-boot file doesn't exist.
Nothing -> return NotThere
Just h -> do
- fresult <- new_summary_cache_check location mod src_fn h
+ fresult <- case mb_old of
+ Just (Right (old_summary, SummOld)) ->
+ -- check the hash on the source file, and return the cached
+ -- summary if it hasn't changed. If the file has changed then
+ -- need to resummarise.
+ case maybe_buf of
+ Just (buf,_) ->
+ checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location (fingerprintStringBuffer buf)
+ Nothing ->
+ checkSummaryHash hsc_env (new_summary location mod src_fn) old_summary location h
+ Nothing ->
+ new_summary location mod src_fn h
return $ case fresult of
Left err -> FoundHomeWithError (moduleUnitId mod, err)
Right ms -> FoundHome (ModuleNodeCompile ms)
-
where
dflags = hsc_dflags hsc_env
- new_summary_cache_check loc mod src_fn h
- | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
-
- -- check the hash on the source file, and
- -- return the cached summary if it hasn't changed. If the
- -- file has changed then need to resummarise.
- case maybe_buf of
- Just (buf,_) ->
- checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
- Nothing ->
- checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
- | otherwise = new_summary loc mod src_fn h
- where
- src_fn_os = unsafeEncodeUtf src_fn
-
new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary location mod src_fn src_hash
- = runExceptT $ do
- preimps@PreprocessedImports {..}
- -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
- -- See multiHomeUnits_cpp2 test
- <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
-
- -- NB: Despite the fact that is_boot is a top-level parameter, we
- -- don't actually know coming into this function what the HscSource
- -- of the module in question is. This is because we may be processing
- -- this module because another module in the graph imported it: in this
- -- case, we know if it's a boot or not because of the {-# SOURCE #-}
- -- annotation, but we don't know if it's a signature or a regular
- -- module until we actually look it up on the filesystem.
- let hsc_src
- | is_boot == IsBoot = HsBootFile
- | isHaskellSigFilename src_fn = HsigFile
- | otherwise = HsSrcFile
-
- when (pi_mod_name /= moduleName mod) $
- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
- $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
-
- let instantiations = homeUnitInstantiations home_unit
- when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
- $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
-
- liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
- { nms_src_fn = src_fn
- , nms_src_hash = src_hash
- , nms_hsc_src = hsc_src
- , nms_location = location
- , nms_mod = mod
- , nms_preimps = preimps
- }
+ = do
+ res <- runExceptT $ do
+ preimps@PreprocessedImports {..}
+ -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
+ -- See multiHomeUnits_cpp2 test
+ <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
+
+ -- NB: Despite the fact that is_boot is a top-level parameter, we
+ -- don't actually know coming into this function what the HscSource
+ -- of the module in question is. This is because we may be processing
+ -- this module because another module in the graph imported it: in this
+ -- case, we know if it's a boot or not because of the {-# SOURCE #-}
+ -- annotation, but we don't know if it's a signature or a regular
+ -- module until we actually look it up on the filesystem.
+ let hsc_src
+ | is_boot == IsBoot = HsBootFile
+ | isHaskellSigFilename src_fn = HsigFile
+ | otherwise = HsSrcFile
+
+ when (pi_mod_name /= moduleName mod) $
+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
+ $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
+
+ let instantiations = homeUnitInstantiations home_unit
+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
+ $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
+
+ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
+ { nms_src_fn = src_fn
+ , nms_src_hash = src_hash
+ , nms_hsc_src = hsc_src
+ , nms_location = location
+ , nms_mod = mod
+ , nms_preimps = preimps
+ }
+ modifySummCache summ_cache_ref $ case res of
+ Left e -> case ml_hs_file_ospath location of
+ Just p -> M.insert (moduleUnitId mod, p) (Left e)
+ Nothing -> id
+ Right ms -> addModSummaryCache ms SummFresh
+ return res
-- | Convenience named arguments for 'makeNewModSummary' only used to make
-- code more readable, not exported.
@@ -1497,7 +1670,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath nms_location)
bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file_ospath nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_imps
return $
ModSummary
@@ -1510,7 +1682,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
, ms_parsed_mod = Nothing
, ms_textual_imps =
(generatedImport FromBackpackSig . noLoc <$> extra_sig_imports) ++
- (generatedImport FromBackpackSig . noLoc <$> implicit_sigs) ++
pi_imps
, ms_hs_hash = nms_src_hash
, ms_iface_date = hi_timestamp
@@ -1549,3 +1720,160 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
let pi_imps = map (rnUnresolvedImportPkgQual (renameRawPkgQual (hsc_unit_env hsc_env))) pi_imps'
return PreprocessedImports {..}
+
+--------------------------------------------------------------------------------
+-- * Generic traversal of iteratively-built graph: dfsBuild
+--------------------------------------------------------------------------------
+
+-- | The result of expanding a node in 'dfsBuild'.
+data NodeRes v
+ -- | Computed the node payload successfully
+ = NSuccess v
+ -- | Skip a node! This means this node doesn't produce a payload and we can
+ -- just ignore it if we ever come across it.
+ --
+ -- In practice, this might happen because of an error or maybe from an
+ -- attempt to expand e.g. an hs-boot node just to see if it sticks, but we
+ -- don't distinguish these uses. Skip just means ignore this node and don't
+ -- abort.
+ | NSkip
+
+-- | In a depth-first order, and starting from the given roots, traverse a
+-- graph by iteratively expanding a node into a payload and a list of children
+-- nodes to visit next.
+--
+-- A node is NEVER visited/expanded more than once, as long as the node key
+-- @k@, computed from the node @n@, uniquely identifies that node.
+--
+-- The first argument @base_map@ is the starting set of already visited nodes
+-- (these nodes won't be expanded again!).
+--
+-- The result is a mapping from the key of every node transitively reachable
+-- from the root nodes (inclusively) to the payload returned by expanding that
+-- node. The result includes the previously visited nodes given in @base_map@,
+-- s.t. @dfsBuild base_map [] _ _ == base_map@.
+--
+-- The @expand@ function returns an 'NResult'. See the 'NResult' documentation
+-- for more information about each result type.
+--
+-- Error handling and exiting early can be achieved by selecting a @Monad m@
+-- accordingly, such as @Control.Monad.Except.Except@
+--
+-- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@.
+--
+-- See also Note [Downsweep Control Flow and Caching]
+dfsBuild :: (Ord k, Monad m)
+ => Maybe (Map.Map k (NodeRes v))
+ -- ^ Base map, existing results. We won't re-expand any of the nodes
+ -- already present in this map.
+ -> [n]
+ -- ^ The root nodes from where to start traversal
+ -> (n -> k)
+ -- ^ Compute the key which uniquely identifies this node
+ -> (n -> m (NodeRes (v,[n])))
+ -- ^ Expand this node into its payload result and into the list of
+ -- children nodes to visit next.
+ -> m (Map.Map k (NodeRes v))
+ -- ^ The result accumulates the payload of expanding the root nodes
+ -- and all nodes transitively reachable from those roots.
+dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
+ where
+ go [] visited = pure visited
+ go (s:ss) visited
+ | k `Map.member` visited
+ = go ss visited
+ | otherwise
+ = do r <- expand s
+ case r of
+ NSkip ->
+ go ss
+ (Map.insert k NSkip visited) -- Skip!
+ NSuccess (v,ns) ->
+ go (ns ++ ss)
+ (Map.insert k (NSuccess v) visited)
+ where
+ k = key s
+
+{-
+Note [Downsweep Control Flow and Caching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The control flow of downsweep is extracted into a single function `dfsBuild`,
+which takes care of iteratively expanding and traversing all nodes of the
+in-construction module graph necessary to build a full `ModuleGraph` at the
+end.
+
+There are three levels of caching going on, all of which are necessary to make
+sure we don't do repeated work (notably, we NEVER summarise the same module
+twice).
+
+1. `dfsBuild` accumulates the final module graph and never revisits the
+ same node of the module graph. Cache is keyed by the final
+ `ModuleGraph`s `NodeKey`s.
+
+ For example, suppose
+
+ A imports B and C
+ B imports D
+ C imports D
+
+ Then, starting from A we will expand A and push B and C to the worklist;
+ then, going back to B, we expand B which pushes D to the worklist. After
+ processing D, we go to C, which imports D, but we have already visited that
+ module so we can just use the already-constructed `ModuleGraphNode` for D.
+
+2. For Module A in home-unit u1, each import in the list of imports
+ needs to be *found* (call to `findImportedModuleWithIsBoot`): at this
+ point, we only have the `ModuleName` of the import, not the `Module`.
+ This *finding* is somewhat expensive, so we cache it as well
+ (`ImportsCache`). The cache key is the home-unit to which the module
+ belongs~[1], the import package qualifier, and the ModuleName.
+
+ Same example, suppose
+
+ A imports B and C
+ B imports D
+ C imports D
+
+ When expanding B, we will findImportedModule "import D".
+ When expanding C, we would findImportedModule "import D", but we can just
+ look it up in the cache
+
+ [1] Different home-units will have different package flags, which means
+ potentially different `Module` resolution for the same `ModuleName`.
+
+3. The most expensive operation we want to avoid is summarising a
+ `Module` into a `ModSummary`, which notably involves parsing the
+ module header from scratch.
+ The third cache, in essence, maps a `Module` to its `ModSummary`
+ (named `ModSummaryCache`). This cache upholds the invariant: we NEVER
+ summarise the same module twice. In practice, the cache key is the
+ Module's UnitId and the Source path; the reason is we need to
+ distinguish between `.hs` and `.hs-boot` files, as their summaries
+ will differ.
+
+ Note that this covers more than just (1), because we summarise all imports
+ of a single module when expanding it (see 'expandModuleSummary'), before
+ returning from the expansion function.
+
+ Note that (2) can't guarantee this alone: Two ModuleName imports in
+ separate units can (and likely do) map to the same `Module`.
+
+(W1)
+ In `summariseModuleWithSource`, on a cache hit, we must check if the module
+ name matches the file name, because the cache might have been populated by
+ `summariseFile`:
+
+ - `summariseFile` is used for summarising file targets, where
+ the file name needn't match the module name: e.g., the `Main` module is
+ sometimes not defined in a file named `Main.hs`.
+
+ - `summariseModuleWithSource` is used for summarising module targets, like
+ an `import Bar`, where `Bar.hs` must contain `module Bar where`
+ specifically (since we will later look for .hi files based on the module
+ name).
+
+ See tests T27461a and T27461b.
+
+See also Note [Downsweep: building and maintaining the module graph] and
+Note [The ModuleGraph].
+-}
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -286,7 +286,7 @@ hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> Modu
-- These things are currently stored in the EPS for home packages. (See #25795 for
-- progress in removing these kind of checks; and making these functions of
-- `UnitEnv` rather than `HscEnv`)
--- See Note [Downsweep and the ModuleGraph]
+-- See Note [The ModuleGraph]
hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return []
hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
= let hug = hsc_HUG hsc_env
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -292,28 +292,28 @@ implicitRequirements hsc_env normal_imports
where
mhome_unit = hsc_home_unit_maybe hsc_env
--- | Like @implicitRequirements'@, but returns either the module name, if it is
--- a free hole, or the instantiated unit the imported module is from, so that
--- that instantiated unit can be processed and via the batch mod graph (rather
--- than a transitive closure done here) all the free holes are still reachable.
+-- | Like @implicitRequirements'@, but returns the instantiated unit the
+-- imported module is from, so that that instantiated unit can be processed and
+-- via the batch mod graph (rather than a transitive closure done here) all the
+-- free holes are still reachable.
implicitRequirementsShallow
:: HscEnv
-> [UnresolvedImport PkgQual]
- -> IO ([ModuleName], [InstantiatedUnit])
-implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
+ -> IO [InstantiatedUnit]
+implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports
where
mhome_unit = hsc_home_unit_maybe hsc_env
go acc [] = pure acc
- go (accL, accR) (e:imports) = do
+ go accR (e:imports) = do
found <- resolveImport hsc_env e
let acc' = case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
case moduleUnit mod of
- HoleUnit -> (moduleName mod : accL, accR)
- RealUnit _ -> (accL, accR)
- VirtUnit u -> (accL, u:accR)
- _ -> (accL, accR)
+ HoleUnit -> panic "implicitRequirementsShallow: HoleUnit is unreachable through findImportedModule!"
+ RealUnit _ -> accR
+ VirtUnit u -> u:accR
+ _ -> accR
go acc' imports
-- | Given a 'Unit', make sure it is well typed. This is because
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -167,7 +167,7 @@ data UnitEnv = UnitEnv
, ue_module_graph :: ModuleGraph
-- ^ The module graph of the current session
- -- See Note [Downsweep and the ModuleGraph] for when this is constructed.
+ -- See Note [The ModuleGraph] for when this is constructed.
, ue_home_unit_graph :: !HomeUnitGraph
-- See Note [Multiple Home Units]
=====================================
testsuite/tests/driver/T27461/Main1.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import Bar () -- resolves to src/Bar.hs, which declares module Foo
+
+main :: IO ()
+main = return ()
=====================================
testsuite/tests/driver/T27461/Main2.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()
=====================================
testsuite/tests/driver/T27461/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# src/Bar.hs declares module Foo, which is fine for a file target, but Main's
+# `import Bar` resolves to that same file and must be rejected.
+T27461a :
+ cp Main1.hs src/Main.hs
+ ! '$(TEST_HC)' $(TEST_HC_OPTS) --make -fno-code -v0 -isrc src/Main.hs src/Bar.hs
=====================================
testsuite/tests/driver/T27461/T27461a.stderr
=====================================
@@ -0,0 +1,4 @@
+src/Bar.hs:1:8: error: [GHC-28623]
+ File name does not match module name:
+ Saw : ‘Foo’
+ Expected: ‘Bar’
=====================================
testsuite/tests/driver/T27461/T27461b.script
=====================================
@@ -0,0 +1,7 @@
+"-- Successfully load modules if file target is not imported"
+:! cp Main2.hs src/Main.hs
+:load src/Main.hs src/Bar.hs
+main
+:! cp Main1.hs src/Main.hs
+"-- Crash on reload as we import a file target that has the wrong module name"
+:reload
=====================================
testsuite/tests/driver/T27461/T27461b.stderr
=====================================
@@ -0,0 +1,5 @@
+src/Bar.hs:1:8: error: [GHC-28623]
+ File name does not match module name:
+ Saw : ‘Foo’
+ Expected: ‘Bar’
+
=====================================
testsuite/tests/driver/T27461/T27461b.stdout
=====================================
@@ -0,0 +1,2 @@
+"-- Successfully load modules if file target is not imported"
+"-- Crash on reload as we import a file target that has the wrong module name"
=====================================
testsuite/tests/driver/T27461/all.T
=====================================
@@ -0,0 +1,3 @@
+test('T27461a', extra_files(['src/', 'Main1.hs']), makefile_test, [])
+test('T27461b', [extra_files(['src/', 'Main1.hs', 'Main2.hs']), extra_hc_opts('-isrc')],
+ ghci_script, ['T27461b.script'])
=====================================
testsuite/tests/driver/T27461/src/Bar.hs
=====================================
@@ -0,0 +1,5 @@
+module Foo where
+-- Named Bar.hs but declares module Foo: allowed for a file target.
+
+foo :: Int
+foo = 1
=====================================
testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
=====================================
@@ -24,6 +24,7 @@ import Control.Monad.Catch (handle, throwM)
import Control.Exception.Context
import GHC.Driver.MakeFile
import GHC.Utils.Outputable
+import Data.IORef (newIORef)
-- | Convert a ModuleNodeCompile to a ModuleNodeFixed
convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo
convertToFixed (ModuleNodeCompile ms) =
@@ -151,5 +152,6 @@ main = do
getModSummaryFromTarget :: FilePath -> Ghc ModSummary
getModSummaryFromTarget file = do
hsc_env <- getSession
- Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ summ_cache <- liftIO $ newIORef mempty
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing
return ms
=====================================
testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Types.SourceFile
import System.Environment
import Control.Monad (void, when)
import Data.Maybe (fromJust)
+import Data.IORef (newIORef)
import Control.Exception (ExceptionWithContext(..), SomeException)
import Control.Monad.Catch (handle, throwM)
import Control.Exception.Context
@@ -67,7 +68,9 @@ main = do
keyC = msKey msC
let mkGraph s = do
- ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s []
+ summ_cache <- newIORef mempty
+ imps_cache <- newIORef mempty
+ ([], nodes) <- downsweepFromRootNodes hsc_env summ_cache imps_cache Nothing [] True DownsweepUseFixed s []
return $ mkModuleGraph nodes
graph <- liftIO $ mkGraph [ModuleNodeCompile msC]
@@ -98,5 +101,6 @@ main = do
getModSummaryFromTarget :: FilePath -> Ghc ModSummary
getModSummaryFromTarget file = do
hsc_env <- getSession
- Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ summ_cache <- liftIO $ newIORef mempty
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing
return ms
=====================================
testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
=====================================
@@ -23,6 +23,7 @@ import Control.Monad.Catch (handle, throwM)
import Control.Exception.Context
import GHC.Utils.Outputable
import Data.List
+import Data.IORef (newIORef)
-- | Convert a ModuleNodeCompile to a ModuleNodeFixed
convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo
@@ -132,5 +133,6 @@ main = do
getModSummaryFromTarget :: FilePath -> Ghc ModSummary
getModSummaryFromTarget file = do
hsc_env <- getSession
- Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ summ_cache <- liftIO $ newIORef mempty
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing
return ms
=====================================
testsuite/tests/splice-imports/SI35.hs
=====================================
@@ -28,6 +28,7 @@ import GHC.Unit.Module.Stage
import GHC.Data.Graph.Directed.Reachability
import GHC.Utils.Trace
import GHC.Unit.Module.Graph
+import Data.IORef (newIORef)
main :: IO ()
main = do
@@ -75,5 +76,6 @@ main = do
getModSummaryFromTarget :: FilePath -> Ghc ModSummary
getModSummaryFromTarget file = do
hsc_env <- getSession
- Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ summ_cache <- liftIO $ newIORef mempty
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing
return ms
\ No newline at end of file
=====================================
utils/check-ppr/Main.hs
=====================================
@@ -18,6 +18,7 @@ import System.Environment( getArgs )
import System.Exit
import System.FilePath
import System.IO
+import Data.IORef
usage :: String
usage = unlines
@@ -85,7 +86,8 @@ parseOneFile libdir fileName = do
let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
_ <- setSessionDynFlags dflags2
hsc_env <- getSession
- mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) mempty fileName Nothing Nothing
+ cache <- liftIO $ newIORef mempty
+ mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) cache fileName Nothing Nothing
case mms of
Left _err -> error "parseOneFile"
Right ms -> parseModule ms
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b757727a78613e7437a713058c24b9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b757727a78613e7437a713058c24b9…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/az/hie-bios-bat-executable
by Alan Zimmerman (＠alanz) 15 Aug '26
by Alan Zimmerman (＠alanz) 15 Aug '26
15 Aug '26
Alan Zimmerman pushed new branch wip/az/hie-bios-bat-executable at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/hie-bios-bat-executable
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/T27602] DEMO: Tighten T9675 residency tolerance (do not merge)
by Simon Jakobi (＠sjakobi) 15 Aug '26
by Simon Jakobi (＠sjakobi) 15 Aug '26
15 Aug '26
Simon Jakobi pushed to branch wip/sjakobi/T27602 at Glasgow Haskell Compiler / GHC
Commits:
a4ddab82 by Simon Jakobi at 2026-08-15T11:54:49+02:00
DEMO: Tighten T9675 residency tolerance (do not merge)
Revert the T4830 regression from the previous demo commit; T4830's
'bytes allocated' turns out to be fully deterministic across CI
samples, so it cannot show a spread.
Instead tighten T9675's residency tolerance from 15% to 2%: its
peak_megabytes_allocated jitters by up to ~12% between runs of the
same commit, so with a multi-sample baseline the natural jitter
fails the window and the new sample-spread output shows a baseline
built from genuinely disagreeing samples.
Context: #27602
Assisted-by: Claude Fable 5
- - - - -
1 changed file:
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -133,7 +133,8 @@ test('T9020',
test('T9675',
[ only_ways(['optasm']),
- collect_compiler_residency(15),
+ # Demo-only: tightened from 15 so natural residency jitter fails.
+ collect_compiler_residency(2),
collect_compiler_stats('bytes allocated',2),
],
compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a4ddab82385619a28b7fd6de1b925e1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a4ddab82385619a28b7fd6de1b925e1…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/T27602] 2 commits: testsuite: Show baseline sample count and spread in perf failures
by Simon Jakobi (＠sjakobi) 15 Aug '26
by Simon Jakobi (＠sjakobi) 15 Aug '26
15 Aug '26
Simon Jakobi pushed to branch wip/sjakobi/T27602 at Glasgow Haskell Compiler / GHC
Commits:
5d69b025 by Simon Jakobi at 2026-08-15T11:15:42+02:00
testsuite: Show baseline sample count and spread in perf failures
A perf baseline is the mean of all samples recorded for a commit, so a
single outlier can silently corrupt it. Previously, the failure output
gave no hint about such outliers: the baseline printed as one number.
In #27602, T27336's peak_megabytes_allocated baseline showed as 757
when the underlying samples were 605 and 909.
When the baseline is averaged from more than one sample, say so in the
failure message and list the samples, both in the one-line stat-failure
reason and in the detail block. Single-sample baselines print exactly
as before.
Context: #27602
Assisted-by: Claude Fable 5
- - - - -
b222f971 by Simon Jakobi at 2026-08-15T11:19:30+02:00
ci: Clarify comment on pushing perf notes after failures
Context: #27602
Assisted-by: Claude Fable 5
- - - - -
2 changed files:
- .gitlab/ci.sh
- testsuite/driver/perf_notes.py
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -1120,9 +1120,10 @@ case ${1:-help} in
setup) setup && cleanup_submodules ;;
configure) time_it "configure" configure ;;
build_hadrian) time_it "build" build_hadrian ;;
- # N.B. Always push notes, even if the build fails. This is okay to do as the
- # testsuite driver doesn't record notes for tests that fail due to
- # correctness.
+ # N.B. Always push notes, even if the build fails. Metrics from runs failing
+ # a perf stat check are deliberately recorded too — discarding them would
+ # bias the baseline towards whichever sample came first. Only correctness
+ # failures record nothing.
test_hadrian)
fetch_perf_notes
res=0
=====================================
testsuite/driver/perf_notes.py
=====================================
@@ -84,8 +84,11 @@ PerfStat = NamedTuple('PerfStat', [('test_env', TestEnv),
('value', float)])
# A baseline recovered form stored metrics.
-Baseline = NamedTuple('Baseline', [('perfStat', PerfStat),
- ('commit', GitHash)])
+class Baseline(NamedTuple):
+ perfStat: PerfStat
+ commit: GitHash
+ # The raw samples the baseline value was averaged over.
+ samples: List[float] = []
# The type of exceptions which are thrown when computing the current stat value
# fails.
@@ -465,6 +468,10 @@ def get_allowed_changes(baseline_ref: Optional[GitRef]) -> Dict[TestName, List[A
# (bool , str ) -> (str , str , str , str) -> float
_commit_metric_cache = {} # type: ignore
+# Like _commit_metric_cache, but mapping to the list of raw sample values the
+# baseline was averaged over. Filled by get_commit_metric.
+_commit_samples_cache = {} # type: ignore
+
# Get the baseline of a test at a given commit. This is the expected value
# *before* the commit is applied (i.e. on the parent commit).
# This searches git notes from older commits for recorded metrics (locally and
@@ -506,7 +513,8 @@ def baseline_metric(commit: GitHash,
if baseline_commit is not None:
current_metric = get_commit_metric(namespace, baseline_commit, test_env, name, metric, way)
if current_metric is not None:
- return Baseline(current_metric, baseline_commit)
+ return Baseline(current_metric, baseline_commit,
+ get_commit_samples(namespace, baseline_commit, test_env, name, metric, way))
else:
return None
@@ -515,7 +523,8 @@ def baseline_metric(commit: GitHash,
# Check for a metric on this commit.
current_metric = get_commit_metric(namespace, current_commit, test_env, name, metric, way)
if current_metric is not None:
- return Baseline(current_metric, current_commit)
+ return Baseline(current_metric, current_commit,
+ get_commit_samples(namespace, current_commit, test_env, name, metric, way))
# Stop if there is an expected change at this commit. In that case
# metrics on ancestor commits will not be a valid baseline.
@@ -598,8 +607,23 @@ def get_commit_metric(gitNoteRef,
# Save baselines to the cache.
_commit_metric_cache[cacheKeyA] = baseline_by_cache_key_b
+ _commit_samples_cache[cacheKeyA] = values_by_cache_key_b
return baseline_by_cache_key_b.get(cacheKeyB)
+# Get the raw sample values that get_commit_metric averages over. Uses the
+# cache filled by get_commit_metric, so no extra git calls after it has run.
+def get_commit_samples(gitNoteRef,
+ ref: Union[GitRef, GitHash],
+ test_env: TestEnv,
+ name: TestName,
+ metric: MetricName,
+ way: WayName
+ ) -> List[float]:
+ get_commit_metric(gitNoteRef, ref, test_env, name, metric, way)
+ cacheKeyA = (gitNoteRef, commit_hash(ref))
+ cacheKeyB = (test_env, name, metric, way)
+ return _commit_samples_cache.get(cacheKeyA, {}).get(cacheKeyB, [])
+
def check_stats_change(actual: PerfStat,
baseline: Baseline,
acceptance_window: MetricAcceptanceWindow,
@@ -654,9 +678,17 @@ def check_stats_change(actual: PerfStat,
' baseline @ %s' % baseline.commit
print(actual.metric, error + ':')
dev = 100.0 if expected_val == 0 else round(((float(actual.value) * 100) / int(expected_val)) - 100, 1)
+ # A multi-sample baseline is a mean; show the samples so outliers
+ # corrupting the baseline are visible (#27602).
+ if len(baseline.samples) > 1:
+ samples_note = ('; baseline is mean of %d samples: %s'
+ % (len(baseline.samples),
+ ', '.join('%g' % s for s in baseline.samples)))
+ else:
+ samples_note = ''
change_line = (f'{actual.metric} {change.value} from {baseline.perfStat.test_env} '
f'baseline @ {baseline.commit[:7]}: {expected_val} -> {actual.value} '
- f'({dev:+g}%, allowed {acceptance_window.describe()})')
+ f'({dev:+g}%, allowed {acceptance_window.describe()}{samples_note})')
result = failBecause('stat ' + change_line, tag='stat')
if not change_allowed or force_print:
@@ -666,6 +698,10 @@ def check_stats_change(actual: PerfStat,
print(descr, str(val).rjust(length), extra)
display(' Expected ' + full_name + ' ' + actual.metric + ':', expected_val, acceptance_window.describe())
+ if len(baseline.samples) > 1:
+ display(' Samples ' + full_name + ' ' + actual.metric + ':',
+ len(baseline.samples),
+ '(' + ', '.join('%g' % s for s in baseline.samples) + ')')
display(' Lower bound ' + full_name + ' ' + actual.metric + ':', lowerBound, '')
display(' Upper bound ' + full_name + ' ' + actual.metric + ':', upperBound, '')
display(' Actual ' + full_name + ' ' + actual.metric + ':', actual.value, '')
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/622d8907861a5edfdd1bde0a2ec0a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/622d8907861a5edfdd1bde0a2ec0a7…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: loopImports: Don't dup ms_uid in summary imports
by Marge Bot (＠marge-bot) 15 Aug '26
by Marge Bot (＠marge-bot) 15 Aug '26
15 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
57186d18 by Rodrigo Mesquita at 2026-08-15T02:49:34-04:00
loopImports: Don't dup ms_uid in summary imports
We were writing the ms_unitid of the mod summary with every single
import of that module
That complicated the code (as though the UnitId in that list could ever
be something else) and also allocates unnecessarily per every mod
import. Very slight allocation decrease measured locally in a few tests:
(MultiComponentModulesRecomp: -0.06%; MultiComponentModulesRecomp100: -0.05%)
Purely a clean up.
- - - - -
389eeb13 by Rodrigo Mesquita at 2026-08-15T02:49:34-04:00
downsweep: make control flow simpler and cache correct
This refactor extracts the control flow of downsweep into a single
function `dfsBuild`, which takes care of iteratively expanding and
traversing all nodes of the in-construction module graph necessary to
build a full `ModuleGraph`.
There are three levels of caching going on, all of which are necessary
to make sure we don't do repeated work (notably, NEVER summarise the
same module twice).
1. `dfsBuild` accumulates the final module graph and never revisits the
same node of the module graph. Cache is keyed by the final
`ModuleGraph`s `NodeKey`s.
2. For Module A in home-unit u1, each import in the list of imports
needs to be *found* (call to `findImportedModuleWithIsBoot`): at this
point, we only have the `ModuleName` of the import, not the `Module`.
This *finding* is somewhat expensive, so we cache it as well
(`ImportsCache`). The cache key is the home-unit to which the module
belongs~[1], the import package qualifier, and the ModuleName.
[1] Different home-units will have different package flags, which means
potentially different `Module` resolution for the same `ModuleName`.
3. The most expensive operation we want to avoid is summarising a
`Module` into a `ModSummary`, which notably involves parsing the
module header from scratch.
The third cache, in essence, maps a `Module` to its `ModSummary`
(named `ModSummaryCache`). This cache upholds the invariant: we NEVER
summarise the same module twice. In practice, the cache key is the
Module's UnitId and the Source path; the reason is we need to
distinguish between `.hs` and `.hs-boot` files, as their summaries
will differ.
Note that (2) can't guarantee this alone: Two ModuleName imports in
separate units can (and likely do) map to the same `Module`.
Note that the previous implementation failed to achieve the
no-duplicate-work summarisation invariant, and we ended up doing a
quadratic amount of processing in scenarios like test
`MultiComponentModules100`.
See also Note [Downsweep Control Flow and Caching]
Fixes #27461
Perf changes:
MultiComponentModules(normal) ghc/alloc 2,097,389,264 1,992,186,736 -5.0% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,173,770 21,293,867,360 -12.4% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,761,394 498,543,984 -17.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,968,240 8,895,404,864 -25.2% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
dcf199ce by Rodrigo Mesquita at 2026-08-15T02:49:34-04:00
implicitRequirementsShallow can never reach HoleUnit
findImportedModule will never return `HoleUnit` for a `ModuleName`
(a `HoleUnit` can only be found as a signature instantiation, never as a
directly *imported* thing)
Therefore, we can drop `[ModuleName]` returned by
`implicitRequirementsShallow`, which makes many things dead code.
Namely, the call to `implicitRequirementsShallow` from
GHC.Driver.Downsweep which was a performance bottleneck (for doing lots
of duplicate work in findImportedModule) is now entirely gone.
Fixes #27053
In an MR with this patch and the downsweep refactor (previous commit), CI says:
MultiComponentModules(normal) ghc/alloc 2,097,396,728 1,943,662,304 -7.3% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,182,136 17,227,574,440 -29.1% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,769,518 449,973,656 -25.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,976,408 4,828,894,160 -59.4% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
e032cb24 by Rodrigo Mesquita at 2026-08-15T02:49:34-04:00
downsweep: Cache negative results
When traversing a module graph structure, a uniquely identified node
should always expand to the same thing.
I don't see how visiting the same node which failed to be expanded a
first time would ever successfully expand the second time we try to
expand it (eg. when coming from a different edge to it -- it is still
the same node!). The node expansion is local, based just based on the
node itself, not on the path to get there.
Therefore, this patch removes the weird behavior and commentary of
`dfsBuild` wrt to `Nothing` not being cached and being potentially
expanded a second time around to something different, which was
misleading and, ultimately, incorrect.
Now, we have a `MGRes`, which is more explicit about a node being
Skipped just being a node that is ignored whenever it is found (and that
skip is cached) -- and we may want to do this due to failures or due to
just trying nodes which might not work on purpose, like hs-boots.
We uniformly cache positive and negative results and remove the
assumption that there might be an ordering in which the same node
visited at a later time might be expanded differently.
This makes it possible to traverse the module nodes in parallel without
a change in behavior, since there's no longer a hidden ordering
requirement.
- - - - -
150fe3ff by Rodrigo Mesquita at 2026-08-15T02:49:34-04:00
Organize and clean-up GHC.Driver.Downsweep
Simply some cosmetic changes, moving definitions around to structure the
module better into its relevant sections
(In go (ns ++ ss), it's not a problem to use ++ because it's a good
producer and we won't have to append fully before processing the next
item in go)
- - - - -
dabe6ae8 by Wolfgang Jeltsch at 2026-08-15T02:49:35-04:00
Add support for textual output of bytecode file content
- - - - -
9cff2f4d by mangoiv at 2026-08-15T02:49:37-04:00
hadrian: set the executable bit for hie-bios.bat
- - - - -
37 changed files:
- + changelog.d/downsweep-refactor
- + changelog.d/show-byte-code
- compiler/GHC/ByteCode/Serialize.hs
- + compiler/GHC/ByteCode/Show.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Unit/Env.hs
- compiler/ghc.cabal.in
- docs/users_guide/using.rst
- ghc/GHC/Driver/Session/Mode.hs
- ghc/Main.hs
- hadrian/hie-bios.bat
- + testsuite/tests/driver/T27461/Main1.hs
- + testsuite/tests/driver/T27461/Main2.hs
- + testsuite/tests/driver/T27461/Makefile
- + testsuite/tests/driver/T27461/T27461a.stderr
- + testsuite/tests/driver/T27461/T27461b.script
- + testsuite/tests/driver/T27461/T27461b.stderr
- + testsuite/tests/driver/T27461/T27461b.stdout
- + testsuite/tests/driver/T27461/all.T
- + testsuite/tests/driver/T27461/src/Bar.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- + testsuite/tests/show-bytecode/Example.hs
- + testsuite/tests/show-bytecode/Makefile
- + testsuite/tests/show-bytecode/all.T
- + testsuite/tests/show-bytecode/normalize
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs
- + testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs
- testsuite/tests/splice-imports/SI35.hs
- utils/check-ppr/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e553d0b413f4b1a46ff251eff9e4a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e553d0b413f4b1a46ff251eff9e4a…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: loopImports: Don't dup ms_uid in summary imports
by Marge Bot (＠marge-bot) 15 Aug '26
by Marge Bot (＠marge-bot) 15 Aug '26
15 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
39720029 by Rodrigo Mesquita at 2026-08-14T21:32:13-04:00
loopImports: Don't dup ms_uid in summary imports
We were writing the ms_unitid of the mod summary with every single
import of that module
That complicated the code (as though the UnitId in that list could ever
be something else) and also allocates unnecessarily per every mod
import. Very slight allocation decrease measured locally in a few tests:
(MultiComponentModulesRecomp: -0.06%; MultiComponentModulesRecomp100: -0.05%)
Purely a clean up.
- - - - -
3904d06a by Rodrigo Mesquita at 2026-08-14T21:32:13-04:00
downsweep: make control flow simpler and cache correct
This refactor extracts the control flow of downsweep into a single
function `dfsBuild`, which takes care of iteratively expanding and
traversing all nodes of the in-construction module graph necessary to
build a full `ModuleGraph`.
There are three levels of caching going on, all of which are necessary
to make sure we don't do repeated work (notably, NEVER summarise the
same module twice).
1. `dfsBuild` accumulates the final module graph and never revisits the
same node of the module graph. Cache is keyed by the final
`ModuleGraph`s `NodeKey`s.
2. For Module A in home-unit u1, each import in the list of imports
needs to be *found* (call to `findImportedModuleWithIsBoot`): at this
point, we only have the `ModuleName` of the import, not the `Module`.
This *finding* is somewhat expensive, so we cache it as well
(`ImportsCache`). The cache key is the home-unit to which the module
belongs~[1], the import package qualifier, and the ModuleName.
[1] Different home-units will have different package flags, which means
potentially different `Module` resolution for the same `ModuleName`.
3. The most expensive operation we want to avoid is summarising a
`Module` into a `ModSummary`, which notably involves parsing the
module header from scratch.
The third cache, in essence, maps a `Module` to its `ModSummary`
(named `ModSummaryCache`). This cache upholds the invariant: we NEVER
summarise the same module twice. In practice, the cache key is the
Module's UnitId and the Source path; the reason is we need to
distinguish between `.hs` and `.hs-boot` files, as their summaries
will differ.
Note that (2) can't guarantee this alone: Two ModuleName imports in
separate units can (and likely do) map to the same `Module`.
Note that the previous implementation failed to achieve the
no-duplicate-work summarisation invariant, and we ended up doing a
quadratic amount of processing in scenarios like test
`MultiComponentModules100`.
See also Note [Downsweep Control Flow and Caching]
Fixes #27461
Perf changes:
MultiComponentModules(normal) ghc/alloc 2,097,389,264 1,992,186,736 -5.0% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,173,770 21,293,867,360 -12.4% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,761,394 498,543,984 -17.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,968,240 8,895,404,864 -25.2% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
f8bbd057 by Rodrigo Mesquita at 2026-08-14T21:32:13-04:00
implicitRequirementsShallow can never reach HoleUnit
findImportedModule will never return `HoleUnit` for a `ModuleName`
(a `HoleUnit` can only be found as a signature instantiation, never as a
directly *imported* thing)
Therefore, we can drop `[ModuleName]` returned by
`implicitRequirementsShallow`, which makes many things dead code.
Namely, the call to `implicitRequirementsShallow` from
GHC.Driver.Downsweep which was a performance bottleneck (for doing lots
of duplicate work in findImportedModule) is now entirely gone.
Fixes #27053
In an MR with this patch and the downsweep refactor (previous commit), CI says:
MultiComponentModules(normal) ghc/alloc 2,097,396,728 1,943,662,304 -7.3% GOOD
MultiComponentModules100(normal) ghc/alloc 24,310,182,136 17,227,574,440 -29.1% GOOD
MultiComponentModulesRecomp(normal) ghc/alloc 602,769,518 449,973,656 -25.3% GOOD
MultiComponentModulesRecomp100(normal) ghc/alloc 11,885,976,408 4,828,894,160 -59.4% GOOD
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModules100
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
-------------------------
- - - - -
6c3c3086 by Rodrigo Mesquita at 2026-08-14T21:32:13-04:00
downsweep: Cache negative results
When traversing a module graph structure, a uniquely identified node
should always expand to the same thing.
I don't see how visiting the same node which failed to be expanded a
first time would ever successfully expand the second time we try to
expand it (eg. when coming from a different edge to it -- it is still
the same node!). The node expansion is local, based just based on the
node itself, not on the path to get there.
Therefore, this patch removes the weird behavior and commentary of
`dfsBuild` wrt to `Nothing` not being cached and being potentially
expanded a second time around to something different, which was
misleading and, ultimately, incorrect.
Now, we have a `MGRes`, which is more explicit about a node being
Skipped just being a node that is ignored whenever it is found (and that
skip is cached) -- and we may want to do this due to failures or due to
just trying nodes which might not work on purpose, like hs-boots.
We uniformly cache positive and negative results and remove the
assumption that there might be an ordering in which the same node
visited at a later time might be expanded differently.
This makes it possible to traverse the module nodes in parallel without
a change in behavior, since there's no longer a hidden ordering
requirement.
- - - - -
fabfe4bc by Rodrigo Mesquita at 2026-08-14T21:32:13-04:00
Organize and clean-up GHC.Driver.Downsweep
Simply some cosmetic changes, moving definitions around to structure the
module better into its relevant sections
(In go (ns ++ ss), it's not a problem to use ++ because it's a good
producer and we won't have to append fully before processing the next
item in go)
- - - - -
9c094539 by Wolfgang Jeltsch at 2026-08-14T21:32:14-04:00
Add support for textual output of bytecode file content
- - - - -
6e553d0b by mangoiv at 2026-08-14T21:32:15-04:00
hadrian: set the executable bit for hie-bios.bat
- - - - -
37 changed files:
- + changelog.d/downsweep-refactor
- + changelog.d/show-byte-code
- compiler/GHC/ByteCode/Serialize.hs
- + compiler/GHC/ByteCode/Show.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Unit/Env.hs
- compiler/ghc.cabal.in
- docs/users_guide/using.rst
- ghc/GHC/Driver/Session/Mode.hs
- ghc/Main.hs
- hadrian/hie-bios.bat
- + testsuite/tests/driver/T27461/Main1.hs
- + testsuite/tests/driver/T27461/Main2.hs
- + testsuite/tests/driver/T27461/Makefile
- + testsuite/tests/driver/T27461/T27461a.stderr
- + testsuite/tests/driver/T27461/T27461b.script
- + testsuite/tests/driver/T27461/T27461b.stderr
- + testsuite/tests/driver/T27461/T27461b.stdout
- + testsuite/tests/driver/T27461/all.T
- + testsuite/tests/driver/T27461/src/Bar.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- + testsuite/tests/show-bytecode/Example.hs
- + testsuite/tests/show-bytecode/Makefile
- + testsuite/tests/show-bytecode/all.T
- + testsuite/tests/show-bytecode/normalize
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout
- + testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs
- + testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout
- + testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs
- testsuite/tests/splice-imports/SI35.hs
- utils/check-ppr/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05aee047ad3659b1eee454e1a2bee7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05aee047ad3659b1eee454e1a2bee7…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
15 Aug '26
Vladislav Zavialov pushed new branch wip/int-index/T7803 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/T7803
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
14 Aug '26
Simon Jakobi pushed new branch wip/sjakobi/T27602 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27602
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/romes/27514] Concurrent worker abstraction for downsweep/make
by sheaf (＠sheaf) 14 Aug '26
by sheaf (＠sheaf) 14 Aug '26
14 Aug '26
sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC
Commits:
566d789d by sheaf at 2026-08-14T23:26:51+02:00
Concurrent worker abstraction for downsweep/make
This commit introduces GHC.Driver.Concurrency which provides a high-level
interface over scheduling concurrent workers, used by downsweep and
--make.
Summary of changes:
- The ad-hoc plumbing of AbstractSem is replaced by the dedicated
'data Concurrency = Serial | Concurrent ConcurrencyEnv'.
This avoids a footgun in which one could try to use an 'AbstractSem'
as a lock in the serial case.
- We no longer wastefully re-run an entire action upon a semaphore
failure. The "fallback to -j1" logic is preserved, but it only
applies to the initial attempt at opening a semaphore, not on late
semaphore errors that occur partway through a lengthy computation.
- Logger threads are now properly cleaned up on exception.
- Drop the 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager'
arguments to 'depanalE', 'depanalPartial' and 'downsweep', which
were all dead in practice.
- - - - -
9 changed files:
- + compiler/GHC/Driver/Concurrency.hs
- + compiler/GHC/Driver/Config/Concurrency.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeAction.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Utils/TmpFs.hs
- compiler/ghc.cabal.in
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
compiler/GHC/Driver/Concurrency.hs
=====================================
@@ -0,0 +1,464 @@
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE BlockArguments #-}
+
+module GHC.Driver.Concurrency
+ ( -- * Worker limit and concurrency
+ WorkerLimit(..)
+ , isWorkerLimitSequential
+ , withWorkerLimit
+ , Concurrency
+ , withConcurrency
+ -- * Concurrent worker scheduling
+ , ConcurrentWorkerEnv(..)
+ , mapConcurrentWorkers
+ , concurrentTraversal_DF
+ )
+ where
+
+import GHC.Prelude
+
+import GHC.Driver.MakeSem
+import GHC.Driver.Pipeline.LogQueue
+ ( LogQueueQueue, finishLogQueue, initLogQueue, logThread
+ , newLogQueue, newLogQueueQueue, parLogAction )
+import GHC.Utils.Logger
+ ( Logger, makeThreadSafe, pushLogHook )
+import GHC.Utils.Panic
+ ( panic )
+import GHC.Utils.TmpFs
+ ( TmpFs, forkTmpFsFrom, mergeTmpFsInto, withLocalTmpFS )
+
+import System.Semaphore
+ ( SemaphoreError, SemaphoreIdentifier )
+
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+import Control.Concurrent
+ ( ThreadId, forkIOWithUnmask, killThread, myThreadId )
+import Control.Concurrent.MVar
+ ( MVar, newEmptyMVar, newMVar, putMVar, takeMVar )
+import GHC.Conc
+ ( labelThread )
+#else
+import Control.Concurrent
+ ( ThreadId, forkIOWithUnmask, killThread, myThreadId
+ , newQSem, signalQSem, waitQSem, MVar, takeMVar, putMVar, newEmptyMVar )
+import Control.Monad
+ ( unless )
+import qualified Control.Monad.Catch as MC
+import GHC.Conc
+ ( getNumCapabilities, getNumProcessors, labelThread, setNumCapabilities )
+#endif
+import Control.Concurrent.STM
+ ( TVar, atomically, check, modifyTVar', newTVarIO, readTVar, writeTVar )
+import Control.Exception
+ ( AsyncException(ThreadKilled), SomeAsyncException, SomeException
+ , finally, fromException, mask, mask_, onException
+ , throwIO, try, uninterruptibleMask_ )
+import Control.Monad
+ ( replicateM )
+import Data.Foldable
+ ( for_ )
+import Data.IORef
+ ( IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef )
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+
+--------------------------------------------------------------------------------
+-- * Worker Limit
+--------------------------------------------------------------------------------
+
+-- | A limit on the number of concurrent worker threads.
+data WorkerLimit
+ -- | Fixed concurrent worker count limit @-jN@
+ = NumProcessorsLimit Int
+ -- | The concurrent worker count is limited by a @-jsem@ semaphore
+ | JSemLimit
+ SemaphoreIdentifier
+ -- ^ Semaphore identifier (from the @semaphore-compat@ library)
+ deriving Eq
+
+isWorkerLimitSequential :: WorkerLimit -> Bool
+isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1
+isWorkerLimitSequential (JSemLimit {}) = False
+
+runWorkerLimit
+ :: (SemaphoreError -> IO ())
+ -- ^ report failure when opening the @-jsem@ semaphore
+ -- (after which we fall back to running with a single job)
+ -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+runWorkerLimit _report_semaphore_failure _ action = do
+ lock <- newMVar ()
+ action $ AbstractSem (takeMVar lock) (putMVar lock ())
+#else
+runWorkerLimit report_semaphore_failure worker_limit action = case worker_limit of
+ NumProcessorsLimit n_jobs ->
+ runNjobsAbstractSem n_jobs action
+ JSemLimit sem_ident ->
+ runJSemAbstractSem sem_ident action >>= \case
+ Right a -> return a
+ Left err -> do
+ report_semaphore_failure err
+ runNjobsAbstractSem 1 action
+#endif
+
+#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
+runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
+runNjobsAbstractSem n_jobs action = do
+ compile_sem <- newQSem n_jobs
+ n_capabilities <- getNumCapabilities
+ n_cpus <- getNumProcessors
+ let
+ asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
+ set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n
+ updNumCapabilities = do
+ -- Setting number of capabilities more than
+ -- CPU count usually leads to high userspace
+ -- lock contention. #9221
+ set_num_caps $ min n_jobs n_cpus
+ resetNumCapabilities = set_num_caps n_capabilities
+ MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
+
+#endif
+
+--------------------------------------------------------------------------------
+-- * Workers
+--------------------------------------------------------------------------------
+
+data Concurrency
+ = Serial
+ | Concurrent !ConcurrencyEnv
+
+-- | Run an action with the given concurrency control (serial or concurrent).
+withConcurrency :: Concurrency -> IO a -> IO a
+withConcurrency conc act =
+ case conc of
+ Serial -> act
+ Concurrent ( ConcurrencyEnv { ce_semaphore } ) ->
+ withAbstractSem ce_semaphore act
+
+data ConcurrencyEnv =
+ ConcurrencyEnv
+ { ce_semaphore :: !AbstractSem
+ , ce_log_queue_queue :: !( TVar LogQueueQueue )
+ , ce_next_log_queue_id :: !( IORef Int )
+ }
+
+-- | The local environment of a worker thread that may be scheduled concurrently.
+data ConcurrentWorkerEnv = ConcurrentWorkerEnv
+ { cwe_logger :: !Logger
+ , cwe_tmpfs :: !TmpFs
+ }
+
+-- | Run an action with a local 'TmpFs', merging in the resulting temporary file
+-- accumulator into the parent afterwards.
+workerEnv_withLocalTmpFS :: ConcurrentWorkerEnv -> (ConcurrentWorkerEnv -> IO a) -> IO a
+workerEnv_withLocalTmpFS env use =
+ withLocalTmpFS (cwe_tmpfs env) \ lcl_tmpfs ->
+ use env { cwe_tmpfs = lcl_tmpfs }
+
+-- | Run an action either serially or concurrently based on the provided
+-- 'WorkerLimit'.
+withWorkerLimit
+ :: Logger
+ -> TmpFs
+ -> (SemaphoreError -> IO ())
+ -- ^ report a failure to open the @-jsem@ semaphore
+ -- (after which we fall back to running with a single job)
+ -> WorkerLimit
+ -> (Concurrency -> ConcurrentWorkerEnv -> IO a) -- ^ action to run
+ -> IO a
+withWorkerLimit logger tmpfs report_semaphore_failure limit action
+ | isWorkerLimitSequential limit
+ = action Serial $
+ ConcurrentWorkerEnv
+ { cwe_logger = logger
+ , cwe_tmpfs = tmpfs
+ }
+ | otherwise
+ = do
+ safe_logger <- makeThreadSafe logger
+ lqq_var <- newTVarIO newLogQueueQueue
+ stopped_var <- newTVarIO False
+ wait_log_thread <- logThread safe_logger stopped_var lqq_var
+ next_logq_var <- newIORef 1
+
+ let
+ stop_logging :: IO ()
+ stop_logging = do
+ atomically $ writeTVar stopped_var True
+ wait_log_thread
+
+ parent_work_env :: ConcurrentWorkerEnv
+ parent_work_env =
+ ConcurrentWorkerEnv
+ { cwe_logger = safe_logger
+ , cwe_tmpfs = tmpfs
+ }
+
+ ( `finally` stop_logging ) $
+ runWorkerLimit report_semaphore_failure limit \ sem -> do
+ let
+ conc =
+ Concurrent $
+ ConcurrencyEnv
+ { ce_semaphore = sem
+ , ce_log_queue_queue = lqq_var
+ , ce_next_log_queue_id = next_logq_var
+ }
+ action conc parent_work_env
+
+--------------------------------------------------------------------------------
+-- * Scheduling concurrent workers
+--------------------------------------------------------------------------------
+
+-- | Internal scheduler abstraction with two capabilities:
+--
+-- - spawn a new worker thread
+-- - wait for a worker thread to complete
+data Scheduler r = Scheduler
+ { spawnWorker :: (ConcurrentWorkerEnv -> IO r) -> IO ()
+ -- ^ Spawn one concurrent worker.
+ --
+ -- The worker does not hold a token of the concurrency semaphore: the
+ -- worker action should use 'withConcurrency' around the work whose
+ -- concurrency should be limited.
+ , awaitWorker :: IO (Either SomeException r)
+ -- ^ Wait for one worker to complete.
+ --
+ -- Will crash if there are no outstanding workers.
+ }
+
+-- | Internal implementation of a concurrent worker scheduler.
+--
+-- Usage of this function requires the following:
+--
+-- - all spawn/await actions are performed by a single thread,
+-- - we never wait for more workers than were spawned,
+-- - no worker outlives 'run_schedule'.
+run_schedule
+ :: forall r a
+ . String
+ -- ^ thread label for workers
+ -> Concurrency
+ -> ConcurrentWorkerEnv
+ -> (Scheduler r -> IO a)
+ -- ^ worker action
+ -> IO a
+run_schedule worker_label conc parent_work_env withScheduler =
+ case conc of
+
+ Serial -> do
+ results_var <- newIORef Seq.empty
+ let
+ spawnWorker :: (ConcurrentWorkerEnv -> IO r) -> IO ()
+ spawnWorker action = do
+ res <- try @SomeException $
+ workerEnv_withLocalTmpFS parent_work_env action
+ case res of
+ Left e
+ | Just _ <- fromException @SomeAsyncException e
+ -> throwIO e
+ _ -> modifyIORef' results_var (Seq.|> res)
+
+ awaitWorker :: IO (Either SomeException r)
+ awaitWorker =
+ readIORef results_var >>= \case
+ res Seq.:<| rest -> do
+ writeIORef results_var rest
+ pure res
+ Seq.Empty ->
+ panic "run_schedule: no outstanding job"
+
+ withScheduler $ Scheduler { spawnWorker, awaitWorker }
+
+ Concurrent ( ConcurrencyEnv { ce_next_log_queue_id, ce_log_queue_queue } ) -> do
+ worker_tids_var <- newTVarIO $ Set.empty @ThreadId
+ all_results_vars_var <- newIORef $ Seq.empty @(MVar (Either SomeException r))
+
+ let
+ wait_for_workers :: IO ()
+ wait_for_workers =
+ atomically $
+ check . Set.null =<< readTVar worker_tids_var
+
+ cancel_workers :: IO ()
+ cancel_workers = do
+ uninterruptibleMask_ do
+ tids <- atomically $ readTVar worker_tids_var
+ for_ tids killThread
+ wait_for_workers
+
+ awaitWorker :: IO (Either SomeException r)
+ awaitWorker =
+ readIORef all_results_vars_var >>= \case
+ first_worker_res_var Seq.:<| rest -> do
+ writeIORef all_results_vars_var rest
+ -- block on the earliest-spawned outstanding worker
+ takeMVar first_worker_res_var
+ Seq.Empty ->
+ panic "run_schedule: no outstanding job"
+
+ spawnWorker :: (ConcurrentWorkerEnv -> IO r) -> IO ()
+ spawnWorker action = mask_ do
+
+ worker_res_var <- newEmptyMVar
+
+ -- TmpFs
+ lcl_tmpfs <- forkTmpFsFrom (cwe_tmpfs parent_work_env)
+
+ -- LogQueue
+ lq <- do
+ job_id <- atomicModifyIORef' ce_next_log_queue_id \n -> (n + 1, n)
+ lq <- newLogQueue job_id
+ atomically $ initLogQueue ce_log_queue_queue lq
+ pure lq
+
+ let
+
+ worker_work_env :: ConcurrentWorkerEnv
+ worker_work_env =
+ parent_work_env
+ { cwe_tmpfs = lcl_tmpfs
+ , cwe_logger = pushLogHook (const (parLogAction lq))
+ (cwe_logger parent_work_env)
+ }
+
+ -- Run a worker action and record its result.
+ run_worker_and_record :: IO r -> IO ()
+ run_worker_and_record worker_action = do
+ res <- try @SomeException worker_action
+ case res of
+ Left e
+ -- Worker is being cancelled: don't record anything.
+ | Just ThreadKilled <- fromException e
+ -> pure ()
+ _ -> putMVar worker_res_var res
+
+ -- Record that a worker thread is done.
+ mark_worker_done :: ThreadId -> IO ()
+ mark_worker_done tid =
+ uninterruptibleMask_ do
+ -- Uninterruptible: the deletion below /must/ occur.
+ -- An uninterruptible mask is OK as we only ever block for (GAP) below.
+ mergeTmpFsInto lcl_tmpfs $ cwe_tmpfs parent_work_env
+ finishLogQueue lq
+ atomically do
+ tids <- readTVar worker_tids_var
+ check $ tid `Set.member` tids
+ -- Ensure we never end up with a dead ThreadId in 'worker_tids_var'
+ -- (if the worker thread finishes before the parent thread has
+ -- the time to add its ThreadId to 'worker_tids_var').
+
+ writeTVar worker_tids_var $ Set.delete tid tids
+
+ run_worker :: (forall b. IO b -> IO b) -> IO ()
+ run_worker unmask = do
+ tid <- myThreadId
+ labelThread tid worker_label
+ let
+ worker_action :: IO r
+ worker_action = unmask $ action worker_work_env
+
+ run_worker_and_record worker_action `finally`
+ mark_worker_done tid
+
+ worker_tid <-
+ forkIOWithUnmask run_worker
+ `onException` finishLogQueue lq
+ -- Very short (GAP) between forking the thread and recording its ThreadId.
+ atomically $ modifyTVar' worker_tids_var $ Set.insert worker_tid
+ modifyIORef' all_results_vars_var (Seq.|> worker_res_var)
+
+ mask \ restore -> do
+ result <- restore (withScheduler $ Scheduler { spawnWorker, awaitWorker })
+ `onException` cancel_workers
+ restore wait_for_workers `onException` cancel_workers
+ pure result
+
+--------------------------------------------------------------------------------
+-- * Derived scheduling functionality
+--------------------------------------------------------------------------------
+
+-- | Map a worker action over the input list with the given concurrency control.
+--
+-- Workers run to completion (no early abort); the first exception
+-- (in input order) is rethrown at the end.
+mapConcurrentWorkers
+ :: String -- ^ thread label for workers
+ -> Concurrency
+ -> ConcurrentWorkerEnv
+ -> (ConcurrentWorkerEnv -> a -> IO b)
+ -- ^ individual worker action
+ --
+ -- NB: workers do not hold semaphore tokens by default; use
+ -- 'withConcurrency' to acquire one
+ -> [a]
+ -> IO [b]
+mapConcurrentWorkers worker_label conc work_env f xs =
+ run_schedule worker_label conc work_env \ scheduler -> do
+ for_ xs \ x -> spawnWorker scheduler \ worker_env -> f worker_env x
+ results <- replicateM (length xs) (awaitWorker scheduler)
+ either throwIO pure (sequence results)
+
+-- | Depth-first traversal with on-the-fly expansion of nodes.
+--
+-- Each expansion step is handled by a worker thread under the given
+-- concurrency control.
+--
+-- Deterministic: expansions are consumed in the order the nodes were
+-- discovered, so the traversal is a function of the node graph alone.
+--
+-- Fails fast: the first worker exception cancels the outstanding workers and
+-- is rethrown.
+concurrentTraversal_DF
+ :: forall k n r
+ . Ord k
+ => String -- ^ thread label for workers
+ -> Concurrency
+ -> ConcurrentWorkerEnv
+ -> Map.Map k r
+ -- ^ results known ahead of time (no expansion needed)
+ -> [n]
+ -- ^ root nodes
+ -> (n -> k)
+ -- ^ node key from node
+ -> (ConcurrentWorkerEnv -> n -> IO (r, [n]))
+ -- ^ worker action: expand a node into its result and the children to visit next
+ --
+ -- NB: workers do not hold semaphore tokens by default; use
+ -- 'withConcurrency' to acquire one
+ -> IO (Map.Map k r)
+concurrentTraversal_DF worker_label conc work_env base_map roots key expand =
+ run_schedule worker_label conc work_env \ scheduler -> do
+ let
+ expand_node :: n -> ConcurrentWorkerEnv -> IO (k, (r, [n]))
+ expand_node node worker_env = do
+ res <- expand worker_env node
+ pure (key node, res)
+
+ go
+ :: Map.Map k r -- expanded nodes and their results
+ -> Set.Set k -- nodes currently being expanded
+ -> [n] -- discovered nodes, to expand next
+ -> IO (Map.Map k r)
+ go !visited !pending (node : worklist)
+ | k `Set.member` pending || k `Map.member` visited
+ = go visited pending worklist
+ | otherwise
+ = do spawnWorker scheduler (expand_node node)
+ go visited (Set.insert k pending) worklist
+ where
+ k = key node
+ go visited pending []
+ | Set.null pending
+ = pure visited
+ | otherwise
+ = awaitWorker scheduler >>= \case
+ Left e -> throwIO e
+ Right (k, (result, children)) ->
+ go (Map.insert k result visited) (Set.delete k pending) children
+
+ go base_map Set.empty roots
=====================================
compiler/GHC/Driver/Config/Concurrency.hs
=====================================
@@ -0,0 +1,41 @@
+-- | Subsystem configuration for 'GHC.Driver.Concurrency'.
+module GHC.Driver.Config.Concurrency
+ ( mkWorkerLimit
+ , semaphoreOpenFailureHandler
+ ) where
+
+import GHC.Prelude
+
+import GHC.Driver.Concurrency
+import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
+import GHC.Driver.DynFlags
+import GHC.Driver.Errors ( printOrThrowDiagnostics )
+import GHC.Driver.Errors.Types
+
+import GHC.Types.Error ( singleMessage )
+import GHC.Types.SrcLoc ( noSrcSpan )
+import GHC.Utils.Error ( mkPlainMsgEnvelope )
+import GHC.Utils.Logger ( Logger )
+
+import GHC.Conc ( getNumProcessors )
+import System.Semaphore ( SemaphoreError )
+
+--------------------------------------------------------------------------------
+
+-- | Compute the 'WorkerLimit' from the @-j@\/@-jsem@ flags.
+mkWorkerLimit :: DynFlags -> IO WorkerLimit
+mkWorkerLimit dflags =
+ case parMakeCount dflags of
+ Nothing -> pure $ num_procs 1
+ Just (ParMakeSemaphore h) -> pure (JSemLimit h)
+ Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
+ Just (ParMakeThisMany n) -> pure $ num_procs n
+ where
+ num_procs x = NumProcessorsLimit (max 1 x)
+
+-- | Report that the semaphore specified using the @-jsem@ flag could not be opened.
+semaphoreOpenFailureHandler :: Logger -> DynFlags -> SemaphoreError -> IO ()
+semaphoreOpenFailureHandler logger dflags err = do
+ let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
+ msg = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
+ printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -40,9 +40,9 @@ import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
-import GHC.Driver.Messager
-import GHC.Driver.MakeSem
+import GHC.Driver.Concurrency
import GHC.Driver.MakeAction
+import GHC.Driver.Config.Concurrency
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Ppr
@@ -64,7 +64,6 @@ import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf )
import GHC.Data.StringBuffer
import GHC.Data.Graph.Directed.Reachability
-import GHC.Utils.Exception ( throwIO, SomeAsyncException, AsyncException (..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -101,7 +100,6 @@ import qualified Data.Set as Set
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
-import qualified Control.Monad.Catch as MC
import Data.Maybe
import Data.List (partition)
import Data.Time
@@ -112,13 +110,8 @@ import System.FilePath
import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
-import Control.Monad.Trans.Class
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.List.NonEmpty as NE
-import Control.Concurrent
-import Control.Concurrent.STM.TQueue
-import Control.Concurrent.STM
-import Control.Applicative
{-
Note [The ModuleGraph]
@@ -245,8 +238,6 @@ See Note [The ModuleGraph] for an overview when we do downsweep.
--
-- See also Note [The ModuleGraph]
downsweep :: HscEnv
- -> (GhcMessage -> AnyGhcDiagnostic)
- -> Maybe Messager
-> [ModSummary]
-- ^ Old summaries
-> Maybe ModuleGraph
@@ -260,13 +251,14 @@ downsweep :: HscEnv
-- The non-error elements of the returned list all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
-downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do
+downsweep hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots = do
n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
summ_cache <- newMVar (mkModSummaryCache (zip old_summaries (repeat SummOld)))
imps_cache <- newMVar Map.empty
- withMakeEnv n_jobs hsc_env diag_wrapper msg $ \make_env -> do
- (root_errs, root_summaries) <- rootSummariesParallel n_jobs make_env (hsc_targets hsc_env)
- (getRootSummary excl_mods summ_cache imps_cache)
+ withWorkerLimitHsc hsc_env n_jobs $ \conc hsc_env' -> do
+ (root_errs, root_summaries) <-
+ rootSummariesParallel conc hsc_env' (hsc_targets hsc_env)
+ (getRootSummary excl_mods summ_cache imps_cache)
let closure_errs = checkHomeUnitsClosed unit_env
unit_env = hsc_unit_env hsc_env
@@ -275,13 +267,12 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
case all_errs of
[] -> do
let env = DownsweepEnv
- { ds_hsc_env = hsc_env
+ { ds_hsc_env = hsc_env'
, ds_summaries_cache = summ_cache
, ds_imports_cache = imps_cache
, ds_mode = DownsweepUseCompile
, ds_excl_mods = excl_mods
- , ds_n_jobs = n_jobs
- , ds_make_env = make_env
+ , ds_concurrency = conc
}
(downsweep_errs, downsweep_nodes) <- runDownsweepM env $
downsweepFromRootNodes maybe_base_graph allow_dup_roots
@@ -349,15 +340,14 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
njobs <- mkWorkerLimit (hsc_dflags hsc_env)
summs <- newMVar (mkModSummaryCache [(mod_summary,SummOld)])
imps <- newMVar mempty
- withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
+ withWorkerLimitHsc hsc_env njobs $ \conc hsc_env' -> do
let env = DownsweepEnv
- { ds_hsc_env = hsc_env
+ { ds_hsc_env = hsc_env'
, ds_summaries_cache = summs
, ds_imports_cache = imps
, ds_mode = DownsweepUseFixed
, ds_excl_mods = []
- , ds_n_jobs = njobs
- , ds_make_env = make_env
+ , ds_concurrency = conc
}
~(errs, mg) <- runDownsweepM env $
downsweepFromRootNodes Nothing True
@@ -394,15 +384,14 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
summ_cache <- newMVar mempty
imps_cache <- newMVar mempty
- withMakeEnv n_jobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
+ withWorkerLimitHsc hsc_env n_jobs $ \conc hsc_env' -> do
let env = DownsweepEnv
- { ds_hsc_env = hsc_env
+ { ds_hsc_env = hsc_env'
, ds_mode = DownsweepUseFixed{-or DownsweepUseCompile?-}
, ds_summaries_cache = summ_cache
, ds_imports_cache = imps_cache
, ds_excl_mods = []
- , ds_n_jobs = n_jobs
- , ds_make_env = make_env
+ , ds_concurrency = conc
}
graph <- runDownsweepM env do
loopFromInteractive cached_nodes interactive_mn imps
@@ -439,15 +428,14 @@ downsweepInstalledModules hsc_env mods = do
nodes <- mapM process installed_mods
summs <- newMVar mempty
imps <- newMVar mempty
- withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
+ withWorkerLimitHsc hsc_env njobs $ \conc hsc_env' -> do
let env = DownsweepEnv
- { ds_hsc_env = hsc_env
+ { ds_hsc_env = hsc_env'
, ds_summaries_cache = summs
, ds_imports_cache = imps
, ds_mode = DownsweepUseFixed
, ds_excl_mods = []
- , ds_n_jobs = njobs
- , ds_make_env = make_env
+ , ds_concurrency = conc
}
(errs, mg) <- runDownsweepM env $
downsweepFromRootNodes Nothing True nodes external_uids
@@ -562,8 +550,8 @@ data DownsweepEnv = DownsweepEnv {
, ds_summaries_cache :: ModSummaryCache
, ds_imports_cache :: ImportsCache
, ds_excl_mods :: [ModuleName]
- , ds_n_jobs :: WorkerLimit
- , ds_make_env :: MakeEnv
+ , ds_concurrency :: Concurrency
+ -- ^ The concurrency to use for downsweep
}
mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
@@ -928,15 +916,28 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
--- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline system.
+-- | Execute 'getRootSummary' for the 'Target's in bundles, spawning one
+-- worker per bundle. The number of bundles processed at once is limited by
+-- the given 'Concurrency'.
rootSummariesParallel
- :: WorkerLimit -> MakeEnv -> [Target]
+ :: Concurrency -> HscEnv -> [Target]
-> (HscEnv -> Target -> IO (Either DriverMessages ModSummary))
-> IO ([DriverMessages], [ModSummary])
-rootSummariesParallel n_jobs make_env targets get_summary = do
- partitionEithers <$> mapConcDS n_jobs bundle_size make_env get_summary targets
- where
- bundle_size = 20
+rootSummariesParallel conc hsc_env targets get_summary = do
+ results <-
+ mapConcurrentWorkers "root_summary_worker" conc (viewHscWorkerEnv hsc_env)
+ ( \ work_env bundle ->
+ withConcurrency conc $
+ mapM (get_summary (setHscWorkerEnv work_env hsc_env)) bundle )
+ bundles
+ pure $ partitionEithers (concat results)
+ where
+ bundle_size = 20
+
+ bundles = mk_bundles targets
+ mk_bundles = unfoldr \case
+ [] -> Nothing
+ ts -> Just (splitAt bundle_size ts)
--------------------------------------------------------------------------------
-- * Check/validate properties and error out
@@ -1762,7 +1763,7 @@ data NodeRes v
-- node. The result includes the previously visited nodes given in @base_map@,
-- s.t. @parDfsBuild base_map [] _ _ == base_map@.
--
--- The @expand@ function returns an 'NResult'. See the 'NResult' documentation
+-- The @expand@ function returns a 'NodeRes'. See the 'NodeRes' documentation
-- for more information about each result type.
--
-- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@.
@@ -1785,90 +1786,25 @@ parDfsBuild :: forall k v n. Ord k
-- ^ The result accumulates the payload of expanding the root nodes
-- and all nodes transitively reachable from those roots.
parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
- exc_var <- newTVarIO $ Nothing @MC.SomeException
- visited_var <- newTVarIO $ fromMaybe Map.empty base_map
- pending <- newTVarIO $ Set.empty @k
- worklist <- newTQueueIO @n
- threads <- newTVarIO []
-
- coord_tid <- forkIO $
- coordinator ds_env exc_var visited_var worklist pending threads
- `MC.catch` \case
- (e::MC.SomeException)
- -- exit cleanly when killed
- | Just ThreadKilled <- fromException e -> return ()
- -- if the coordinator somehow else crashes,
- -- signal the exc_var for the main thread to throw it
- | otherwise -> atomically (modifyTVar' exc_var (<|> Just e))
-
- atomically $ mapM_ (writeTQueue worklist) roots
-
- mb_exc <- wait_done exc_var worklist pending
- `MC.finally` do
- killThread coord_tid
- mapM_ killThread =<< readTVarIO threads
-
- case mb_exc of
- Just e -> throwIO e
- Nothing -> readTVarIO visited_var
- where
- wait_done exc_var worklist pending =
- -- this txn retries until all work is done or an exception is signaled
- atomically $ do
- readTVar exc_var >>= \case
- Just e -> return (Just e)
- Nothing -> do
- empty_worklist <- isEmptyTQueue worklist
- empty_pending <- Set.null <$> readTVar pending
- check (empty_worklist && empty_pending)
- return Nothing
-
- coordinator ds_env exc_var visvar worklist pendvar threads = forever $ do
- mb_node_to_expand <- atomically $ do
- node <- readTQueue worklist
- let k = key node
-
- visited <- readTVar visvar
- pending <- readTVar pendvar
-
- if (k `Set.member` pending || k `Map.member` visited)
- then return Nothing
- else do
- -- must add to pending in the same transaction as worklist dequeue,
- -- otherwise the main thread may find both the worklist and pending
- -- lists empty and exit prematurely.
- modifyTVar' pendvar (Set.insert k)
- return (Just (k, node))
-
- case mb_node_to_expand of
- Nothing -> return ()
- Just (k, node) -> do
- tid <- MC.mask_ $ forkIOWithUnmask $ \unmask ->
- unmask (withLocalTmpFSMake (ds_make_env ds_env) $ \make_env ->
- worker ds_env{ds_make_env = make_env} visvar worklist pendvar k node)
- `MC.catch` \case
- e | Just (_ :: SomeAsyncException) <- fromException e
- -> throwIO e -- async exceptions like KillThread get thrown
- | otherwise -- exceptions in workers are written for main thread
- -> atomically (modifyTVar' exc_var (<|> Just e))
-
- atomically $ modifyTVar' threads (tid:)
-
- worker ds_env@DownsweepEnv{..} visvar worklist pendvar k node =
- withAbstractSem (compile_sem ds_make_env) $ do
- r <- runDownsweepM ds_env $
- expand node -- do the main work!
-
- atomically $ do
- case r of
- NSkip ->
- modifyTVar' visvar (Map.insert k NSkip)
- NSuccess (v,ns) -> do
- modifyTVar' visvar (Map.insert k (NSuccess v))
- mapM_ (writeTQueue worklist) ns
-
- modifyTVar' pendvar (Set.delete k)
+ let
+ conc :: Concurrency
+ conc = ds_concurrency ds_env
+
+ expand_node :: ConcurrentWorkerEnv -> n -> IO (NodeRes v, [n])
+ expand_node worker_env node = do
+ result <- withConcurrency conc $
+ runDownsweepM (setDownsweepWorkerEnv worker_env ds_env) (expand node)
+ pure $ case result of
+ NSkip -> (NSkip, [])
+ NSuccess (val, new_work) -> (NSuccess val, new_work)
+
+ concurrentTraversal_DF "downsweep_worker" conc (viewHscWorkerEnv $ ds_hsc_env ds_env)
+ (fromMaybe mempty base_map) roots key expand_node
+
+setDownsweepWorkerEnv :: ConcurrentWorkerEnv -> DownsweepEnv -> DownsweepEnv
+setDownsweepWorkerEnv work_env env =
+ env { ds_hsc_env = setHscWorkerEnv work_env (ds_hsc_env env) }
{-
Note [Downsweep Control Flow and Caching]
@@ -1963,70 +1899,10 @@ things, and that processing can often be costly (e.g. see `expandModuleSummary`)
We leverage multiple threads in this traversal to expand more than one module
at once, respecting -j<N> to mean we never expand more than N modules at once.
-The parallel downsweep is all handled by `parDfsBuild` as follows:
-
-- We launch a thread for every module we discover that needs to be
- expanded in the `coordinator` thread, popping it from the worklist
-- Every launched `worker` thread blocks waiting for a semaphore token
- (`withAbstractSem`) to respect -j<N>
-- The main thread waits until both the worklist and pending list is
- cleared, atomically.
-
-STM is used crucially to guarantee e.g. we don't have race conditions
-between taking from the worklist and writing to the pending list while
-checking whether they are clear.
-
-Exceptions are bubbled up to the main thread. The "main" thread, which is
-typically waiting for the worklist+pending lists to be clear, instead gets
-unblocked by this exception (signaled in `exc_var`) and re-throws it.
--}
---------------------------------------------------------------------------------
--- * Concurrent utilities
---------------------------------------------------------------------------------
-
--- | Map an action over a list using the parallelism pipeline system.
--- Create bundles of the list elems wrapped in a 'MakeAction' that uses
--- 'withAbstractSem' to wait for a free slot, limiting the number of
--- concurrently computed summaries to the value of the @-j@ option or the slots
--- allocated by the job server, if that is used.
---
--- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
--- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
--- result won't be read anyway here.
---
--- To emulate the current behavior, we funnel exceptions past the concurrency
--- barrier and rethrow the first one afterwards.
-mapConcDS ::
- WorkerLimit ->
- Int {-^ Batch size -} ->
- MakeEnv ->
- (HscEnv -> a -> IO b) ->
- [a] ->
- IO ([b])
-mapConcDS n_jobs bundle_size make_env run_action xs = do
- (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
- runAllPipelines n_jobs make_env actions
- (sequence . catMaybes <$> sequence get_results) >>= \case
- Right results -> pure (concat results)
- Left exc -> throwIO exc
- where
- bundles = mk_bundles xs
-
- mk_bundles = unfoldr \case
- [] -> Nothing
- ts -> Just (splitAt bundle_size ts)
-
- action_and_result (log_queue_id, ts) = do
- res_var <- liftIO newEmptyMVar
- pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)
-
- action log_queue_id target_bundle = do
- env@MakeEnv {compile_sem} <- ask
- lift $ lift $
- withAbstractSem compile_sem $
- withLoggerHsc log_queue_id env \ lcl_hsc_env ->
- MC.try (mapM (run_action lcl_hsc_env) target_bundle) >>= \case
- Left e | Just (_ :: SomeAsyncException) <- fromException e ->
- throwIO e
- a -> pure a
+We use the concurrent scheduling abstraction from GHC.Driver.Concurrency
+('concurrentTraversal_DF'). Each time we discover a new node, a worker is
+spawned to expand it. After each expansion completes, the resulting children
+nodes are pushed onto the worklist. With -j1 no threads are involved: each
+expansion runs in sequence.
+-}
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -63,8 +63,9 @@ import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Main
-import GHC.Driver.MakeSem
import GHC.Driver.Downsweep
+import GHC.Driver.Concurrency
+import GHC.Driver.Config.Concurrency
import GHC.Driver.MakeAction
import GHC.Types.UnresolvedImport
@@ -156,22 +157,20 @@ depanal :: GhcMonad m =>
depanal excluded_mods allow_dup_roots = do
hsc_env <- getSession
let sec = initSourceErrorContext (hsc_dflags hsc_env)
- (errs, mod_graph) <- depanalE mkUnknownDiagnostic Nothing excluded_mods allow_dup_roots
+ (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots
if isEmptyMessages errs
then pure mod_graph
else throwErrors sec (fmap GhcDriverMessage errs)
-- | Perform dependency analysis like in 'depanal'.
-- In case of errors, the errors and an empty module graph are returned.
-depanalE :: GhcMonad m => -- New for #17459
- (GhcMessage -> AnyGhcDiagnostic)
- -> Maybe Messager
- -> [ModuleName] -- ^ excluded modules
+depanalE :: GhcMonad m =>
+ [ModuleName] -- ^ excluded modules
-> Bool -- ^ allow duplicate roots
-> m (DriverMessages, ModuleGraph)
-depanalE diag_wrapper msg excluded_mods allow_dup_roots = do
+depanalE excluded_mods allow_dup_roots = do
hsc_env <- getSession
- (errs, mod_graph) <- depanalPartial diag_wrapper msg excluded_mods allow_dup_roots
+ (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
if isEmptyMessages errs
then do
hsc_env <- getSession
@@ -209,13 +208,11 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do
-- new module graph.
depanalPartial
:: GhcMonad m
- => (GhcMessage -> AnyGhcDiagnostic)
- -> Maybe Messager
- -> [ModuleName] -- ^ excluded modules
+ => [ModuleName] -- ^ excluded modules
-> Bool -- ^ allow duplicate roots
-> m (DriverMessages, ModuleGraph)
-- ^ possibly empty 'Bag' of errors and a module graph.
-depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do
+depanalPartial excluded_mods allow_dup_roots = do
hsc_env <- getSession
let
targets = hsc_targets hsc_env
@@ -234,7 +231,7 @@ depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do
liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
(errs, mod_graph) <- liftIO $ downsweep
- hsc_env diag_wrapper msg (mgModSummaries old_graph) Nothing
+ hsc_env (mgModSummaries old_graph) Nothing
excluded_mods allow_dup_roots
return (unionManyMessages errs, mod_graph)
@@ -438,7 +435,7 @@ loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how t
-> m SuccessFlag
loadWithCache cache diag_wrapper how_much = do
msg <- mkBatchMsg <$> getSession
- (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False -- #17459
+ (errs, mod_graph) <- depanalE [] False -- #17459
success <- load' cache how_much diag_wrapper (Just msg) mod_graph
hsc_env <- getSession
let sec = initSourceErrorContext (hsc_dflags hsc_env)
@@ -840,14 +837,15 @@ The Algorithm
a pair of an `IO a` action and a `MVar a`, where to place the result.
The list is sorted topologically, so can be executed in order without fear of
blocking.
-* runPipelines takes this list and eventually passes it to runLoop which executes
- each action and places the result into the right MVar.
-* The amount of parallelism is controlled by a semaphore. This is just used around the
- module compilation step, so that only the right number of modules are compiled at
- the same time which reduces overall memory usage and allocations.
-* Each proper node has a LogQueue, which dictates where to send it's output.
-* The LogQueue is placed into the LogQueueQueue when the action starts and a worker
- thread processes the LogQueueQueue printing logs for each module in a stable order.
+* runPipelines spawns one worker per action ('GHC.Driver.Concurrency.mapConcurrentWorkers'),
+ which executes the action and places the result into the right MVar.
+* The amount of parallelism is controlled by a semaphore ('withMakeEnvConcurrency'). This is
+ just used around the module compilation step, so that only the right number of
+ modules are compiled at the same time which reduces overall memory usage and
+ allocations.
+* Each worker has a LogQueue, which dictates where to send its output. A log
+ thread processes the LogQueues, printing logs for each module in a stable
+ order (the order in which the actions were spawned).
* The result variable for an action producing `a` is of type `Maybe a`, therefore
it is still filled on a failure. If a module fails to compile, the
failure is propagated through the whole module graph and any modules which didn't
@@ -1137,7 +1135,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
!build_deps = getDependencies (map gwib_mod deps) build_map
let loop_action = withCurrentUnit loop_unit $ do
!_ <- wait_deps build_deps
- hsc_env <- asks hsc_env
+ hsc_env <- asks me_hsc_env
let mns :: [ModuleName]
mns = mapMaybe (nodeKeyModName . gwib_mod) deps
@@ -1180,7 +1178,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit uid = do
- local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})
+ local (\env -> env { me_hsc_env = hscSetActiveUnitId uid (me_hsc_env env)})
upsweep
:: WorkerLimit -- ^ The number of workers we wish to run in parallel
@@ -1556,10 +1554,11 @@ executeInstantiationNode k n deps uid iu = do
env <- ask
-- Output of the logger is mediated by a central worker to
-- avoid output interleaving
- msg <- asks env_messager
- wrapper <- asks diag_wrapper
- lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->
- let lcl_hsc_env = setHUG deps hsc_env
+ msg <- asks me_messager
+ wrapper <- asks me_diag_wrapper
+ lift $ MaybeT $
+ let hsc_env = me_hsc_env env
+ lcl_hsc_env = setHUG deps hsc_env
in wrapAction wrapper lcl_hsc_env $ do
res <- upsweep_inst lcl_hsc_env msg k n uid iu
cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
@@ -1582,13 +1581,13 @@ executeCompileNode :: Int
-> ModuleNodeInfo
-> RunMakeM HomeModInfo
executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do
- me@MakeEnv{..} <- ask
+ make_env <- ask
-- Rehydrate any dependencies if this module had a boot file or is a signature file.
- lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do
+ lift $ MaybeT (withMakeEnvConcurrency make_env $ \hsc_env -> do
hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods
case mni of
- ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod
- ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc
+ ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' make_env mod
+ ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' make_env key loc
)
where
@@ -1601,9 +1600,9 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do
_ -> mrehydrate_mods
executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)
- executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc =
- wrapAction diag_wrapper hsc_env $ do
- forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc))
+ executeCompileNodeFixed hsc_env MakeEnv{me_diag_wrapper, me_messager} mod loc =
+ wrapAction me_diag_wrapper hsc_env $ do
+ forM_ me_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc))
read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc)
let sec = initSourceErrorContext (hsc_dflags hsc_env)
case read_result of
@@ -1619,7 +1618,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do
return (HomeModInfo iface details hm_linkable)
executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)
- executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do
+ executeCompileNodeWithSource hsc_env MakeEnv{me_diag_wrapper, me_messager} mod = do
let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
lcl_dynflags = ms_hspp_opts mod
let lcl_hsc_env =
@@ -1628,8 +1627,8 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do
hsc_env
-- Compile the module, locking with a semaphore to avoid too many modules
-- being compiled at the same time leading to high memory usage.
- wrapAction diag_wrapper lcl_hsc_env $ do
- res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
+ wrapAction me_diag_wrapper lcl_hsc_env $ do
+ res <- upsweep_mod lcl_hsc_env me_messager old_hmi mod k n
cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
return res
@@ -1853,15 +1852,15 @@ Also closely related are
-}
executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
-executeLinkNode hug kn@(k, _) uid deps = do
+executeLinkNode hug kn uid deps = do
withCurrentUnit uid $ do
make_env@MakeEnv{..} <- ask
- let dflags = hsc_dflags hsc_env
- msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager
+ let dflags = hsc_dflags me_hsc_env
+ msg' = (\messager -> \recomp -> messager me_hsc_env kn recomp (LinkNode deps uid)) <$> me_messager
- linkresult <- lift $ MaybeT $ withAbstractSem compile_sem $ withLoggerHsc k make_env $ \lcl_hsc_env -> do
+ linkresult <- lift $ MaybeT $ withMakeEnvConcurrency make_env $ \lcl_hsc_env -> do
let hsc_env' = setHUG hug lcl_hsc_env
- wrapAction diag_wrapper hsc_env' $ do
+ wrapAction me_diag_wrapper hsc_env' $ do
link (ghcLink dflags)
hsc_env'
True -- We already decided to link
=====================================
compiler/GHC/Driver/MakeAction.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
module GHC.Driver.MakeAction
( MakeAction(..)
, RunMakeM
@@ -7,79 +6,41 @@ module GHC.Driver.MakeAction
-- * Running the pipelines
, runAllPipelines
, runPipelines
- -- * Worker limit
- , WorkerLimit(..)
- , mkWorkerLimit
- , runWorkerLimit
-- * Utility
- , withLoggerHsc
- , withParLog
- , withLocalTmpFS
- , withLocalTmpFSMake
+ , withMakeEnvConcurrency
+ , withWorkerLimitHsc
+ , viewHscWorkerEnv
+ , setHscWorkerEnv
) where
import GHC.Prelude
-import GHC.Driver.DynFlags
-import GHC.Driver.Monad
+import GHC.Driver.Concurrency
+import GHC.Driver.Config.Concurrency
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Driver.Messager
-import GHC.Driver.MakeSem
-
-#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
-import System.Semaphore
- ( SemaphoreIdentifier )
-#else
-import System.Semaphore
- ( SemaphoreError, SemaphoreIdentifier )
-#endif
-
-#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
-import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
-import GHC.Driver.Errors ( printOrThrowDiagnostics )
-import GHC.Types.Error ( singleMessage )
-import GHC.Types.SrcLoc ( noSrcSpan )
-import GHC.Utils.Error ( mkPlainMsgEnvelope )
-#endif
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
+import GHC.Driver.Monad
-#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
-import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask )
-#else
-import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
-#endif
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import qualified Control.Monad.Catch as MC
-
-#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
-import GHC.Conc ( getNumProcessors )
-#else
-import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
-#endif
-import Control.Monad.Trans.Reader
-import GHC.Driver.Pipeline.LogQueue
-import Control.Concurrent.STM
import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
--------------------------------------------------------------------------------
-- * MakeEnv and MakeAction
--------------------------------------------------------------------------------
-- | Environment used when compiling a module
-data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
- , compile_sem :: !AbstractSem
- -- Modify the environment for module k, with the supplied logger modification function.
- -- For -j1, this wrapper doesn't do anything
- -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
- -- into the log queue.
- , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
- , env_messager :: !(Maybe Messager)
- , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
- }
+data MakeEnv =
+ MakeEnv
+ { me_hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
+ , me_concurrency :: !Concurrency
+ , me_messager :: !(Maybe Messager)
+ , me_diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
+ }
-- | Come up with a 'MakeEnv' based on the given 'WorkerLimit'.
-- For -j1, it will be a trivial 'MakeEnv' not prepared for parallelism.
@@ -91,47 +52,14 @@ withMakeEnv
-> Maybe Messager -- ^ Optional custom messager to use to report progress
-> (MakeEnv -> IO r) -> IO r
withMakeEnv worker_limit hsc_env diag_wrapper mHscMessager act =
- if isWorkerLimitSequential worker_limit
- then withSeqMakeEnv
- else withParMakeEnv
- where
- withSeqMakeEnv = do
- let seq_env = MakeEnv
- { hsc_env = hsc_env
- , withLogger = \_ k -> k id
- , compile_sem = AbstractSem (return ()) (return ())
- , env_messager = mHscMessager
- , diag_wrapper = diag_wrapper
- }
- act seq_env
-
- withParMakeEnv = do
- -- A variable which we write to when an error has happened and we have to tell the
- -- logging thread to gracefully shut down.
- stopped_var <- newTVarIO False
- -- The queue of LogQueues which actions are able to write to. When an action starts it
- -- will add it's LogQueue into this queue.
- log_queue_queue_var <- newTVarIO newLogQueueQueue
- -- Thread which coordinates the printing of logs
- wait_log_thread <- logThread (hsc_logger hsc_env) stopped_var log_queue_queue_var
-
-
- -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
- thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger hsc_env)
- let thread_safe_hsc_env = hsc_env { hsc_logger = thread_safe_logger }
-
- runWorkerLimit (hsc_logger hsc_env) (hsc_dflags hsc_env) worker_limit $ \abstract_sem -> do
- let env = MakeEnv { hsc_env = thread_safe_hsc_env
- , withLogger = withParLog log_queue_queue_var
- , compile_sem = abstract_sem
- , env_messager = mHscMessager
- , diag_wrapper = diag_wrapper
- }
- -- Reset the number of capabilities once the upsweep ends.
- r <- act env
- atomically $ writeTVar stopped_var True
- wait_log_thread
- pure r
+ withWorkerLimitHsc hsc_env worker_limit $ \ conc hsc_env' ->
+ act $
+ MakeEnv
+ { me_hsc_env = hsc_env'
+ , me_concurrency = conc
+ , me_messager = mHscMessager
+ , me_diag_wrapper = diag_wrapper
+ }
-- ** MakeAction ---------------------------------------------------------------
@@ -139,9 +67,6 @@ data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
-waitMakeAction :: MakeAction -> IO ()
-waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
-
--------------------------------------------------------------------------------
-- * Running the pipelines
--------------------------------------------------------------------------------
@@ -155,149 +80,51 @@ runPipelines
runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do
liftIO $ label_self "main --make thread"
withMakeEnv n_job hsc_env diag_wrapper mHscMessager $ \make_env -> do
- runAllPipelines n_job make_env all_pipelines
+ runAllPipelines make_env all_pipelines
where
label_self :: String -> IO ()
label_self thread_name = do
self_tid <- CC.myThreadId
CC.labelThread self_tid thread_name
--- | Run the given actions and then wait for them all to finish.
-runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
-runAllPipelines worker_limit env acts = do
- let single_worker = isWorkerLimitSequential worker_limit
- spawn_actions :: IO [ThreadId]
- spawn_actions = if single_worker
- then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)
- else runLoop forkIOWithUnmask env acts
-
- kill_actions :: [ThreadId] -> IO ()
- kill_actions tids = mapM_ killThread tids
-
- MC.bracket spawn_actions kill_actions $ \_ -> do
- mapM_ waitMakeAction acts
-
--- | Execute each action in order, limiting the amount of parallelism by the given
--- semaphore.
-runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
-runLoop _ _env [] = return []
-runLoop fork_thread env (MakeAction act res_var :acts) = do
-
- -- withLocalTmpFs has to occur outside of fork to remain deterministic
- new_thread <- withLocalTmpFSMake env $ \lcl_env ->
- MC.mask_ $
- fork_thread $ \unmask -> (do
- mres <- (unmask $ run_pipeline lcl_env act)
- `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
- putMVar res_var mres)
- threads <- runLoop fork_thread env acts
- return (new_thread : threads)
- where
- run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)
- run_pipeline env p = runMaybeT (runReaderT p env)
-
---------------------------------------------------------------------------------
--- * Worker Limit
---------------------------------------------------------------------------------
-
--- | This describes what we use to limit the number of jobs, either we limit it
--- ourselves to a specific number or we have an external parallelism semaphore
--- limit it for us.
-data WorkerLimit
- = NumProcessorsLimit Int
- | JSemLimit
- SemaphoreIdentifier
- -- ^ Semaphore identifier from @-jsem@
- deriving Eq
-
-mkWorkerLimit :: DynFlags -> IO WorkerLimit
-mkWorkerLimit dflags =
- case parMakeCount dflags of
- Nothing -> pure $ num_procs 1
- Just (ParMakeSemaphore h) -> pure (JSemLimit h)
- Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
- Just (ParMakeThisMany n) -> pure $ num_procs n
- where
- num_procs x = NumProcessorsLimit (max 1 x)
-
-isWorkerLimitSequential :: WorkerLimit -> Bool
-isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1
-isWorkerLimitSequential (JSemLimit {}) = False
-
-runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
-#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
-runWorkerLimit _logger _dflags _ action = do
- lock <- newMVar ()
- action $ AbstractSem (takeMVar lock) (putMVar lock ())
-#else
-runWorkerLimit logger dflags worker_limit action = case worker_limit of
- NumProcessorsLimit n_jobs ->
- runNjobsAbstractSem n_jobs action
- JSemLimit sem_ident -> do
- result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
- case result of
- Right a -> return a
- Left err -> do
- let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
- msg = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
- printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
- runNjobsAbstractSem 1 action
-#endif
-
-#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
-runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
-runNjobsAbstractSem n_jobs action = do
- compile_sem <- newQSem n_jobs
- n_capabilities <- getNumCapabilities
- n_cpus <- getNumProcessors
- let
- asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
- set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n
- updNumCapabilities = do
- -- Setting number of capabilities more than
- -- CPU count usually leads to high userspace
- -- lock contention. #9221
- set_num_caps $ min n_jobs n_cpus
- resetNumCapabilities = set_num_caps n_capabilities
- MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
-
-#endif
+-- | Run the given actions (assumed to be in dependency order) and wait for
+-- them all to finish, rethrowing the first unhandled exception (in action order)
+-- afterwards.
+runAllPipelines :: MakeEnv -> [MakeAction] -> IO ()
+runAllPipelines env acts =
+ void $
+ mapConcurrentWorkers "make_worker" (me_concurrency env) (viewHscWorkerEnv (me_hsc_env env))
+ ( \ work_env (MakeAction act res_var) -> do
+ let lcl_env = env { me_hsc_env = setHscWorkerEnv work_env (me_hsc_env env) }
+ mres <- runMaybeT (runReaderT act lcl_env)
+ `MC.onException` putMVar res_var Nothing
+ putMVar res_var mres )
+ acts
--------------------------------------------------------------------------------
-- * Utility
--------------------------------------------------------------------------------
-withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
-withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do
- withLogger k $ \modifyLogger -> do
- let lcl_logger = modifyLogger (hsc_logger hsc_env)
- hsc_env' = hsc_env { hsc_logger = lcl_logger }
- -- Run continuation with modified logger
- cont hsc_env'
-
-withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
-withParLog lqq_var k cont = do
- let init_log = do
- -- Make a new log queue
- lq <- newLogQueue k
- -- Add it into the LogQueueQueue
- atomically $ initLogQueue lqq_var lq
- return lq
- finish_log lq = liftIO (finishLogQueue lq)
- MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))
-
-withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a
-withLocalTmpFS tmpfs act = do
- let initialiser = do
- liftIO $ forkTmpFsFrom tmpfs
- finaliser tmpfs_local = do
- liftIO $ mergeTmpFsInto tmpfs_local tmpfs
- -- Add remaining files which weren't cleaned up into local tmp fs for
- -- clean-up later.
- -- Clear the logQueue if this node had it's own log queue
- MC.bracket initialiser finaliser act
-
-withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a
-withLocalTmpFSMake env k =
- withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs
- -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})
+-- | A version of 'withWorkerLimit' taking an 'HscEnv'.
+withWorkerLimitHsc :: HscEnv -> WorkerLimit -> (Concurrency -> HscEnv -> IO a) -> IO a
+withWorkerLimitHsc hsc_env limit k =
+ withWorkerLimit (hsc_logger hsc_env) (hsc_tmpfs hsc_env)
+ (semaphoreOpenFailureHandler (hsc_logger hsc_env) (hsc_dflags hsc_env))
+ limit
+ (\conc work_env -> k conc (setHscWorkerEnv work_env hsc_env))
+
+-- | Like 'withConcurrency', but retrieving the 'Concurrency' and 'HscEnv' from
+-- the 'MakeEnv'.
+withMakeEnvConcurrency :: MakeEnv -> (HscEnv -> IO a) -> IO a
+withMakeEnvConcurrency env cont =
+ withConcurrency (me_concurrency env) (cont (me_hsc_env env))
+
+-- | The local environment for a concurrent worker derived from an 'HscEnv'.
+viewHscWorkerEnv :: HscEnv -> ConcurrentWorkerEnv
+viewHscWorkerEnv hsc_env =
+ ConcurrentWorkerEnv { cwe_logger = hsc_logger hsc_env, cwe_tmpfs = hsc_tmpfs hsc_env }
+
+-- | Set the local concurrent worker environment within an 'HscEnv'.
+setHscWorkerEnv :: ConcurrentWorkerEnv -> HscEnv -> HscEnv
+setHscWorkerEnv (ConcurrentWorkerEnv { cwe_logger = logger, cwe_tmpfs = tmpfs }) hsc_env =
+ hsc_env { hsc_logger = logger, hsc_tmpfs = tmpfs }
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -39,6 +39,7 @@ import GHC.Utils.Json
import System.Semaphore
( AbstractSem(..)
, ClientSemaphore
+ , SemaphoreError
, SemaphoreIdentifier
, SemaphoreToken
, openSemaphore
@@ -534,18 +535,24 @@ makeJobserver sem_ident = do
-- | Implement an abstract semaphore using a semaphore 'Jobserver'
-- which queries the system semaphore of the given name for resources.
+--
+-- Returns 'Left' if the system semaphore could not be opened, in which case
+-- the operation is not run at all. A 'SemaphoreError' arising after the
+-- semaphore was successfully opened is thrown, not returned.
runJSemAbstractSem :: SemaphoreIdentifier -- ^ the semaphore identifier (from @-jsem@)
-> (AbstractSem -> IO a) -- ^ the operation to run
-- which requires a semaphore
- -> IO a
+ -> IO (Either SemaphoreError a)
runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do
- (abs, cleanup) <- makeJobserver sem_ident
- r <- try $ unmask $ action abs
- case r of
- Left (e1 :: MC.SomeException) -> do
- (_ :: Either MC.SomeException ()) <- MC.try cleanup
- MC.throwM e1
- Right x -> cleanup $> x
+ MC.try @_ @SemaphoreError (makeJobserver sem_ident) >>= \case
+ Left open_failure -> return (Left open_failure)
+ Right (abs, cleanup) -> do
+ r <- try $ unmask $ action abs
+ case r of
+ Left (e1 :: MC.SomeException) -> do
+ (_ :: Either MC.SomeException ()) <- MC.try cleanup
+ MC.throwM e1
+ Right x -> cleanup $> Right x
{- Note [Architecture of the Job Server]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Utils/TmpFs.hs
=====================================
@@ -6,6 +6,7 @@ module GHC.Utils.TmpFs
, initTmpFs
, forkTmpFsFrom
, mergeTmpFsInto
+ , withLocalTmpFS
, PathsToClean(..)
, emptyPathsToClean
, TempFileLifetime(..)
@@ -157,6 +158,16 @@ mergeTmpFsInto src dst = do
atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergePathsToClean src_files s, ()))
atomicModifyIORef' (tmp_subdirs_to_clean dst) (\s -> (mergePathsToClean src_subdirs s, ()))
+-- | Run an action with a local 'TmpFs' forked from the given 'TmpFs'.
+--
+-- The remaining files of the local 'TmpFs' which weren't cleaned up by the
+-- action are merged back into the given 'TmpFs', for clean-up later.
+withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a
+withLocalTmpFS tmpfs act =
+ Exception.bracket
+ (forkTmpFsFrom tmpfs)
+ (\tmpfs_local -> mergeTmpFsInto tmpfs_local tmpfs)
+ act
cleanTempDirs :: Logger -> TmpFs -> IO ()
cleanTempDirs logger tmpfs
=====================================
compiler/ghc.cabal.in
=====================================
@@ -487,11 +487,13 @@ Library
GHC.Driver.ByteCode
GHC.Driver.CmdLine
GHC.Driver.CodeOutput
+ GHC.Driver.Concurrency
GHC.Driver.Config
GHC.Driver.Config.Cmm
GHC.Driver.Config.Cmm.Parser
GHC.Driver.Config.CmmToAsm
GHC.Driver.Config.CmmToLlvm
+ GHC.Driver.Config.Concurrency
GHC.Driver.Config.Core.Lint
GHC.Driver.Config.Core.Lint.Interactive
GHC.Driver.Config.Core.Opt.Arity
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -172,7 +172,7 @@ createIfaces verbosity modules flags instIfaceMap = do
_ <- setSessionDynFlags dflags''
targets <- mapM (\(filePath, _) -> guessTarget filePath Nothing Nothing) hs_srcs
setTargets targets
- (_errs, modGraph) <- depanalE mkUnknownDiagnostic (Just batchMsg) [] False
+ (_errs, modGraph) <- depanalE [] False
-- Create (if necessary) and load .hi-files. With --no-compilation this happens later.
when (Flag_NoCompilation `notElem` flags) $ do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/566d789d5522489eb017e9999f0b7bd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/566d789d5522489eb017e9999f0b7bd…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0