.gitlab-ci.yml

@@ -2,7 +2,7 @@ variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: 6ceb0cecaeefd4927b26c054e4897724986078c8
+  DOCKER_REV: 0da9c4be73f2d73868f610d20352af856e8f2727
 
   # Sequential version number capturing the versions of all tools fetched by
   # .gitlab/ci.sh. Used for invalidation of GitLab CI cache.
@@ -307,16 +307,20 @@ hadrian-ghc-in-ghci:
     - .gitlab/ci.sh setup
     - cabal update
     - cd hadrian; cabal new-build -j`../mk/detect-cpu-count.sh` --with-compiler=$GHC --project-file=ci.project; cd ..
+  after_script:
+    - cp -Rf $HOME/.cabal cabal-cache
   variables:
     GHC_FLAGS: -Werror
+  cache:
+    key: lint
+    paths:
+      - cabal-cache
 
 lint-base:
   extends: .lint-params
   script:
     - hadrian/build -c -j stage1:lib:base
     - hadrian/build -j lint:base
-  cache:
-    key: lint
 
 ############################################################
 # Validation via Pipelines (make)
@@ -681,6 +685,25 @@ nightly-x86_64-linux-deb9-integer-simple:
     TEST_ENV: "x86_64-linux-deb9-integer-simple"
     TEST_TYPE: slowtest
 
+.build-x86_64-linux-deb9-tsan:
+  extends: .validate-linux-hadrian
+  stage: full-build
+  variables:
+    TEST_ENV: "x86_64-linux-deb9-tsan"
+    BUILD_FLAVOUR: "thread-sanitizer"
+    TSAN_OPTIONS: "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"
+    # Haddock is large enough to make TSAN choke without massive quantities of
+    # memory.
+    HADRIAN_ARGS: "--docs=none"
+
+nightly-x86_64-linux-deb9-tsan:
+  <<: *nightly
+  extends: .build-x86_64-linux-deb9-tsan
+
+validate-x86_64-linux-deb9-tsan:
+  extends: .build-x86_64-linux-deb9-tsan
+  when: manual
+
 validate-x86_64-linux-deb9-dwarf:
   extends: .build-x86_64-linux-deb9
   stage: full-build

compiler/.hlint.yaml

@@ -5,3 +5,20 @@
 - ignore: {}
 - warn: {name: Unused LANGUAGE pragma}
 - warn: {name: Use fewer LANGUAGE pragmas}
+- warn: {name: Redundant return}
+- warn: {name: Redundant True guards}
+- warn: {name: Redundant do}
+- warn: {name: Redundant variable capture}
+- warn: {name: Redundant void}
+- warn: {name: Redundant as}
+- warn: {name: Use fewer imports}
+- warn: {name: Redundant as-pattern}
+- warn: {name: Redundant where}
+
+## Exceptions
+# Sometimes, the hlint parser flags some functions and modules as incorrectly
+# using a language extension. Some other times, we need to make exceptions to
+# lints that we otherwise want applied elsewhere. Such exceptions are listed
+# below.
+
+- ignore: {name: Redundant do, within: [GHC.SysTools.Terminal, GHC.Utils.Binary]}

compiler/GHC.hs

@@ -264,6 +264,7 @@ module GHC (
 
         -- * Exceptions
         GhcException(..), showGhcException,
+        GhcApiError(..),
 
         -- * Token stream manipulations
         Token,
@@ -274,10 +275,7 @@ module GHC (
         parser,
 
         -- * API Annotations
-        ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
-        getAnnotation, getAndRemoveAnnotation,
-        getAnnotationComments, getAndRemoveAnnotationComments,
-        unicodeAnn,
+        ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
 
         -- * Miscellaneous
         --sessionHscEnv,
@@ -294,14 +292,14 @@ module GHC (
 
 import GHC.Prelude hiding (init)
 
-import GHC.ByteCode.Types
-import GHC.Runtime.Eval
-import GHC.Runtime.Eval.Types
-import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.Types
-import GHCi.RemoteTypes
+import GHC.Platform
+import GHC.Platform.Ways
 
-import GHC.Core.Ppr.TyThing  ( pprFamInst )
+import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
+                           , isSourceFilename, startPhase )
+import GHC.Driver.Env
+import GHC.Driver.CmdLine
+import GHC.Driver.Session hiding (WarnReason(..))
 import GHC.Driver.Backend
 import GHC.Driver.Config
 import GHC.Driver.Main
@@ -309,19 +307,49 @@ import GHC.Driver.Make
 import GHC.Driver.Hooks
 import GHC.Driver.Pipeline   ( compileOne' )
 import GHC.Driver.Monad
-import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import GHC.Driver.Ppr
+
+import GHC.ByteCode.Types
+import GHC.Runtime.Eval
+import GHC.Runtime.Eval.Types
+import GHC.Runtime.Interpreter
+import GHC.Runtime.Interpreter.Types
+import GHC.Runtime.Context
+import GHCi.RemoteTypes
+
+import qualified GHC.Parser as Parser
+import GHC.Parser.Lexer
+import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
+
 import GHC.Iface.Load        ( loadSysInterface )
+import GHC.Hs
+import GHC.Builtin.Types.Prim ( alphaTyVars )
+import GHC.Iface.Tidy
+import GHC.Data.Bag        ( listToBag )
+import GHC.Data.StringBuffer
+import GHC.Data.FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
 import GHC.Tc.Types
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Module
+import GHC.Tc.Utils.Instantiate
+import GHC.Tc.Instance.Family
+
+import GHC.SysTools.FileCleanup
+import GHC.SysTools
+import GHC.SysTools.BaseDir
+
+import GHC.Utils.Error
+import GHC.Utils.Monad
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
 import GHC.Core.Predicate
-import GHC.Unit
-import GHC.Unit.State
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Hs
 import GHC.Core.Type  hiding( typeKind )
-import GHC.Tc.Utils.TcType
-import GHC.Types.Id
-import GHC.Builtin.Types.Prim ( alphaTyVars )
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Ppr   ( pprForAll )
 import GHC.Core.Class
@@ -329,42 +357,37 @@ import GHC.Core.DataCon
 import GHC.Core.FVs        ( orphNamesOfFamInst )
 import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
 import GHC.Core.InstEnv
+import GHC.Core
+
+import GHC.Types.Id
 import GHC.Types.Name      hiding ( varName )
 import GHC.Types.Avail
 import GHC.Types.SrcLoc
-import GHC.Core
-import GHC.Iface.Tidy
-import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
-                           , isSourceFilename, startPhase )
-import GHC.Driver.Finder
-import GHC.Driver.Types
-import GHC.Driver.CmdLine
-import GHC.Driver.Session hiding (WarnReason(..))
-import GHC.Platform.Ways
-import GHC.Driver.Ppr
-import GHC.SysTools
-import GHC.SysTools.BaseDir
+import GHC.Types.TyThing.Ppr  ( pprFamInst )
 import GHC.Types.Annotations
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Data.Bag        ( listToBag )
-import GHC.Utils.Error
-import GHC.Utils.Monad
-import GHC.Utils.Misc
-import GHC.Data.StringBuffer
-import GHC.Utils.Outputable
+import GHC.Types.Name.Set
+import GHC.Types.Name.Reader
+import GHC.Types.SourceError
+import GHC.Types.SafeHaskell
+import GHC.Types.Fixity
+import GHC.Types.Target
 import GHC.Types.Basic
-import GHC.Data.FastString
-import qualified GHC.Parser as Parser
-import GHC.Parser.Lexer
-import GHC.Parser.Annotation
-import GHC.Parser.Errors.Ppr
-import qualified GHC.LanguageExtensions as LangExt
+import GHC.Types.TyThing
 import GHC.Types.Name.Env
-import GHC.Tc.Module
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Family
-import GHC.SysTools.FileCleanup
+import GHC.Types.Name.Ppr
+import GHC.Types.TypeEnv
+import GHC.Types.SourceFile
+
+import GHC.Unit
+import GHC.Unit.External
+import GHC.Unit.State
+import GHC.Unit.Finder
+import GHC.Unit.Module.ModIface
+import GHC.Unit.Module.ModGuts
+import GHC.Unit.Module.ModDetails
+import GHC.Unit.Module.ModSummary
+import GHC.Unit.Module.Graph
+import GHC.Unit.Home.ModInfo
 
 import Data.Foldable
 import qualified Data.Map.Strict as Map
@@ -595,12 +618,6 @@ checkBrokenTablesNextToCode' dflags
 -- read), and prepares the compilers knowledge about packages.  It can
 -- be called again to load new packages: just add new package flags to
 -- (packageFlags dflags).
---
--- Returns a list of new packages that may need to be linked in using
--- the dynamic linker (see 'linkPackages') as a result of new package
--- flags.  If you are not doing linking or doing static linking, you
--- can ignore the list of packages returned.
---
 setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
 setSessionDynFlags dflags0 = do
   dflags1 <- checkNewDynFlags dflags0
@@ -1507,7 +1524,7 @@ getModuleSourceAndFlags mod = do
 -- | Return module source as token stream, including comments.
 --
 -- The module must be in the module graph and its source must be available.
--- Throws a 'GHC.Driver.Types.SourceError' on parse error.
+-- Throws a 'GHC.Driver.Env.SourceError' on parse error.
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
 getTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
@@ -1842,3 +1859,15 @@ interpretPackageEnv dflags = do
          "Package environment "
       ++ show env
       ++ " (specified in GHC_ENVIRONMENT) not found"
+
+-- | An error thrown if the GHC API is used in an incorrect fashion.
+newtype GhcApiError = GhcApiError String
+
+instance Show GhcApiError where
+  show (GhcApiError msg) = msg
+
+instance Exception GhcApiError
+
+mkApiErr :: DynFlags -> SDoc -> GhcApiError
+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
+

compiler/GHC/Builtin/PrimOps.hs

@@ -39,10 +39,11 @@ import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
 import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )
 import GHC.Core.Type
 import GHC.Types.RepType ( tyConPrimRep1 )
-import GHC.Types.Basic   ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
-                           SourceText(..) )
+import GHC.Types.Basic   ( Arity, Boxity(..) )
+import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) )
 import GHC.Types.SrcLoc  ( wiredInSrcSpan )
 import GHC.Types.ForeignCall ( CLabelString )
+import GHC.Types.SourceText  ( SourceText(..) )
 import GHC.Types.Unique  ( Unique)
 import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )
 import GHC.Unit.Types    ( Unit )

compiler/GHC/Builtin/Types.hs

@@ -164,13 +164,15 @@ import GHC.Builtin.Uniques
 -- others:
 import GHC.Core.Coercion.Axiom
 import GHC.Types.Id
+import GHC.Types.TyThing
+import GHC.Types.SourceText
 import GHC.Types.Var (VarBndr (Bndr))
 import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
 import GHC.Unit.Module        ( Module )
 import GHC.Core.Type
 import GHC.Types.RepType
 import GHC.Core.DataCon
-import {-# SOURCE #-} GHC.Core.ConLike
+import GHC.Core.ConLike
 import GHC.Core.TyCon
 import GHC.Core.Class     ( Class, mkClass )
 import GHC.Types.Name.Reader

compiler/GHC/Builtin/Types/Prim.hs

@@ -115,6 +115,7 @@ import {-# SOURCE #-} GHC.Builtin.Types
 
 import GHC.Types.Var    ( TyVar, mkTyVar )
 import GHC.Types.Name
+import {-# SOURCE #-} GHC.Types.TyThing
 import GHC.Core.TyCon
 import GHC.Types.SrcLoc
 import GHC.Types.Unique
@@ -199,14 +200,14 @@ mkPrimTc :: FastString -> Unique -> TyCon -> Name
 mkPrimTc fs unique tycon
   = mkWiredInName gHC_PRIM (mkTcOccFS fs)
                   unique
-                  (ATyCon tycon)        -- Relevant TyCon
+                  (mkATyCon tycon)        -- Relevant TyCon
                   UserSyntax
 
 mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name
 mkBuiltInPrimTc fs unique tycon
   = mkWiredInName gHC_PRIM (mkTcOccFS fs)
                   unique
-                  (ATyCon tycon)        -- Relevant TyCon
+                  (mkATyCon tycon)        -- Relevant TyCon
                   BuiltInSyntax
 
 
@@ -547,7 +548,7 @@ mkPrimTyConName = mkPrimTcName BuiltInSyntax
 
 mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name
 mkPrimTcName built_in_syntax occ key tycon
-  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax
+  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax
 
 -----------------------------
 -- | Given a RuntimeRep, applies TYPE to it.

compiler/GHC/Builtin/Utils.hs

@@ -50,31 +50,34 @@ module GHC.Builtin.Utils (
 import GHC.Prelude
 
 import GHC.Builtin.Uniques
-import GHC.Types.Unique ( isValidKnownKeyUnique )
-
-import GHC.Core.ConLike ( ConLike(..) )
+import GHC.Builtin.PrimOps
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Literals ( typeNatTyCons )
+import GHC.Builtin.Types.Prim
 import GHC.Builtin.Names.TH ( templateHaskellNames )
 import GHC.Builtin.Names
+
+import GHC.Core.ConLike ( ConLike(..) )
 import GHC.Core.Opt.ConstantFold
-import GHC.Types.Avail
-import GHC.Builtin.PrimOps
 import GHC.Core.DataCon
+import GHC.Core.Class
+import GHC.Core.TyCon
+
+import GHC.Types.Avail
 import GHC.Types.Basic
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.Id.Make
-import GHC.Utils.Outputable
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types
-import GHC.Driver.Types
-import GHC.Core.Class
-import GHC.Core.TyCon
 import GHC.Types.Unique.FM
+import GHC.Types.TyThing
+import GHC.Types.Unique ( isValidKnownKeyUnique )
+
+import GHC.Utils.Outputable
 import GHC.Utils.Misc as Utils
 import GHC.Utils.Panic
-import GHC.Builtin.Types.Literals ( typeNatTyCons )
 import GHC.Hs.Doc
+import GHC.Unit.Module.ModIface (IfaceExport)
 
 import Control.Applicative ((<|>))
 import Data.List        ( intercalate , find )

compiler/GHC/Builtin/bytearray-ops.txt.pp

+
+------------------------------------
+-- ByteArray# operations
+------------------------------------
+
+
+-- Do not edit. This file is generated by utils/genprimopcode/gen_bytearray_ops.py.
+-- To regenerate run,
+--
+--      python3 utils/genprimops/gen_bytearray_ops.py > compiler/GHC/Builtin/bytearray-ops.txt.pp
+
+
+------------------------------------
+-- aligned index operations
+------------------------------------
+
+primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read a 8-bit character; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read a 32-bit character; offset in 4-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read a word-sized integer; offset in machine words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read a word-sized unsigned integer; offset in machine words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp
+   ByteArray# -> Int# -> Addr#
+   {Read a machine address; offset in machine words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp
+   ByteArray# -> Int# -> Float#
+   {Read a single-precision floating-point value; offset in 4-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp
+   ByteArray# -> Int# -> Double#
+   {Read a double-precision floating-point value; offset in 8-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp
+   ByteArray# -> Int# -> StablePtr# a
+   {Read a {\tt StablePtr#} value; offset in machine words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read a 8-bit signed integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read a 16-bit signed integer; offset in 2-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp
+   ByteArray# -> Int# -> INT32
+   {Read a 32-bit signed integer; offset in 4-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp
+   ByteArray# -> Int# -> INT64
+   {Read a 64-bit signed integer; offset in 8-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read a 8-bit unsigned integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read a 16-bit unsigned integer; offset in 2-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp
+   ByteArray# -> Int# -> WORD32
+   {Read a 32-bit unsigned integer; offset in 4-byte words.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp
+   ByteArray# -> Int# -> WORD64
+   {Read a 64-bit unsigned integer; offset in 8-byte words.}
+   with can_fail = True
+
+
+------------------------------------
+-- unaligned index operations
+------------------------------------
+
+primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read a 8-bit character; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read a 32-bit character; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read a word-sized integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read a word-sized unsigned integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp
+   ByteArray# -> Int# -> Addr#
+   {Read a machine address; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp
+   ByteArray# -> Int# -> Float#
+   {Read a single-precision floating-point value; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp
+   ByteArray# -> Int# -> Double#
+   {Read a double-precision floating-point value; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp
+   ByteArray# -> Int# -> StablePtr# a
+   {Read a {\tt StablePtr#} value; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read a 16-bit signed integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp
+   ByteArray# -> Int# -> INT32
+   {Read a 32-bit signed integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp
+   ByteArray# -> Int# -> INT64
+   {Read a 64-bit signed integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read a 16-bit unsigned integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp
+   ByteArray# -> Int# -> WORD32
+   {Read a 32-bit unsigned integer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp
+   ByteArray# -> Int# -> WORD64
+   {Read a 64-bit unsigned integer; offset in bytes.}
+   with can_fail = True
+
+
+------------------------------------
+-- aligned read operations
+------------------------------------
+
+primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   {Read a 8-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   {Read a 32-bit character; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   {Read a word-sized integer; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   {Read a word-sized unsigned integer; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
+   {Read a machine address; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
+   {Read a single-precision floating-point value; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
+   {Read a double-precision floating-point value; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
+   {Read a {\tt StablePtr#} value; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   {Read a 8-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   {Read a 16-bit signed integer; offset in 2-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
+   {Read a 32-bit signed integer; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
+   {Read a 64-bit signed integer; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   {Read a 8-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   {Read a 16-bit unsigned integer; offset in 2-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
+   {Read a 32-bit unsigned integer; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
+   {Read a 64-bit unsigned integer; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+
+------------------------------------
+-- unaligned read operations
+------------------------------------
+
+primop ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   {Read a 8-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   {Read a 32-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   {Read a word-sized integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   {Read a word-sized unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
+   {Read a machine address; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
+   {Read a single-precision floating-point value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
+   {Read a double-precision floating-point value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
+   {Read a {\tt StablePtr#} value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   {Read a 16-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
+   {Read a 32-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
+   {Read a 64-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   {Read a 16-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
+   {Read a 32-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
+   {Read a 64-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+
+------------------------------------
+-- aligned write operations
+------------------------------------
+
+primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   {Write a 8-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   {Write a 32-bit character; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   {Write a word-sized integer; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   {Write a word-sized unsigned integer; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
+   {Write a machine address; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
+   {Write a single-precision floating-point value; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
+   {Write a double-precision floating-point value; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
+   {Write a {\tt StablePtr#} value; offset in machine words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   {Write a 8-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   {Write a 16-bit signed integer; offset in 2-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
+   {Write a 32-bit signed integer; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
+   {Write a 64-bit signed integer; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   {Write a 8-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   {Write a 16-bit unsigned integer; offset in 2-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
+   {Write a 32-bit unsigned integer; offset in 4-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
+   {Write a 64-bit unsigned integer; offset in 8-byte words.}
+   with has_side_effects = True
+        can_fail = True
+
+
+------------------------------------
+-- unaligned write operations
+------------------------------------
+
+primop WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   {Write a 8-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   {Write a 32-bit character; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   {Write a word-sized integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   {Write a word-sized unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp
+   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
+   {Write a machine address; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp
+   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
+   {Write a single-precision floating-point value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp
+   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
+   {Write a double-precision floating-point value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp
+   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
+   {Write a {\tt StablePtr#} value; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   {Write a 16-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
+   {Write a 32-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
+   {Write a 64-bit signed integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   {Write a 16-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
+   {Write a 32-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+
+primop WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
+   {Write a 64-bit unsigned integer; offset in bytes.}
+   with has_side_effects = True
+        can_fail = True
+

compiler/GHC/Builtin/primops.txt.pp

@@ -1546,455 +1546,7 @@ primop  GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp
    MutableByteArray# s -> State# s -> (# State# s, Int# #)
    {Return the number of elements in the array.}
 
-primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp
-   ByteArray# -> Int# -> Char#
-   {Read 8-bit character; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp
-   ByteArray# -> Int# -> Char#
-   {Read 31-bit character; offset in 4-byte words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp
-   ByteArray# -> Int# -> Int#
-   with can_fail = True
-
-primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp
-   ByteArray# -> Int# -> Word#
-   with can_fail = True
-
-primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp
-   ByteArray# -> Int# -> Addr#
-   with can_fail = True
-
-primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp
-   ByteArray# -> Int# -> Float#
-   with can_fail = True
-
-primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp
-   ByteArray# -> Int# -> Double#
-   with can_fail = True
-
-primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp
-   ByteArray# -> Int# -> StablePtr# a
-   with can_fail = True
-
-primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp
-   ByteArray# -> Int# -> Int#
-   {Read 8-bit integer; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp
-   ByteArray# -> Int# -> Int#
-   {Read 16-bit integer; offset in 16-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp
-   ByteArray# -> Int# -> INT32
-   {Read 32-bit integer; offset in 32-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp
-   ByteArray# -> Int# -> INT64
-   {Read 64-bit integer; offset in 64-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp
-   ByteArray# -> Int# -> Word#
-   {Read 8-bit word; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp
-   ByteArray# -> Int# -> Word#
-   {Read 16-bit word; offset in 16-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp
-   ByteArray# -> Int# -> WORD32
-   {Read 32-bit word; offset in 32-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp
-   ByteArray# -> Int# -> WORD64
-   {Read 64-bit word; offset in 64-bit words.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp
-   ByteArray# -> Int# -> Char#
-   {Read 8-bit character; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp
-   ByteArray# -> Int# -> Char#
-   {Read 31-bit character; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp
-   ByteArray# -> Int# -> Addr#
-   {Read address; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp
-   ByteArray# -> Int# -> Float#
-   {Read float; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp
-   ByteArray# -> Int# -> Double#
-   {Read double; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp
-   ByteArray# -> Int# -> StablePtr# a
-   {Read stable pointer; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp
-   ByteArray# -> Int# -> Int#
-   {Read 16-bit int; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp
-   ByteArray# -> Int# -> INT32
-   {Read 32-bit int; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp
-   ByteArray# -> Int# -> INT64
-   {Read 64-bit int; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp
-   ByteArray# -> Int# -> Int#
-   {Read int; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp
-   ByteArray# -> Int# -> Word#
-   {Read 16-bit word; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp
-   ByteArray# -> Int# -> WORD32
-   {Read 32-bit word; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp
-   ByteArray# -> Int# -> WORD64
-   {Read 64-bit word; offset in bytes.}
-   with can_fail = True
-
-primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp
-   ByteArray# -> Int# -> Word#
-   {Read word; offset in bytes.}
-   with can_fail = True
-
-primop  ReadByteArrayOp_Char "readCharArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
-   {Read 8-bit character; offset in bytes.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
-   {Read 31-bit character; offset in 4-byte words.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Int "readIntArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   {Read integer; offset in machine words.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word "readWordArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
-   {Read word; offset in machine words.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Float "readFloatArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp
-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Char "writeCharArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
-   {Write 8-bit character; offset in bytes.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
-   {Write 31-bit character; offset in 4-byte words.}
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Int "writeIntArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word "writeWordArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp
-   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
-   with can_fail = True
-        has_side_effects = True
-
-primop  WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp
-   MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp
-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp
-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp
-   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp
-   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp
-   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp
-   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp
-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp
-   MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp
-   MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp
-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp
-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp
-   MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp
-   MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
-
-primop  WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp
-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
-   with has_side_effects = True
-        can_fail = True
+#include "bytearray-ops.txt.pp"
 
 primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp
    ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
@@ -2527,39 +2079,47 @@ primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
    with has_side_effects = True
         can_fail         = True
 
-primop  InterlockedExchange_Addr "atomicExchangeAddr#" GenPrimOp
+primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp
    Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
    {The atomic exchange operation. Atomically exchanges the value at the first address
     with the Addr# given as second argument. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  InterlockedExchange_Int "atomicExchangeInt#" GenPrimOp
-   Addr# -> Int# -> State# s -> (# State# s, Int# #)
+primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp
+   Addr# -> Word# -> State# s -> (# State# s, Word# #)
    {The atomic exchange operation. Atomically exchanges the value at the address
     with the given value. Returns the old value. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  AtomicCompareExchange_Int "atomicCasInt#" GenPrimOp
-   Addr# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
+primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp
+   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
    { Compare and swap on a word-sized memory location.
 
-     Use as atomicCasInt# location expected desired
+     Use as: \s -> atomicCasAddrAddr# location expected desired s
 
-     This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
 
      Implies a full memory barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  AtomicCompareExchange_Addr "atomicCasAddr#" GenPrimOp
-   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
-   { Compare and swap on a word-sized memory location.
+primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp
+   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
+   { Compare and swap on a word-sized and aligned memory location.
 
-     Use as atomicCasAddr# location expected desired
+     Use as: \s -> atomicCasWordAddr# location expected desired s
 
-     This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
 
      Implies a full memory barrier.}
    with has_side_effects = True
+        can_fail         = True
 
 ------------------------------------------------------------------------
 section "Mutable variables"

compiler/GHC/ByteCode/Asm.hs

@@ -19,27 +19,30 @@ module GHC.ByteCode.Asm (
 
 import GHC.Prelude
 
+import GHC.Driver.Env
+import GHC.Driver.Session
+
 import GHC.ByteCode.Instr
 import GHC.ByteCode.InfoTable
 import GHC.ByteCode.Types
 import GHCi.RemoteTypes
 import GHC.Runtime.Interpreter
+import GHC.Runtime.Heap.Layout
 
-import GHC.Driver.Types
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Literal
+import GHC.Types.Unique
+import GHC.Types.Unique.DSet
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc
+
 import GHC.Core.TyCon
 import GHC.Data.FastString
 import GHC.StgToCmm.Layout     ( ArgRep(..) )
-import GHC.Runtime.Heap.Layout
-import GHC.Driver.Session
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
 import GHC.Platform
-import GHC.Utils.Misc
-import GHC.Types.Unique
-import GHC.Types.Unique.DSet
 
 -- From iserv
 import SizedSeq

compiler/GHC/ByteCode/InfoTable.hs

@@ -12,21 +12,26 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where
 
 import GHC.Prelude
 
+import GHC.Driver.Session
+import GHC.Driver.Env
+
 import GHC.Platform
 import GHC.Platform.Profile
 
 import GHC.ByteCode.Types
 import GHC.Runtime.Interpreter
-import GHC.Driver.Session
-import GHC.Driver.Types
+
 import GHC.Types.Name       ( Name, getName )
 import GHC.Types.Name.Env
+import GHC.Types.RepType
+
 import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )
 import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import GHC.Core.Multiplicity     ( scaledThing )
-import GHC.Types.RepType
+
 import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
 import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
+
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 

compiler/GHC/ByteCode/Linker.hs

@@ -19,24 +19,29 @@ module GHC.ByteCode.Linker (
 
 import GHC.Prelude
 
+import GHC.Driver.Env
+
+import GHC.Runtime.Interpreter
+import GHC.ByteCode.Types
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
 import GHCi.BreakArray
 import SizedSeq
 
-import GHC.Runtime.Interpreter
-import GHC.ByteCode.Types
-import GHC.Driver.Types
-import GHC.Types.Name
-import GHC.Types.Name.Env
 import GHC.Builtin.PrimOps
+
 import GHC.Unit.Types
 import GHC.Unit.Module.Name
+
 import GHC.Data.FastString
+
 import GHC.Utils.Panic
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
 
+import GHC.Types.Name
+import GHC.Types.Name.Env
+
 -- Standard libraries
 import Data.Array.Unboxed
 import Foreign.Ptr

compiler/GHC/Cmm/CLabel.hs

@@ -118,6 +118,7 @@ module GHC.Cmm.CLabel (
         LabelStyle (..),
         pprDebugCLabel,
         pprCLabel,
+        ppInternalProcLabel,
 
         -- * Others
         dynamicLinkerLabelInfo,
@@ -1082,8 +1083,8 @@ isLocalCLabel this_mod lbl =
 -- that data resides in a DLL or not. [Win32 only.]
 -- @labelDynamic@ returns @True@ if the label is located
 -- in a DLL, be it a data reference or not.
-labelDynamic :: NCGConfig -> Module -> CLabel -> Bool
-labelDynamic config this_mod lbl =
+labelDynamic :: NCGConfig -> CLabel -> Bool
+labelDynamic config lbl =
   case lbl of
    -- is the RTS in a DLL or not?
    RtsLabel _ ->
@@ -1136,6 +1137,7 @@ labelDynamic config this_mod lbl =
     externalDynamicRefs = ncgExternalDynamicRefs config
     platform = ncgPlatform config
     os = platformOS platform
+    this_mod = ncgThisModule config
     this_unit = toUnitId (moduleUnit this_mod)
 
 
@@ -1359,6 +1361,39 @@ pprCLabel platform sty lbl =
    CmmLabel _ _ fs CmmRet      -> maybe_underscore $ ftext fs <> text "_ret"
    CmmLabel _ _ fs CmmClosure  -> maybe_underscore $ ftext fs <> text "_closure"
 
+-- Note [Internal proc labels]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Some tools (e.g. the `perf` utility on Linux) rely on the symbol table
+-- for resolution of function names. To help these tools we provide the
+-- (enabled by default) -fexpose-all-symbols flag which causes GHC to produce
+-- symbols even for symbols with are internal to a module (although such
+-- symbols will have only local linkage).
+--
+-- Note that these labels are *not* referred to by code. They are strictly for
+-- diagnostics purposes.
+--
+-- To avoid confusion, it is desireable to add a module-qualifier to the
+-- symbol name. However, the Name type's Internal constructor doesn't carry
+-- knowledge of the current Module. Consequently, we have to pass this around
+-- explicitly.
+
+-- | Generate a label for a procedure internal to a module (if
+-- 'Opt_ExposeAllSymbols' is enabled).
+-- See Note [Internal proc labels].
+ppInternalProcLabel :: Module     -- ^ the current module
+                    -> CLabel
+                    -> Maybe SDoc -- ^ the internal proc label
+ppInternalProcLabel this_mod (IdLabel nm _ flavour)
+  | isInternalName nm
+  = Just
+     $ text "_" <> ppr this_mod
+    <> char '_'
+    <> ztext (zEncodeFS (occNameFS (occName nm)))
+    <> char '_'
+    <> pprUniqueAlways (getUnique nm)
+    <> ppIdFlavor flavour
+ppInternalProcLabel _ _ = Nothing
 
 ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <> case x of

compiler/GHC/Cmm/Graph.hs

@@ -250,10 +250,10 @@ mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
                 -> UpdFrameOffset
                 -> [CmmExpr]
                 -> CmmAGraph
-mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack =
   lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals
-     updfr_off extra_stack $
-       toCall f (Just ret_lbl) updfr_off ret_off
+    updfr_off extra_stack $
+      toCall f (Just ret_lbl) updfr_off ret_off
 
 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
 -- already on the stack).
@@ -262,9 +262,9 @@ mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
                 -> ByteOff
                 -> UpdFrameOffset
                 -> CmmAGraph
-mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off  = do
+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off =
   lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $
-       toCall f (Just ret_lbl) updfr_off ret_off
+    toCall f (Just ret_lbl) updfr_off ret_off
 
 mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as

compiler/GHC/Cmm/Info/Build.hs

@@ -946,7 +946,8 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
   topSRT <- get
 
   let
-    config = initNCGConfig dflags
+    this_mod = thisModule topSRT
+    config = initNCGConfig dflags this_mod
     profile = targetProfile dflags
     platform = profilePlatform profile
     srtMap = moduleSRTMap topSRT
@@ -1019,8 +1020,6 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
            in
                state{ moduleSRTMap = srt_map }
 
-    this_mod = thisModule topSRT
-
     allStaticData =
       all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls
 
@@ -1048,7 +1047,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
           -- when dynamic linking is used we cannot guarantee that the offset
           -- between the SRT and the info table will fit in the offset field.
           -- Consequently we build a singleton SRT in this case.
-          not (labelDynamic config this_mod lbl)
+          not (labelDynamic config lbl)
 
           -- MachO relocations can't express offsets between compilation units at
           -- all, so we are always forced to build a singleton SRT in this case.

compiler/GHC/Cmm/LayoutStack.hs

@@ -451,26 +451,25 @@ handleLastNode
 
 handleLastNode dflags procpoints liveness cont_info stackmaps
                stack0@StackMap { sm_sp = sp0 } tscp middle last
- = case last of
-    --  At each return / tail call,
-    --  adjust Sp to point to the last argument pushed, which
-    --  is cml_args, after popping any other junk from the stack.
-    CmmCall{ cml_cont = Nothing, .. } -> do
-      let sp_off = sp0 - cml_args
-      return ([], sp_off, last, [], mapEmpty)
-
-    --  At each CmmCall with a continuation:
-    CmmCall{ cml_cont = Just cont_lbl, .. } ->
-       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
-
-    CmmForeignCall{ succ = cont_lbl, .. } -> do
-       return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
-            -- one word of args: the return address
-
-    CmmBranch {}     ->  handleBranches
-    CmmCondBranch {} ->  handleBranches
-    CmmSwitch {}     ->  handleBranches
-
+  = case last of
+      --  At each return / tail call,
+      --  adjust Sp to point to the last argument pushed, which
+      --  is cml_args, after popping any other junk from the stack.
+      CmmCall{ cml_cont = Nothing, .. } -> do
+        let sp_off = sp0 - cml_args
+        return ([], sp_off, last, [], mapEmpty)
+
+      --  At each CmmCall with a continuation:
+      CmmCall{ cml_cont = Just cont_lbl, .. } ->
+        return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
+
+      CmmForeignCall{ succ = cont_lbl, .. } ->
+        return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
+              -- one word of args: the return address
+
+      CmmBranch {}     ->  handleBranches
+      CmmCondBranch {} ->  handleBranches
+      CmmSwitch {}     ->  handleBranches
   where
      platform = targetPlatform dflags
      -- Calls and ForeignCalls are handled the same way:
@@ -1051,7 +1050,7 @@ insertReloadsAsNeeded
     -> BlockId
     -> [CmmBlock]
     -> UniqSM [CmmBlock]
-insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do
+insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =
     toBlockList . fst <$>
         rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
   where

compiler/GHC/Cmm/Pipeline.hs

@@ -24,7 +24,7 @@ import GHC.Types.Unique.Supply
 import GHC.Driver.Session
 import GHC.Driver.Backend
 import GHC.Utils.Error
-import GHC.Driver.Types
+import GHC.Driver.Env
 import Control.Monad
 import GHC.Utils.Outputable
 import GHC.Platform
@@ -62,95 +62,95 @@ cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl
 cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))
 cpsTop dflags proc =
     do
-       ----------- Control-flow optimisations ----------------------------------
-
-       -- The first round of control-flow optimisation speeds up the
-       -- later passes by removing lots of empty blocks, so we do it
-       -- even when optimisation isn't turned on.
-       --
-       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
-            return $ cmmCfgOptsProc splitting_proc_points proc
-       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
-
-       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
-                                          , do_layout = do_layout }} = h
-
-       ----------- Eliminate common blocks -------------------------------------
-       g <- {-# SCC "elimCommonBlocks" #-}
-            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
-                          Opt_D_dump_cmm_cbe "Post common block elimination"
-
-       -- Any work storing block Labels must be performed _after_
-       -- elimCommonBlocks
-
-       ----------- Implement switches ------------------------------------------
-       g <- {-# SCC "createSwitchPlans" #-}
-            runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g
-       dump Opt_D_dump_cmm_switch "Post switch plan" g
-
-       ----------- Proc points -------------------------------------------------
-       let
-         call_pps :: ProcPointSet -- LabelMap
-         call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
-       proc_points <-
-          if splitting_proc_points
-             then do
-               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
-                  minimalProcPointSet platform call_pps g
-               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
-                     FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
-               return pp
-             else
-               return call_pps
-
-       ----------- Layout the stack and manifest Sp ----------------------------
-       (g, stackmaps) <-
-            {-# SCC "layoutStack" #-}
-            if do_layout
-               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
-               else return (g, mapEmpty)
-       dump Opt_D_dump_cmm_sp "Layout Stack" g
-
-       ----------- Sink and inline assignments  --------------------------------
-       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
-            condPass Opt_CmmSink (cmmSink platform) g
-                     Opt_D_dump_cmm_sink "Sink assignments"
-
-       ------------- CAF analysis ----------------------------------------------
-       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
-       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
-
-       g <- if splitting_proc_points
+      ----------- Control-flow optimisations ----------------------------------
+
+      -- The first round of control-flow optimisation speeds up the
+      -- later passes by removing lots of empty blocks, so we do it
+      -- even when optimisation isn't turned on.
+      --
+      CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
+           return $ cmmCfgOptsProc splitting_proc_points proc
+      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+      let !TopInfo {stack_info=StackInfo { arg_space = entry_off
+                                         , do_layout = do_layout }} = h
+
+      ----------- Eliminate common blocks -------------------------------------
+      g <- {-# SCC "elimCommonBlocks" #-}
+           condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
+                         Opt_D_dump_cmm_cbe "Post common block elimination"
+
+      -- Any work storing block Labels must be performed _after_
+      -- elimCommonBlocks
+
+      ----------- Implement switches ------------------------------------------
+      g <- {-# SCC "createSwitchPlans" #-}
+           runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g
+      dump Opt_D_dump_cmm_switch "Post switch plan" g
+
+      ----------- Proc points -------------------------------------------------
+      let
+        call_pps :: ProcPointSet -- LabelMap
+        call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+      proc_points <-
+         if splitting_proc_points
             then do
-               ------------- Split into separate procedures -----------------------
-               let pp_map = {-# SCC "procPointAnalysis" #-}
-                            procPointAnalysis proc_points g
-               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
-                  FormatCMM (ppr pp_map)
-               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
-                    splitAtProcPoints platform l call_pps proc_points pp_map
-                                      (CmmProc h l v g)
-               dumps Opt_D_dump_cmm_split "Post splitting" g
-               return g
-             else do
-               -- attach info tables to return points
-               return $ [attachContInfoTables call_pps (CmmProc h l v g)]
-
-       ------------- Populate info tables with stack info -----------------
-       g <- {-# SCC "setInfoTableStackMap" #-}
-            return $ map (setInfoTableStackMap platform stackmaps) g
-       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
-
-       ----------- Control-flow optimisations -----------------------------
-       g <- {-# SCC "cmmCfgOpts(2)" #-}
-            return $ if optLevel dflags >= 1
-                     then map (cmmCfgOptsProc splitting_proc_points) g
-                     else g
-       g <- return (map removeUnreachableBlocksProc g)
-            -- See Note [unreachable blocks]
-       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
-
-       return (Left (cafEnv, g))
+              pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
+                 minimalProcPointSet platform call_pps g
+              dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
+                    FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
+              return pp
+            else
+              return call_pps
+
+      ----------- Layout the stack and manifest Sp ----------------------------
+      (g, stackmaps) <-
+           {-# SCC "layoutStack" #-}
+           if do_layout
+              then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+              else return (g, mapEmpty)
+      dump Opt_D_dump_cmm_sp "Layout Stack" g
+
+      ----------- Sink and inline assignments  --------------------------------
+      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
+           condPass Opt_CmmSink (cmmSink platform) g
+                    Opt_D_dump_cmm_sink "Sink assignments"
+
+      ------------- CAF analysis ----------------------------------------------
+      let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
+      dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
+
+      g <- if splitting_proc_points
+           then do
+             ------------- Split into separate procedures -----------------------
+             let pp_map = {-# SCC "procPointAnalysis" #-}
+                          procPointAnalysis proc_points g
+             dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
+                FormatCMM (ppr pp_map)
+             g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                  splitAtProcPoints platform l call_pps proc_points pp_map
+                                    (CmmProc h l v g)
+             dumps Opt_D_dump_cmm_split "Post splitting" g
+             return g
+           else
+             -- attach info tables to return points
+             return $ [attachContInfoTables call_pps (CmmProc h l v g)]
+
+      ------------- Populate info tables with stack info -----------------
+      g <- {-# SCC "setInfoTableStackMap" #-}
+           return $ map (setInfoTableStackMap platform stackmaps) g
+      dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
+
+      ----------- Control-flow optimisations -----------------------------
+      g <- {-# SCC "cmmCfgOpts(2)" #-}
+           return $ if optLevel dflags >= 1
+                    then map (cmmCfgOptsProc splitting_proc_points) g
+                    else g
+      g <- return (map removeUnreachableBlocksProc g)
+           -- See Note [unreachable blocks]
+      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+      return (Left (cafEnv, g))
 
   where platform = targetPlatform dflags
         dump = dumpGraph dflags

compiler/GHC/Cmm/ProcPoint.hs

-{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module GHC.Cmm.ProcPoint
@@ -237,155 +240,152 @@ extendPPSet platform g blocks procPoints =
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 -- ToDo: use the _ret naming convention that the old code generator
 -- used. -- EZY
-splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
-                     CmmDecl -> UniqSM [CmmDecl]
-splitAtProcPoints platform entry_label callPPs procPoints procMap
-                  (CmmProc (TopInfo {info_tbls = info_tbls})
-                           top_l _ g@(CmmGraph {g_entry=entry})) =
-  do -- Build a map from procpoints to the blocks they reach
-     let add_block
-             :: LabelMap (LabelMap CmmBlock)
-             -> CmmBlock
-             -> LabelMap (LabelMap CmmBlock)
-         add_block graphEnv b =
-           case mapLookup bid procMap of
-             Just ProcPoint -> add graphEnv bid bid b
-             Just (ReachedBy set) ->
-               case setElems set of
-                 []   -> graphEnv
-                 [id] -> add graphEnv id bid b
-                 _    -> panic "Each block should be reachable from only one ProcPoint"
-             Nothing -> graphEnv
-           where bid = entryLabel b
-         add graphEnv procId bid b = mapInsert procId graph' graphEnv
-               where graph  = mapLookup procId graphEnv `orElse` mapEmpty
-                     graph' = mapInsert bid b graph
-
-     let liveness = cmmGlobalLiveness platform g
-     let ppLiveness pp = filter isArgReg $
-                         regSetToList $
-                         expectJust "ppLiveness" $ mapLookup pp liveness
-
-     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
-
-     -- Build a map from proc point BlockId to pairs of:
-     --  * Labels for their new procedures
-     --  * Labels for the info tables of their new procedures (only if
-     --    the proc point is a callPP)
-     -- Due to common blockification, we may overestimate the set of procpoints.
-     let add_label map pp = mapInsert pp lbls map
-           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
-                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
-                                                    Just info_table_lbl)
-                      where block_lbl      = blockLbl pp
-                            info_table_lbl = infoTblLbl pp
-
-         procLabels :: LabelMap (CLabel, Maybe CLabel)
-         procLabels = foldl' add_label mapEmpty
-                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-
-     -- In each new graph, add blocks jumping off to the new procedures,
-     -- and replace branches to procpoints with branches to the jump-off blocks
-     let add_jump_block
-             :: (LabelMap Label, [CmmBlock])
-             -> (Label, CLabel)
-             -> UniqSM (LabelMap Label, [CmmBlock])
-         add_jump_block (env, bs) (pp, l) =
-           do bid <- liftM mkBlockId getUniqueM
-              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
-                  live = ppLiveness pp
-                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
-              return (mapInsert pp bid env, b : bs)
-
-         add_jumps
-             :: LabelMap CmmGraph
-             -> (Label, LabelMap CmmBlock)
-             -> UniqSM (LabelMap CmmGraph)
-         add_jumps newGraphEnv (ppId, blockEnv) =
-           do let needed_jumps = -- find which procpoints we currently branch to
-                    mapFoldr add_if_branch_to_pp [] blockEnv
-                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
-                  add_if_branch_to_pp block rst =
-                    case lastNode block of
-                      CmmBranch id          -> add_if_pp id rst
-                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
-                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids
-                      _                     -> rst
-
-                  -- when jumping to a PP that has an info table, if
-                  -- tablesNextToCode is off we must jump to the entry
-                  -- label instead.
-                  tablesNextToCode = platformTablesNextToCode platform
-                  jump_label (Just info_lbl) _
-                             | tablesNextToCode = info_lbl
-                             | otherwise        = toEntryLbl platform info_lbl
-                  jump_label Nothing  block_lbl = block_lbl
-
-                  add_if_pp id rst = case mapLookup id procLabels of
-                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
-                                       Nothing                 -> rst
-              (jumpEnv, jumpBlocks) <-
-                 foldM add_jump_block (mapEmpty, []) needed_jumps
-                  -- update the entry block
-              let b = expectJust "block in env" $ mapLookup ppId blockEnv
-                  blockEnv' = mapInsert ppId b blockEnv
-                  -- replace branches to procpoints with branches to jumps
-                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
-                  -- add the jump blocks to the graph
-                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
-              let g' = ofBlockMap ppId blockEnv'''
-              -- pprTrace "g' pre jumps" (ppr g') $ do
-              return (mapInsert ppId g' newGraphEnv)
-
-     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
-
-     let to_proc (bid, g)
-             | bid == entry
-             =  CmmProc (TopInfo {info_tbls  = info_tbls,
-                                  stack_info = stack_info})
-                        top_l live g'
-             | otherwise
-             = case expectJust "pp label" $ mapLookup bid procLabels of
-                 (lbl, Just info_lbl)
-                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
-                                        , stack_info=stack_info})
-                               lbl live g'
-                 (lbl, Nothing)
-                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
-                               lbl live g'
-                where
-                 g' = replacePPIds g
-                 live = ppLiveness (g_entry g')
-                 stack_info = StackInfo { arg_space = 0
-                                        , do_layout = True }
-                               -- cannot use panic, this is printed by -ddump-cmm
-
-         -- References to procpoint IDs can now be replaced with the
-         -- infotable's label
-         replacePPIds g = {-# SCC "replacePPIds" #-}
-                          mapGraphNodes (id, mapExp repl, mapExp repl) g
-           where repl e@(CmmLit (CmmBlock bid)) =
-                   case mapLookup bid procLabels of
-                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
-                     _ -> e
-                 repl e = e
-
-     -- The C back end expects to see return continuations before the
-     -- call sites.  Here, we sort them in reverse order -- it gets
-     -- reversed later.
-     let (_, block_order) =
-             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
-                   (revPostorder g)
-         add_block_num (i, map) block =
-           (i + 1, mapInsert (entryLabel block) i map)
-         sort_fn (bid, _) (bid', _) =
-           compare (expectJust "block_order" $ mapLookup bid  block_order)
-                   (expectJust "block_order" $ mapLookup bid' block_order)
-     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
-     return -- pprTrace "procLabels" (ppr procLabels)
-            -- pprTrace "splitting graphs" (ppr procs)
-            procs
+splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl
+                  -> UniqSM [CmmDecl]
 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
+splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
+  -- Build a map from procpoints to the blocks they reach
+  let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc
+
+  let add graphEnv procId bid b = mapInsert procId graph' graphEnv
+        where
+          graph' = mapInsert bid b graph
+          graph  = mapLookup procId graphEnv `orElse` mapEmpty
+
+  let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)
+      add_block graphEnv b =
+        case mapLookup bid procMap of
+          Just ProcPoint -> add graphEnv bid bid b
+          Just (ReachedBy set) ->
+            case setElems set of
+              []   -> graphEnv
+              [id] -> add graphEnv id bid b
+              _    -> panic "Each block should be reachable from only one ProcPoint"
+          Nothing -> graphEnv
+        where
+          bid = entryLabel b
+
+
+  let liveness = cmmGlobalLiveness platform g
+  let ppLiveness pp = filter isArgReg $ regSetToList $
+                        expectJust "ppLiveness" $ mapLookup pp liveness
+  graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
+
+  -- Build a map from proc point BlockId to pairs of:
+  --  * Labels for their new procedures
+  --  * Labels for the info tables of their new procedures (only if
+  --    the proc point is a callPP)
+  -- Due to common blockification, we may overestimate the set of procpoints.
+  let add_label map pp = mapInsert pp lbls map
+        where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+                   | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
+                                                 Just info_table_lbl)
+                   where block_lbl      = blockLbl pp
+                         info_table_lbl = infoTblLbl pp
+
+      procLabels :: LabelMap (CLabel, Maybe CLabel)
+      procLabels = foldl' add_label mapEmpty
+                          (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
+  -- In each new graph, add blocks jumping off to the new procedures,
+  -- and replace branches to procpoints with branches to the jump-off blocks
+  let add_jump_block :: (LabelMap Label, [CmmBlock])
+                     -> (Label, CLabel)
+                     -> UniqSM (LabelMap Label, [CmmBlock])
+      add_jump_block (env, bs) (pp, l) = do
+        bid <- liftM mkBlockId getUniqueM
+        let b    = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
+            live = ppLiveness pp
+            jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
+        return (mapInsert pp bid env, b : bs)
+
+  -- when jumping to a PP that has an info table, if
+  -- tablesNextToCode is off we must jump to the entry
+  -- label instead.
+  let tablesNextToCode = platformTablesNextToCode platform
+
+  let jump_label (Just info_lbl) _
+                 | tablesNextToCode = info_lbl
+                 | otherwise        = toEntryLbl platform info_lbl
+      jump_label Nothing  block_lbl = block_lbl
+
+  let add_if_pp id rst =
+        case mapLookup id procLabels of
+          Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
+          Nothing                 -> rst
+
+  let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+      add_if_branch_to_pp block rst =
+        case lastNode block of
+          CmmBranch id            -> add_if_pp id rst
+          CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
+          CmmSwitch _ ids         -> foldr add_if_pp rst $ switchTargetsToList ids
+          _                       -> rst
+
+  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
+      add_jumps newGraphEnv (ppId, blockEnv) = do
+        -- find which procpoints we currently branch to
+        let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv
+
+        (jumpEnv, jumpBlocks) <-
+           foldM add_jump_block (mapEmpty, []) needed_jumps
+            -- update the entry block
+        let b = expectJust "block in env" $ mapLookup ppId blockEnv
+            blockEnv' = mapInsert ppId b blockEnv
+            -- replace branches to procpoints with branches to jumps
+            blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+            -- add the jump blocks to the graph
+            blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
+        let g' = ofBlockMap ppId blockEnv'''
+        -- pprTrace "g' pre jumps" (ppr g') $ do
+        return (mapInsert ppId g' newGraphEnv)
+
+  graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+
+  let to_proc (bid, g)
+          | bid == entry
+          =  CmmProc (TopInfo {info_tbls  = info_tbls,
+                               stack_info = stack_info})
+                     top_l live g'
+          | otherwise
+          = case expectJust "pp label" $ mapLookup bid procLabels of
+              (lbl, Just info_lbl)
+                 -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+                                     , stack_info=stack_info})
+                            lbl live g'
+              (lbl, Nothing)
+                 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+                            lbl live g'
+             where
+              g' = replacePPIds g
+              live = ppLiveness (g_entry g')
+              stack_info = StackInfo { arg_space = 0
+                                     , do_layout = True }
+                            -- cannot use panic, this is printed by -ddump-cmm
+
+      -- References to procpoint IDs can now be replaced with the
+      -- infotable's label
+      replacePPIds g = {-# SCC "replacePPIds" #-}
+                       mapGraphNodes (id, mapExp repl, mapExp repl) g
+        where repl e@(CmmLit (CmmBlock bid)) =
+                case mapLookup bid procLabels of
+                  Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
+                  _ -> e
+              repl e = e
+
+  -- The C back end expects to see return continuations before the
+  -- call sites.  Here, we sort them in reverse order -- it gets
+  -- reversed later.
+  let add_block_num (i, map) block =
+        (i + 1, mapInsert (entryLabel block) i map)
+  let (_, block_order) =
+          foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
+                (revPostorder g)
+  let sort_fn (bid, _) (bid', _) =
+        compare (expectJust "block_order" $ mapLookup bid  block_order)
+                (expectJust "block_order" $ mapLookup bid' block_order)
+
+  return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
 
 -- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a
 -- recursive lookup, see comment below.

compiler/GHC/CmmToAsm.hs

@@ -152,11 +152,11 @@ nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqS
               -> Stream IO RawCmmGroup a
               -> IO a
 nativeCodeGen dflags this_mod modLoc h us cmms
- = let config   = initNCGConfig dflags
+ = let config   = initNCGConfig dflags this_mod
        platform = ncgPlatform config
        nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
             => NcgImpl statics instr jumpDest -> IO a
-       nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
+       nCG' ncgImpl = nativeCodeGen' dflags config modLoc ncgImpl h us cmms
    in case platformArch platform of
       ArchX86       -> nCG' (X86.ncgX86     config)
       ArchX86_64    -> nCG' (X86.ncgX86_64  config)
@@ -221,20 +221,20 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
 nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
                => DynFlags
                -> NCGConfig
-               -> Module -> ModLocation
+               -> ModLocation
                -> NcgImpl statics instr jumpDest
                -> Handle
                -> UniqSupply
                -> Stream IO RawCmmGroup a
                -> IO a
-nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
+nativeCodeGen' dflags config modLoc ncgImpl h us cmms
  = do
         -- BufHandle is a performance hack.  We could hide it inside
         -- Pretty if it weren't for the fact that we do lots of little
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
-        (ngs, us', a) <- cmmNativeGenStream dflags config this_mod modLoc ncgImpl bufh us
+        (ngs, us', a) <- cmmNativeGenStream dflags config modLoc ncgImpl bufh us
                                          cmms ngs0
         _ <- finishNativeGen dflags config modLoc bufh us' ngs
         return a
@@ -290,7 +290,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
         -- write out the imports
         let ctx = ncgAsmContext config
         printSDocLn ctx Pretty.LeftMode h
-                $ makeImportsDoc dflags (concat (ngs_imports ngs))
+                $ makeImportsDoc config (concat (ngs_imports ngs))
         return us'
   where
     dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify)
@@ -300,7 +300,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
 cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
               => DynFlags
               -> NCGConfig
-              -> Module -> ModLocation
+              -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> BufHandle
               -> UniqSupply
@@ -308,7 +308,7 @@ cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instru
               -> NativeGenAcc statics instr
               -> IO (NativeGenAcc statics instr, UniqSupply, a)
 
-cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
+cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs
  = do r <- Stream.runStream cmm_stream
       case r of
         Left a ->
@@ -330,7 +330,7 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
                   dbgMap = debugToMap ndbgs
 
               -- Generate native code
-              (ngs',us') <- cmmNativeGens dflags config this_mod modLoc ncgImpl h
+              (ngs',us') <- cmmNativeGens dflags config modLoc ncgImpl h
                                                dbgMap us cmms ngs 0
 
               -- Link native code information into debug blocks
@@ -345,7 +345,7 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
               let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
               return (us', ngs'')
 
-          cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us'
+          cmmNativeGenStream dflags config modLoc ncgImpl h us'
               cmm_stream' ngs''
 
     where ncglabel = text "NCG"
@@ -356,7 +356,7 @@ cmmNativeGens :: forall statics instr jumpDest.
                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
               => DynFlags
               -> NCGConfig
-              -> Module -> ModLocation
+              -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> BufHandle
               -> LabelMap DebugBlock
@@ -366,7 +366,7 @@ cmmNativeGens :: forall statics instr jumpDest.
               -> Int
               -> IO (NativeGenAcc statics instr, UniqSupply)
 
-cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go
+cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go
   where
     go :: UniqSupply -> [RawCmmDecl]
        -> NativeGenAcc statics instr -> Int
@@ -379,7 +379,7 @@ cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go
         let fileIds = ngs_dwarfFiles ngs
         (us', fileIds', native, imports, colorStats, linearStats, unwinds)
           <- {-# SCC "cmmNativeGen" #-}
-             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
+             cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap
                           cmm count
 
         -- Generate .file directives for every new file that has been
@@ -433,7 +433,7 @@ emitNativeCode dflags config h sdoc = do
 cmmNativeGen
     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)
     => DynFlags
-    -> Module -> ModLocation
+    -> ModLocation
     -> NcgImpl statics instr jumpDest
         -> UniqSupply
         -> DwarfFiles
@@ -449,7 +449,7 @@ cmmNativeGen
                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks
                 )
 
-cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
+cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count
  = do
         let config   = ncgConfig ncgImpl
         let platform = ncgPlatform config
@@ -467,7 +467,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
         -- cmm to cmm optimisations
         let (opt_cmm, imports) =
                 {-# SCC "cmmToCmm" #-}
-                cmmToCmm config this_mod fixed_cmm
+                cmmToCmm config fixed_cmm
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
@@ -479,7 +479,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
         -- generate native code from cmm
         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
                 {-# SCC "genMachCode" #-}
-                initUs us $ genMachCode config this_mod modLoc
+                initUs us $ genMachCode config modLoc
                                         (cmmTopCodeGen ncgImpl)
                                         fileIds dbgMap opt_cmm cmmCfg
 
@@ -750,8 +750,8 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
 
 -- | Build a doc for all the imports.
 --
-makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
-makeImportsDoc dflags imports
+makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
+makeImportsDoc config imports
  = dyld_stubs imports
             $$
             -- On recent versions of Darwin, the linker supports
@@ -779,7 +779,6 @@ makeImportsDoc dflags imports
              else Outputable.empty)
 
  where
-        config   = initNCGConfig dflags
         platform = ncgPlatform config
 
         -- Generate "symbol stubs" for all external symbols that might
@@ -915,7 +914,7 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
 
 genMachCode
         :: NCGConfig
-        -> Module -> ModLocation
+        -> ModLocation
         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
         -> DwarfFiles
         -> LabelMap DebugBlock
@@ -928,9 +927,9 @@ genMachCode
                 , CFG
                 )
 
-genMachCode config this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
+genMachCode config modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
   = do  { initial_us <- getUniqueSupplyM
-        ; let initial_st           = mkNatM_State initial_us 0 config this_mod
+        ; let initial_st           = mkNatM_State initial_us 0 config
                                                   modLoc fileIds dbgMap cmm_cfg
               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
               final_delta          = natm_delta final_st
@@ -967,10 +966,10 @@ Ideas for other things we could do (put these in Hoopl please!):
     temp assignments, and certain assigns to mem...)
 -}
 
-cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
-cmmToCmm _ _ top@(CmmData _ _) = (top, [])
-cmmToCmm config this_mod (CmmProc info lbl live graph)
-    = runCmmOpt config this_mod $
+cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm _ top@(CmmData _ _) = (top, [])
+cmmToCmm config (CmmProc info lbl live graph)
+    = runCmmOpt config $
       do blocks' <- mapM cmmBlockConFold (toBlockList graph)
          return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
 
@@ -987,34 +986,33 @@ pattern OptMResult x y = (# x, y #)
 data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)
 #endif
 
-newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a)
+newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
     deriving (Functor)
 
 instance Applicative CmmOptM where
-    pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
+    pure x = CmmOptM $ \_ imports -> OptMResult x imports
     (<*>) = ap
 
 instance Monad CmmOptM where
   (CmmOptM f) >>= g =
-    CmmOptM $ \config this_mod imports0 ->
-                case f config this_mod imports0 of
+    CmmOptM $ \config imports0 ->
+                case f config imports0 of
                   OptMResult x imports1 ->
                     case g x of
-                      CmmOptM g' -> g' config this_mod imports1
+                      CmmOptM g' -> g' config imports1
 
 instance CmmMakeDynamicReferenceM CmmOptM where
     addImport = addImportCmmOpt
-    getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports
 
 addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)
+addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)
 
 getCmmOptConfig :: CmmOptM NCGConfig
-getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports
+getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports
 
-runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
-runCmmOpt config this_mod (CmmOptM f) =
-  case f config this_mod [] of
+runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])
+runCmmOpt config (CmmOptM f) =
+  case f config [] of
     OptMResult result imports -> (result, imports)
 
 cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
@@ -1101,30 +1099,28 @@ cmmExprNative referenceKind expr = do
          arch = platformArch platform
      case expr of
         CmmLoad addr rep
-           -> do addr' <- cmmExprNative DataReference addr
-                 return $ CmmLoad addr' rep
+          -> do addr' <- cmmExprNative DataReference addr
+                return $ CmmLoad addr' rep
 
         CmmMachOp mop args
-           -> do args' <- mapM (cmmExprNative DataReference) args
-                 return $ CmmMachOp mop args'
+          -> do args' <- mapM (cmmExprNative DataReference) args
+                return $ CmmMachOp mop args'
 
         CmmLit (CmmBlock id)
-           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
-           -- we must convert block Ids to CLabels here, because we
-           -- might have to do the PIC transformation.  Hence we must
-           -- not modify BlockIds beyond this point.
+          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+          -- we must convert block Ids to CLabels here, because we
+          -- might have to do the PIC transformation.  Hence we must
+          -- not modify BlockIds beyond this point.
 
         CmmLit (CmmLabel lbl)
-           -> do
-                cmmMakeDynamicReference config referenceKind lbl
+          -> cmmMakeDynamicReference config referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
-           -> do
-                 dynRef <- cmmMakeDynamicReference config referenceKind lbl
-                 -- need to optimize here, since it's late
-                 return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
-                     dynRef,
-                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
-                   ]
+          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl
+                -- need to optimize here, since it's late
+                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
+                    dynRef,
+                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
+                  ]
 
         -- On powerpc (non-PIC), it's easier to jump directly to a label than
         -- to use the register table, so we replace these registers
@@ -1146,9 +1142,10 @@ cmmExprNative referenceKind expr = do
            -> return other
 
 -- | Initialize the native code generator configuration from the DynFlags
-initNCGConfig :: DynFlags -> NCGConfig
-initNCGConfig dflags = NCGConfig
+initNCGConfig :: DynFlags -> Module -> NCGConfig
+initNCGConfig dflags this_mod = NCGConfig
    { ncgPlatform              = targetPlatform dflags
+   , ncgThisModule            = this_mod
    , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)
    , ncgProcAlignment         = cmmProcAlignment dflags
    , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags
@@ -1193,5 +1190,6 @@ initNCGConfig dflags = NCGConfig
    , ncgDwarfEnabled        = debugLevel dflags > 0
    , ncgDwarfUnwindings     = debugLevel dflags >= 1
    , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
+   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags
    }
 

compiler/GHC/CmmToAsm/BlockLayout.hs

@@ -475,7 +475,6 @@ combineNeighbourhood edges chains
                  applyEdges edges newEnds newFronts (Set.insert (from,to) combined)
             | otherwise
             = applyEdges edges chainEnds chainFronts combined
-         where
 
         getFronts chain = takeL neighbourOverlapp chain
         getEnds chain = takeR neighbourOverlapp chain
@@ -588,19 +587,14 @@ buildChains edges blocks
         , Just predChain <- mapLookup from chainEnds
         , Just succChain <- mapLookup to chainStarts
         , predChain /= succChain -- Otherwise we try to create a cycle.
-        = do
-            -- pprTraceM "Fusing edge" (ppr edge)
-            fuseChain predChain succChain
+          = fuseChain predChain succChain
 
         | (alreadyPlaced from) &&
           (alreadyPlaced to)
-        =   --pprTraceM "Skipping:" (ppr edge) >>
-            buildNext placed chainStarts chainEnds todo linked
+          = buildNext placed chainStarts chainEnds todo linked
 
         | otherwise
-        = do -- pprTraceM "Finding chain for:" (ppr edge $$
-             --         text "placed" <+> ppr placed)
-             findChain
+          = findChain
       where
         from = edgeFrom edge
         to   = edgeTo   edge