.gitlab/ci.sh

@@ -753,7 +753,7 @@ function check_interfaces(){
 }
 
 function abi_test() {
-  for i in {1..20}; do info "iteration $i"; run_abi_test; done
+  for i in {1..10}; do info "iteration $i"; run_abi_test; done
 }
 
 function run_abi_test() {
@@ -761,8 +761,8 @@ function run_abi_test() {
     fail "HC not set"
   fi
   mkdir -p out
-  OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O0
-  OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O0
+  OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O1 -haddock
+  OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O1 -haddock -dunique-increment=-1 -dinitial-unique=16777215
   check_interfaces out/run1 out/run2 abis "Mismatched ABI hash"
   check_interfaces out/run1 out/run2 interfaces "Mismatched interface hashes"
 }

.gitlab/generate-ci/gen_ci.hs

@@ -155,6 +155,7 @@ data BuildConfig
                 , noSplitSections :: Bool
                 , validateNonmovingGc :: Bool
                 , textWithSIMDUTF :: Bool
+                , testsuiteUsePerf :: Bool
                 }
 
 -- Extra arguments to pass to ./configure due to the BuildConfig
@@ -216,6 +217,7 @@ vanilla = BuildConfig
   , noSplitSections = False
   , validateNonmovingGc = False
   , textWithSIMDUTF = False
+  , testsuiteUsePerf = False
   }
 
 splitSectionsBroken :: BuildConfig -> BuildConfig
@@ -268,6 +270,9 @@ tsan = vanilla { threadSanitiser = True }
 noTntc :: BuildConfig
 noTntc = vanilla { tablesNextToCode = False }
 
+usePerfProfilingTestsuite :: BuildConfig -> BuildConfig
+usePerfProfilingTestsuite bc = bc { testsuiteUsePerf = True }
+
 -----------------------------------------------------------------------------
 -- Platform specific variables
 -----------------------------------------------------------------------------
@@ -288,6 +293,9 @@ runnerTag _ _ = error "Invalid arch/opsys"
 tags :: Arch -> Opsys -> BuildConfig -> [String]
 tags arch opsys _bc = [runnerTag arch opsys] -- Tag for which runners we can use
 
+runnerPerfTag :: Arch -> Opsys -> String
+runnerPerfTag arch sys = runnerTag arch sys ++ "-perf"
+
 -- These names are used to find the docker image so they have to match what is
 -- in the docker registry.
 distroName :: LinuxDistro -> String
@@ -775,6 +783,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
                 | validateNonmovingGc buildConfig
                 ]
         in "RUNTEST_ARGS" =: unwords runtestArgs
+      , if testsuiteUsePerf buildConfig then "RUNTEST_ARGS" =: "--config perf_path=perf" else mempty
       ]
 
     jobArtifacts = Artifacts
@@ -897,6 +906,12 @@ highCompression = addVariable "XZ_OPT" "-9"
 useHashUnitIds :: Job -> Job
 useHashUnitIds = addVariable "HADRIAN_ARGS" "--hash-unit-ids"
 
+-- | Change the tag of the job to make sure the job is scheduled on a
+-- runner that has the necessary capabilties to run the job with 'perf'
+-- profiling counters.
+perfProfilingJobTag :: Arch -> Opsys -> Job -> Job
+perfProfilingJobTag arch opsys j = j { jobTags = [ runnerPerfTag arch opsys ] }
+
 -- | Mark the validate job to run in fast-ci mode
 -- This is default way, to enable all jobs you have to apply the `full-ci` label.
 fastCI :: JobGroup Job -> JobGroup Job
@@ -1000,6 +1015,8 @@ debian_x86 =
   , modifyNightlyJobs allowFailure (modifyValidateJobs (allowFailure . manual) tsan_jobs)
   , -- Nightly allowed to fail: #22343
     modifyNightlyJobs allowFailure (modifyValidateJobs manual (validateBuilds Amd64 (Linux validate_debian) noTntc))
+  -- Run the 'perf' profiling nightly job in the release config.
+  , perfProfilingJob Amd64 (Linux Debian12) releaseConfig
 
   , onlyRule LLVMBackend (validateBuilds Amd64 (Linux validate_debian) llvm)
   , addValidateRule TestPrimops (standardBuilds Amd64 (Linux validate_debian))
@@ -1010,6 +1027,12 @@ debian_x86 =
   where
     validate_debian = Debian12
 
+    perfProfilingJob arch sys buildConfig =
+        -- Rename the job to avoid conflicts
+        rename (<> "-perf")
+          $ modifyJobs (perfProfilingJobTag arch sys)
+          $ disableValidate (validateBuilds arch sys $ usePerfProfilingTestsuite buildConfig)
+
     tsan_jobs =
       modifyJobs
         ( addVariable "TSAN_OPTIONS" "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"

.gitlab/jobs.yaml

@@ -1791,6 +1791,69 @@
       "XZ_OPT": "-9"
     }
   },
+  "nightly-x86_64-linux-deb12-release-perf": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".gitlab/ci.sh clean",
+      "cat ci_timings"
+    ],
+    "allow_failure": false,
+    "artifacts": {
+      "expire_in": "8 weeks",
+      "paths": [
+        "ghc-x86_64-linux-deb12-release.tar.xz",
+        "junit.xml",
+        "unexpected-test-output.tar.gz"
+      ],
+      "reports": {
+        "junit": "junit.xml"
+      },
+      "when": "always"
+    },
+    "cache": {
+      "key": "x86_64-linux-deb12-$CACHE_REV",
+      "paths": [
+        "cabal-cache",
+        "toolchain"
+      ]
+    },
+    "dependencies": [],
+    "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV",
+    "needs": [
+      {
+        "artifacts": false,
+        "job": "hadrian-ghc-in-ghci"
+      }
+    ],
+    "rules": [
+      {
+        "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+        "when": "on_success"
+      }
+    ],
+    "script": [
+      "sudo chown ghc:ghc -R .",
+      ".gitlab/ci.sh setup",
+      ".gitlab/ci.sh configure",
+      ".gitlab/ci.sh build_hadrian",
+      ".gitlab/ci.sh test_hadrian"
+    ],
+    "stage": "full-build",
+    "tags": [
+      "x86_64-linux-perf"
+    ],
+    "variables": {
+      "BIGNUM_BACKEND": "gmp",
+      "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-release",
+      "BUILD_FLAVOUR": "release",
+      "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+      "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+      "RUNTEST_ARGS": " --config perf_path=perf",
+      "TEST_ENV": "x86_64-linux-deb12-release",
+      "XZ_OPT": "-9"
+    }
+  },
   "nightly-x86_64-linux-deb12-unreg-validate": {
     "after_script": [
       ".gitlab/ci.sh save_cache",

compiler/GHC/Builtin/primops.txt.pp

@@ -1925,7 +1925,25 @@ primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp
 
 primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp
    ByteArray# -> Int#
-   {Determine whether a 'ByteArray#' is guaranteed not to move during GC.}
+   {Determine whether a 'ByteArray#' is guaranteed not to move.}
+   with out_of_line = True
+
+primop  ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp
+   ByteArray# -> Int#
+   {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed
+    to be copied into compact regions by the user, potentially invalidating
+    the results of earlier calls to 'byteArrayContents#'.
+
+    See the section `Pinned Byte Arrays` in the user guide for more information.
+
+    This function also returns true for regular pinned bytearrays.
+   }
+   with out_of_line = True
+
+primop  MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp
+   MutableByteArray# s -> Int#
+   { 'isByteArrayWeaklyPinned#' but for mutable arrays.
+   }
    with out_of_line = True
 
 primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp

compiler/GHC/CmmToAsm/AArch64/CodeGen.hs

@@ -1990,9 +1990,13 @@ genCCall target dest_regs arg_regs = do
         MO_SubIntC    _w -> unsupported mop
 
         -- Memory Ordering
-        MO_AcquireFence     ->  return (unitOL DMBISH)
-        MO_ReleaseFence     ->  return (unitOL DMBISH)
-        MO_SeqCstFence      ->  return (unitOL DMBISH)
+        -- Set flags according to their C pendants (stdatomic.h):
+        -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld
+        MO_AcquireFence     ->  return . unitOL $ DMBISH DmbLoad
+        -- atomic_thread_fence(memory_order_release); // -> dmb ish
+        MO_ReleaseFence     ->  return . unitOL $ DMBISH DmbLoadStore
+        -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish
+        MO_SeqCstFence      ->  return . unitOL $ DMBISH DmbLoadStore
         MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)
         -- Prefetch
         MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.

compiler/GHC/CmmToAsm/AArch64/Instr.hs

@@ -30,6 +30,7 @@ import GHC.Utils.Panic
 import Data.Maybe (fromMaybe)
 
 import GHC.Stack
+import GHC.Platform.Reg.Class
 
 -- | LR and FP (8 byte each) are the prologue of each stack frame
 stackFrameHeaderSize :: Int
@@ -134,7 +135,7 @@ regUsageOfInstr platform instr = case instr of
   LDAR _ dst src           -> usage (regOp src, regOp dst)
 
   -- 8. Synchronization Instructions -------------------------------------------
-  DMBISH                   -> usage ([], [])
+  DMBISH _                 -> usage ([], [])
 
   -- 9. Floating Point Instructions --------------------------------------------
   FMOV dst src             -> usage (regOp src, regOp dst)
@@ -281,7 +282,7 @@ patchRegsOfInstr instr env = case instr of
     LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)
 
     -- 8. Synchronization Instructions -----------------------------------------
-    DMBISH         -> DMBISH
+    DMBISH c       -> DMBISH c
 
     -- 9. Floating Point Instructions ------------------------------------------
     FMOV o1 o2     -> FMOV (patchOp o1) (patchOp o2)
@@ -454,10 +455,22 @@ isMetaInstr instr
 mkRegRegMoveInstr :: Reg -> Reg -> Instr
 mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)
 
--- | Take the source and destination from this reg -> reg move instruction
--- or Nothing if it's not one
+-- | Take the source and destination registers from a move instruction of same
+-- register class (`RegClass`).
+--
+-- The idea is to identify moves that can be eliminated by the register
+-- allocator: If the source register serves no special purpose, one could
+-- continue using it; saving one move instruction. For this, the register kinds
+-- (classes) must be the same (no conversion involved.)
 takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
---takeRegRegMoveInstr (MOV (OpReg fmt dst) (OpReg fmt' src)) | fmt == fmt' = Just (src, dst)
+takeRegRegMoveInstr (MOV (OpReg _fmt dst) (OpReg _fmt' src))
+  | classOfReg dst == classOfReg src = pure (src, dst)
+  where
+    classOfReg ::Reg -> RegClass
+    classOfReg reg
+      = case reg of
+        RegVirtual vr -> classOfVirtualReg vr
+        RegReal rr -> classOfRealReg rr
 takeRegRegMoveInstr _ = Nothing
 
 -- | Make an unconditional jump instruction.
@@ -649,7 +662,7 @@ data Instr
     | BCOND Cond Target   -- branch with condition. b.<cond>
 
     -- 8. Synchronization Instructions -----------------------------------------
-    | DMBISH
+    | DMBISH DMBISHFlags
     -- 9. Floating Point Instructions
     -- move to/from general purpose <-> floating, or floating to floating
     | FMOV Operand Operand
@@ -672,6 +685,9 @@ data Instr
     -- - fnmadd: d = - r1 * r2 - r3
     | FMA FMASign Operand Operand Operand Operand
 
+data DMBISHFlags = DmbLoad | DmbLoadStore
+  deriving (Eq, Show)
+
 instrCon :: Instr -> String
 instrCon i =
     case i of

compiler/GHC/CmmToAsm/AArch64/Ppr.hs

@@ -527,7 +527,8 @@ pprInstr platform instr = case instr of
   LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
 
   -- 8. Synchronization Instructions -------------------------------------------
-  DMBISH -> line $ text "\tdmb ish"
+  DMBISH DmbLoadStore -> line $ text "\tdmb ish"
+  DMBISH DmbLoad -> line $ text "\tdmb ishld"
 
   -- 9. Floating Point Instructions --------------------------------------------
   FMOV o1 o2 -> op2 (text "\tfmov") o1 o2

compiler/GHC/CoreToStg.hs

@@ -27,7 +27,8 @@ import GHC.Core.DataCon
 
 import GHC.Stg.Syntax
 import GHC.Stg.Debug
-import GHC.Stg.Utils
+import GHC.Stg.Make
+import GHC.Stg.Utils (allowTopLevelConApp)
 
 import GHC.Types.RepType
 import GHC.Types.Id.Make ( coercionTokenId )
@@ -36,16 +37,13 @@ import GHC.Types.Id.Info
 import GHC.Types.CostCentre
 import GHC.Types.Tickish
 import GHC.Types.Var.Env
-import GHC.Types.Name   ( isExternalName, nameModule_maybe )
+import GHC.Types.Name   ( isExternalName )
 import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )
 import GHC.Types.Literal
 import GHC.Types.ForeignCall
 import GHC.Types.IPE
-import GHC.Types.Demand    ( isAtMostOnceDmd )
-import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
 
 import GHC.Unit.Module
-import GHC.Data.FastString
 import GHC.Platform        ( Platform )
 import GHC.Platform.Ways
 import GHC.Builtin.PrimOps
@@ -338,10 +336,12 @@ coreToTopStgRhs
         -> CtsM (CollectedCCs, (Id, StgRhs))
 
 coreToTopStgRhs opts this_mod ccs (bndr, rhs)
-  = do { new_rhs <- coreToPreStgRhs rhs
+  = do { new_rhs <- coreToMkStgRhs bndr rhs
 
        ; let (stg_rhs, ccs') =
-               mkTopStgRhs opts this_mod ccs bndr new_rhs
+               mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
+                           (coreToStg_AutoSccsOnIndividualCafs opts)
+                           this_mod ccs bndr new_rhs
              stg_arity =
                stgRhsArity stg_rhs
 
@@ -372,7 +372,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
 
 -- coreToStgExpr panics if the input expression is a value lambda. CorePrep
 -- ensures that value lambdas only exist as the RHS of bindings, which we
--- handle with the function coreToPreStgRhs.
+-- handle with the function coreToMkStgRhs.
 
 coreToStgExpr
         :: HasDebugCallStack => CoreExpr
@@ -685,166 +685,24 @@ coreToStgRhs :: (Id,CoreExpr)
              -> CtsM StgRhs
 
 coreToStgRhs (bndr, rhs) = do
-    new_rhs <- coreToPreStgRhs rhs
+    new_rhs <- coreToMkStgRhs bndr rhs
     return (mkStgRhs bndr new_rhs)
 
--- Represents the RHS of a binding for use with mk(Top)StgRhs.
-data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks
-
 -- Convert the RHS of a binding from Core to STG. This is a wrapper around
 -- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
-coreToPreStgRhs expr
-  = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
-    do { body' <- coreToStgExpr body
-       ; return (PreStgRhs args' body' (exprType body)) }
-  where
-   (args, body) = myCollectBinders expr
-   args'        = filterStgBinders args
-
--- Generate a top-level RHS. Any new cost centres generated for CAFs will be
--- appended to `CollectedCCs` argument.
-mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
-            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
-
-mkTopStgRhs CoreToStgOpts
-  { coreToStg_platform = platform
-  , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
-  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
-  } this_mod ccs bndr (PreStgRhs bndrs rhs typ)
-  | not (null bndrs)
-  = -- The list of arguments is non-empty, so not CAF
-    ( StgRhsClosure noExtFieldSilent
-                    dontCareCCS
-                    ReEntrant
-                    bndrs rhs typ
-    , ccs )
-
-  -- After this point we know that `bndrs` is empty,
-  -- so this is not a function binding
-  | StgConApp con mn args _ <- unticked_rhs
-  , -- Dynamic StgConApps are updatable
-    not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
-  = -- CorePrep does this right, but just to make sure
-    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
-              (ppr bndr $$ ppr con $$ ppr args)
-    ( StgRhsCon dontCareCCS con mn ticks args typ, ccs )
-
-  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
-  | opt_AutoSccsOnIndividualCafs
-  = ( StgRhsClosure noExtFieldSilent
-                    caf_ccs
-                    upd_flag [] rhs typ
-    , collectCC caf_cc caf_ccs ccs )
-
-  | otherwise
-  = ( StgRhsClosure noExtFieldSilent
-                    all_cafs_ccs
-                    upd_flag [] rhs typ
-    , ccs )
-
-  where
-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
-    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
-             | otherwise                           = Updatable
-
-    -- CAF cost centres generated for -fcaf-all
-    caf_cc = mkAutoCC bndr modl
-    caf_ccs = mkSingletonCCS caf_cc
-           -- careful: the binder might be :Main.main,
-           -- which doesn't belong to module mod_name.
-           -- bug #249, tests prof001, prof002
-    modl | Just m <- nameModule_maybe (idName bndr) = m
-         | otherwise = this_mod
-
-    -- default CAF cost centre
-    (_, all_cafs_ccs) = getAllCAFsCC this_mod
-
--- Generate a non-top-level RHS. Cost-centre is always currentCCS,
--- see Note [Cost-centre initialization plan].
-mkStgRhs :: Id -> PreStgRhs -> StgRhs
-mkStgRhs bndr (PreStgRhs bndrs rhs typ)
-  | not (null bndrs)
-  = StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  ReEntrant
-                  bndrs rhs typ
-
-  -- After this point we know that `bndrs` is empty,
-  -- so this is not a function binding
-
-  | isJoinId bndr -- Must be a nullary join point
-  = -- It might have /type/ arguments (T18328),
-    -- so its JoinArity might be >0
-    StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  ReEntrant -- ignored for LNE
-                  [] rhs typ
-
-  | StgConApp con mn args _ <- unticked_rhs
-  = StgRhsCon currentCCS con mn ticks args typ
-
-  | otherwise
-  = StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  upd_flag [] rhs typ
-  where
-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
-    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
-             | otherwise                           = Updatable
-
-  {-
-    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
-    well; and making these into simple non-updatable thunks breaks other
-    assumptions (namely that they will be entered only once).
-
-    upd_flag | isPAP env rhs  = ReEntrant
-             | otherwise      = Updatable
-
--- Detect thunks which will reduce immediately to PAPs, and make them
--- non-updatable.  This has several advantages:
---
---         - the non-updatable thunk behaves exactly like the PAP,
---
---         - the thunk is more efficient to enter, because it is
---           specialised to the task.
---
---         - we save one update frame, one stg_update_PAP, one update
---           and lots of PAP_enters.
---
---         - in the case where the thunk is top-level, we save building
---           a black hole and furthermore the thunk isn't considered to
---           be a CAF any more, so it doesn't appear in any SRTs.
---
--- We do it here, because the arity information is accurate, and we need
--- to do it before the SRT pass to save the SRT entries associated with
--- any top-level PAPs.
-
-isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
-                              where
-                                 arity = stgArity f (lookupBinding env f)
-isPAP env _               = False
-
--}
-
-{- ToDo:
-          upd = if isOnceDem dem
-                    then (if isNotTop toplev
-                            then SingleEntry    -- HA!  Paydirt for "dem"
-                            else
-                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
-                     Updatable)
-                else Updatable
-        -- For now we forbid SingleEntry CAFs; they tickle the
-        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
-        -- and I don't understand why.  There's only one SE_CAF (well,
-        -- only one that tickled a great gaping bug in an earlier attempt
-        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
-        -- specifically Main.lvl6 in spectral/cryptarithm2.
-        -- So no great loss.  KSW 2000-07.
--}
+coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs
+coreToMkStgRhs bndr expr = do
+  let (args, body) = myCollectBinders expr
+  let args'        = filterStgBinders args
+  extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+    body' <- coreToStgExpr body
+    let mk_rhs = MkStgRhs
+          { rhs_args = args'
+          , rhs_expr = body'
+          , rhs_type = exprType body
+          , rhs_is_join = isJoinId bndr
+          }
+    pure mk_rhs
 
 -- ---------------------------------------------------------------------------
 -- A monad for the core-to-STG pass
@@ -933,15 +791,6 @@ lookupBinding env v = case lookupVarEnv env v of
                         Just xx -> xx
                         Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
 
-getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
-getAllCAFsCC this_mod =
-    let
-      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
-      all_cafs_cc  = mkAllCafsCC this_mod span
-      all_cafs_ccs = mkSingletonCCS all_cafs_cc
-    in
-      (all_cafs_cc, all_cafs_ccs)
-
 -- Misc.
 
 filterStgBinders :: [Var] -> [Var]

compiler/GHC/Driver/Config/Stg/Pipeline.hs

@@ -7,6 +7,7 @@ import GHC.Prelude
 import Control.Monad (guard)
 
 import GHC.Stg.Pipeline
+import GHC.Stg.Utils
 
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Config.Stg.Lift
@@ -15,15 +16,19 @@ import GHC.Driver.DynFlags
 
 -- | Initialize STG pretty-printing options from DynFlags
 initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts
-  { stgPipeline_lint = do
-      guard $ gopt Opt_DoStgLinting dflags
-      Just $ initDiagOpts dflags
-  , stgPipeline_pprOpts = initStgPprOpts dflags
-  , stgPipeline_phases = getStgToDo for_bytecode dflags
-  , stgPlatform = targetPlatform dflags
-  , stgPipeline_forBytecode = for_bytecode
-  }
+initStgPipelineOpts dflags for_bytecode =
+  let !platform = targetPlatform dflags
+      !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags
+  in StgPipelineOpts
+    { stgPipeline_lint = do
+        guard $ gopt Opt_DoStgLinting dflags
+        Just $ initDiagOpts dflags
+    , stgPipeline_pprOpts = initStgPprOpts dflags
+    , stgPipeline_phases = getStgToDo for_bytecode dflags
+    , stgPlatform = platform
+    , stgPipeline_forBytecode = for_bytecode
+    , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs
+    }
 
 -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
 getStgToDo

compiler/GHC/Driver/Main.hs

 {-# LANGUAGE LambdaCase #-}
-
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -295,13 +294,13 @@ import Data.Time
 
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import GHC.Iface.Env ( trace_if )
+import GHC.Platform.Ways
 import GHC.Stg.InferTags.TagSig (seqTagSig)
 import GHC.StgToCmm.Utils (IPEStats)
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.DFM
 import GHC.Cmm.Config (CmmConfig)
 
-
 {- **********************************************************************
 %*                                                                      *
                 Initialisation
@@ -990,6 +989,27 @@ initModDetails hsc_env iface =
     -- in make mode, since this HMI will go into the HPT.
     genModDetails hsc_env' iface
 
+-- | Modify flags such that objects are compiled for the interpreter's way.
+-- This is necessary when building foreign objects for Template Haskell, since
+-- those are object code built outside of the pipeline, which means they aren't
+-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build
+-- outputs for dependencies when the interpreter used for TH is dynamic but the
+-- main outputs aren't.
+-- Furthermore, the HPT only stores one set of objects with different names for
+-- bytecode linking in 'HomeModLinkable', so the usual hack for switching
+-- between ways in 'get_link_deps' doesn't work.
+compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a
+compile_for_interpreter hsc_env use =
+  use (hscUpdateFlags update hsc_env)
+  where
+    update dflags = dflags {
+      targetWays_ = adapt_way interpreterDynamic WayDyn $
+                    adapt_way interpreterProfiled WayProf $
+                    targetWays_ dflags
+      }
+
+    adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay
+
 -- | If the 'Linkable' contains Core bindings loaded from an interface, replace
 -- them with a lazy IO thunk that compiles them to bytecode and foreign objects.
 --
@@ -2063,9 +2083,10 @@ generateByteCode :: HscEnv
   -> IO (CompiledByteCode, [FilePath])
 generateByteCode hsc_env cgguts mod_location = do
   (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
-  stub_o <- traverse (compileForeign hsc_env LangC) hasStub
-  foreign_files_o <- traverse (uncurry (compileForeign hsc_env)) (cgi_foreign_files cgguts)
-  pure (comp_bc, maybeToList stub_o ++ foreign_files_o)
+  compile_for_interpreter hsc_env $ \ i_env -> do
+    stub_o <- traverse (compileForeign i_env LangC) hasStub
+    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
+    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)
 
 generateFreshByteCode :: HscEnv
   -> ModuleName

compiler/GHC/Driver/Make.hs

@@ -2924,19 +2924,22 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
     atomically $ writeTVar stopped_var True
     wait_log_thread
 
-withLocalTmpFS :: RunMakeM a -> RunMakeM a
-withLocalTmpFS act = do
+withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a
+withLocalTmpFS tmpfs act = do
   let initialiser = do
-        MakeEnv{..} <- ask
-        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)
-        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }
-      finaliser lcl_env = do
-        gbl_env <- ask
-        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))
+        liftIO $ forkTmpFsFrom tmpfs
+      finaliser tmpfs_local = do
+        liftIO $ mergeTmpFsInto tmpfs_local tmpfs
        -- Add remaining files which weren't cleaned up into local tmp fs for
        -- clean-up later.
        -- Clear the logQueue if this node had it's own log queue
-  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act
+  MC.bracket initialiser finaliser act
+
+withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a
+withLocalTmpFSMake env k =
+  withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs
+    -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})
+
 
 -- | Run the given actions and then wait for them all to finish.
 runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
@@ -2958,16 +2961,18 @@ runAllPipelines worker_limit env acts = do
 runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
 runLoop _ _env [] = return []
 runLoop fork_thread env (MakeAction act res_var :acts) = do
-  new_thread <-
+
+  -- withLocalTmpFs has to occur outside of fork to remain deterministic
+  new_thread <- withLocalTmpFSMake env $ \lcl_env ->
     fork_thread $ \unmask -> (do
-            mres <- (unmask $ run_pipeline (withLocalTmpFS act))
+            mres <- (unmask $ run_pipeline lcl_env act)
                       `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
             putMVar res_var mres)
   threads <- runLoop fork_thread env acts
   return (new_thread : threads)
   where
-      run_pipeline :: RunMakeM a -> IO (Maybe a)
-      run_pipeline p = runMaybeT (runReaderT p env)
+      run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)
+      run_pipeline env p = runMaybeT (runReaderT p env)
 
 data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
 

compiler/GHC/Parser.y

@@ -4483,13 +4483,13 @@ gl = getLoc
 glA :: HasLoc a => a -> SrcSpan
 glA = getHasLoc
 
-glR :: HasLoc a => a -> Anchor
+glR :: HasLoc a => a -> EpaLocation
 glR !la = EpaSpan (getHasLoc la)
 
-glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor
+glEE :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation
 glEE !x !y = spanAsAnchor $ comb2 x y
 
-glRM :: Located a -> Maybe Anchor
+glRM :: Located a -> Maybe EpaLocation
 glRM (L !l _) = Just $ spanAsAnchor l
 
 glAA :: HasLoc a => a -> EpaLocation
@@ -4609,11 +4609,11 @@ hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
 hsDoAnn (L l _) (L ll _) kw
   = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
 
-listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor
+listAsAnchor :: [LocatedAn t a] -> Located b -> EpaLocation
 listAsAnchor [] (L l _) = spanAsAnchor l
 listAsAnchor (h:_) s = spanAsAnchor (comb2 h s)
 
-listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor
+listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation
 listAsAnchorM [] = Nothing
 listAsAnchorM (L l _:_) =
   case locA l of

compiler/GHC/Parser/Annotation.hs

@@ -23,7 +23,7 @@ module GHC.Parser.Annotation (
   TokenLocation(..),
   DeltaPos(..), deltaPos, getDeltaLine,
 
-  EpAnn(..), Anchor,
+  EpAnn(..),
   anchor,
   spanAsAnchor, realSpanAsAnchor,
   noSpanAnchor,
@@ -528,7 +528,7 @@ instance Outputable AddEpAnn where
 -- new AST fragments out of old ones, and have them still printed out
 -- in a precise way.
 data EpAnn ann
-  = EpAnn { entry   :: !Anchor
+  = EpAnn { entry   :: !EpaLocation
            -- ^ Base location for the start of the syntactic element
            -- holding the annotations.
            , anns     :: !ann -- ^ Annotations added by the Parser
@@ -539,15 +539,6 @@ data EpAnn ann
         deriving (Data, Eq, Functor)
 -- See Note [XRec and Anno in the AST]
 
--- | An 'Anchor' records the base location for the start of the
--- syntactic element holding the annotations, and is used as the point
--- of reference for calculating delta positions for contained
--- annotations.
--- It is also normally used as the reference point for the spacing of
--- the element relative to its container. If the AST element is moved,
--- that relationship is tracked using the 'EpaDelta' constructor instead.
-type Anchor = EpaLocation -- Transitional
-
 anchor :: (EpaLocation' a) -> RealSrcSpan
 anchor (EpaSpan (RealSrcSpan r _)) = r
 anchor _ = panic "anchor"
@@ -676,7 +667,7 @@ data AnnListItem
 -- keywords such as 'where'.
 data AnnList
   = AnnList {
-      al_anchor    :: Maybe Anchor, -- ^ start point of a list having layout
+      al_anchor    :: Maybe EpaLocation, -- ^ start point of a list having layout
       al_open      :: Maybe AddEpAnn,
       al_close     :: Maybe AddEpAnn,
       al_rest      :: [AddEpAnn], -- ^ context, such as 'where' keyword
@@ -1143,7 +1134,7 @@ listLocation as = EpaSpan (go noSrcSpan as)
     go acc (L (EpAnn (EpaSpan s) _ _) _:rest) = go (combine acc s) rest
     go acc (_:rest) = go acc rest
 
-widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
+widenAnchor :: EpaLocation -> [AddEpAnn] -> EpaLocation
 widenAnchor (EpaSpan (RealSrcSpan s mb)) as
   = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb  (bufSpanFromAnns as)))
 widenAnchor (EpaSpan us) _ = EpaSpan us
@@ -1151,7 +1142,7 @@ widenAnchor a@EpaDelta{} as = case (realSpanFromAnns as) of
                                     Strict.Nothing -> a
                                     Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing)
 
-widenAnchorS :: Anchor -> SrcSpan -> Anchor
+widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation
 widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr)
   = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr))
 widenAnchorS (EpaSpan us) _ = EpaSpan us

compiler/GHC/Parser/PostProcess.hs

@@ -478,13 +478,13 @@ add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c
 add_where (AddEpAnn _ _) _ _ = panic "add_where"
  -- EpaDelta should only be used for transformations
 
-valid_anchor :: Anchor -> Bool
+valid_anchor :: EpaLocation -> Bool
 valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0
 valid_anchor _ = False
 
 -- If the decl list for where binds is empty, the anchor ends up
 -- invalid. In this case, use the parent one
-patch_anchor :: RealSrcSpan -> Anchor -> Anchor
+patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation
 patch_anchor r EpaDelta{} = EpaSpan (RealSrcSpan r Strict.Nothing)
 patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb)
   where
@@ -497,7 +497,7 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
 
 -- | The 'Anchor' for a stmtlist is based on either the location or
 -- the first semicolon annotion.
-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor
+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe EpaLocation
 stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _))
   = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb)
 stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb)

compiler/GHC/Rename/Env.hs

@@ -442,6 +442,7 @@ lookupConstructorInfo con_name
        ; case info of
             IAmConLike con_info -> return con_info
             UnboundGRE          -> return $ ConInfo (ConIsData []) ConHasPositionalArgs
+            IAmTyCon {}         -> failIllegalTyCon WL_Constructor con_name
             _ -> pprPanic "lookupConstructorInfo: not a ConLike" $
                       vcat [ text "name:" <+> ppr con_name ]
        }
@@ -1035,24 +1036,12 @@ lookupOccRn' which_suggest rdr_name
 lookupOccRn :: RdrName -> RnM Name
 lookupOccRn = lookupOccRn' WL_Anything
 
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
+-- | Look up an occurrence of a 'RdrName'.
 --
--- There is a fallback to the type level, when the first lookup fails.
--- This is required to implement a pat-to-type transformation
--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
--- Consider this example:
+-- Displays constructors and pattern synonyms as suggestions if
+-- it is not in scope.
 --
---   data VisProxy a where VP :: forall a -> VisProxy a
---
---   f :: VisProxy Int -> ()
---   f (VP Int) = ()
---
--- Here `Int` is actually a type, but it stays on position where
--- we expect a data constructor.
---
--- In all other cases we just use this additional lookup for better
--- error messaging (See Note [Promotion]).
+-- See Note [lookupOccRnConstr]
 lookupOccRnConstr :: RdrName -> RnM Name
 lookupOccRnConstr rdr_name
   = do { mb_gre <- lookupOccRn_maybe rdr_name
@@ -1064,6 +1053,28 @@ lookupOccRnConstr rdr_name
               Just gre -> return $ greName gre
               Nothing ->  reportUnboundName' WL_Constructor rdr_name} }
 
+{- Note [lookupOccRnConstr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.
+
+However, there is a fallback to the type level when the lookup fails.
+This is required to implement a pat-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+Consider this example:
+
+  data VisProxy a where VP :: forall a -> VisProxy a
+
+  f :: VisProxy Int -> ()
+  f (VP Int) = ()
+
+Here `Int` is actually a type, but it occurs in a position in which we expect
+a data constructor.
+
+In all other cases we just use this additional lookup for better
+error messaging (See Note [Promotion]).
+-}
+
 -- lookupOccRnRecField looks up an occurrence of a RdrName and displays
 -- record fields as suggestions if it is not in scope
 lookupOccRnRecField :: RdrName -> RnM Name

compiler/GHC/Rename/Expr.hs

@@ -539,9 +539,9 @@ rnExpr (ExplicitSum _ alt arity expr)
   = do { (expr', fvs) <- rnLExpr expr
        ; return (ExplicitSum noExtField alt arity expr', fvs) }
 
-rnExpr (RecordCon { rcon_con = con_id
+rnExpr (RecordCon { rcon_con = con_rdr
                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr
        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
        ; (flds', fvss) <- mapAndUnzipM rn_field flds
        ; let rec_binds' = HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd }

compiler/GHC/Stg/Make.hs

+module GHC.Stg.Make
+  ( MkStgRhs (..)
+  , mkTopStgRhs
+  , mkStgRhs
+  , mkStgRhsCon_maybe
+  , mkTopStgRhsCon_maybe
+  )
+where
+
+import GHC.Prelude
+import GHC.Unit.Module
+
+import GHC.Core.DataCon
+import GHC.Core.Type (Type)
+
+import GHC.Stg.Syntax
+import GHC.Stg.Utils (stripStgTicksTop)
+
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.CostCentre
+import GHC.Types.Demand    ( isAtMostOnceDmd )
+import GHC.Types.Tickish
+
+-- Represents the RHS of a binding for use with mk(Top)StgRhs and
+-- mk(Top)StgRhsCon_maybe.
+data MkStgRhs = MkStgRhs
+  { rhs_args :: [Id]     -- ^ Empty for thunks
+  , rhs_expr :: StgExpr  -- ^ RHS expression
+  , rhs_type :: Type     -- ^ RHS type (only used in the JS backend: layering violation)
+  , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?
+  }
+
+
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
+            -> Bool -> Module -> CollectedCCs
+            -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
+mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
+  -- try to make a StgRhsCon first
+  | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs
+  = ( rhs_con, ccs )
+
+  | not (null bndrs)
+  = -- The list of arguments is non-empty, so not CAF
+    ( StgRhsClosure noExtFieldSilent
+                    dontCareCCS
+                    ReEntrant
+                    bndrs rhs typ
+    , ccs )
+
+  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+  | opt_AutoSccsOnIndividualCafs
+  = ( StgRhsClosure noExtFieldSilent
+                    caf_ccs
+                    upd_flag [] rhs typ
+    , collectCC caf_cc caf_ccs ccs )
+
+  | otherwise
+  = ( StgRhsClosure noExtFieldSilent
+                    all_cafs_ccs
+                    upd_flag [] rhs typ
+    , ccs )
+
+  where
+    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+             | otherwise                           = Updatable
+
+    -- CAF cost centres generated for -fcaf-all
+    caf_cc = mkAutoCC bndr modl
+    caf_ccs = mkSingletonCCS caf_cc
+           -- careful: the binder might be :Main.main,
+           -- which doesn't belong to module mod_name.
+           -- bug #249, tests prof001, prof002
+    modl | Just m <- nameModule_maybe (idName bndr) = m
+         | otherwise = this_mod
+
+    -- default CAF cost centre
+    (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialization plan].
+mkStgRhs :: Id -> MkStgRhs -> StgRhs
+mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
+  -- try to make a StgRhsCon first
+  | Just rhs_con <- mkStgRhsCon_maybe mk_rhs
+  = rhs_con
+
+  | otherwise
+  = StgRhsClosure noExtFieldSilent
+                  currentCCS
+                  upd_flag bndrs rhs typ
+  where
+    upd_flag | is_join                             = JumpedTo
+             | not (null bndrs)                    = ReEntrant
+             | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+             | otherwise                           = Updatable
+
+  {-
+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
+    well; and making these into simple non-updatable thunks breaks other
+    assumptions (namely that they will be entered only once).
+
+    upd_flag | isPAP env rhs  = ReEntrant
+             | otherwise      = Updatable
+
+-- Detect thunks which will reduce immediately to PAPs, and make them
+-- non-updatable.  This has several advantages:
+--
+--         - the non-updatable thunk behaves exactly like the PAP,
+--
+--         - the thunk is more efficient to enter, because it is
+--           specialised to the task.
+--
+--         - we save one update frame, one stg_update_PAP, one update
+--           and lots of PAP_enters.
+--
+--         - in the case where the thunk is top-level, we save building
+--           a black hole and furthermore the thunk isn't considered to
+--           be a CAF any more, so it doesn't appear in any SRTs.
+--
+-- We do it here, because the arity information is accurate, and we need
+-- to do it before the SRT pass to save the SRT entries associated with
+-- any top-level PAPs.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+                              where
+                                 arity = stgArity f (lookupBinding env f)
+isPAP env _               = False
+
+-}
+
+{- ToDo:
+          upd = if isOnceDem dem
+                    then (if isNotTop toplev
+                            then SingleEntry    -- HA!  Paydirt for "dem"
+                            else
+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
+                     Updatable)
+                else Updatable
+        -- For now we forbid SingleEntry CAFs; they tickle the
+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+        -- and I don't understand why.  There's only one SE_CAF (well,
+        -- only one that tickled a great gaping bug in an earlier attempt
+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+        -- specifically Main.lvl6 in spectral/cryptarithm2.
+        -- So no great loss.  KSW 2000-07.
+-}
+
+
+-- | Try to make a non top-level StgRhsCon if appropriate
+mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
+mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join)
+  | [] <- bndrs
+  , not is_join
+  , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+  = Just (StgRhsCon currentCCS con mn ticks args typ)
+
+  | otherwise = Nothing
+
+
+-- | Try to make a top-level StgRhsCon if appropriate
+mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
+mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join)
+  | [] <- bndrs
+  , not is_join -- shouldn't happen at top-level
+  , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+  , allow_static_con_app con args
+  = Just (StgRhsCon dontCareCCS con mn ticks args typ)
+
+  | otherwise = Nothing

compiler/GHC/Stg/Pipeline.hs

@@ -31,6 +31,8 @@ import GHC.Stg.CSE      ( stgCse )
 import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams )
 import GHC.Unit.Module ( Module )
 
+import GHC.Core.DataCon (DataCon)
+
 import GHC.Utils.Error
 import GHC.Types.Var
 import GHC.Types.Var.Set
@@ -52,6 +54,12 @@ data StgPipelineOpts = StgPipelineOpts
   , stgPipeline_pprOpts     :: !StgPprOpts
   , stgPlatform             :: !Platform
   , stgPipeline_forBytecode :: !Bool
+
+  , stgPipeline_allowTopLevelConApp  :: Module -> DataCon -> [StgArg] -> Bool
+    -- ^ Is a top-level (static) StgConApp allowed or not. If not, use dynamic allocation.
+    --
+    -- This is typically used to support dynamic linking on Windows and the
+    -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp.
   }
 
 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
@@ -136,7 +144,7 @@ stg2stg logger extra_vars opts this_mod binds
           StgUnarise -> do
             us <- getUniqueSupplyM
             liftIO (stg_linter False "Pre-unarise" binds)
-            let binds' = {-# SCC "StgUnarise" #-} unarise us binds
+            let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds
             liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
             liftIO (stg_linter True "Unarise" binds')
             return binds'

compiler/GHC/Stg/Stats.hs

@@ -46,6 +46,7 @@ data CounterType
   | ReEntrantBinds   Bool{-ditto-}
   | SingleEntryBinds Bool{-ditto-}
   | UpdatableBinds   Bool{-ditto-}
+  | JoinPointBinds   Bool{-ditto-}
   deriving (Eq, Ord)
 
 type Count      = Int
@@ -94,6 +95,7 @@ showStgStats prog
     s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
     s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
     s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+    s (JoinPointBinds _)      = "JoinPointBinds_Nested      "
 
 gatherStgStats :: [StgTopBinding] -> StatEnv
 gatherStgStats binds = combineSEs (map statTopBinding binds)
@@ -132,6 +134,7 @@ statRhs top (_, StgRhsClosure _ _ u _ body _)
         ReEntrant   -> ReEntrantBinds   top
         Updatable   -> UpdatableBinds   top
         SingleEntry -> SingleEntryBinds top
+        JumpedTo    -> JoinPointBinds   top
     )
 
 {-

compiler/GHC/Stg/Syntax.hs

@@ -54,7 +54,6 @@ module GHC.Stg.Syntax (
 
         -- utils
         stgRhsArity, freeVarsOfRhs,
-        isDllConApp,
         stgArgType,
         stgArgRep,
         stgArgRep1,
@@ -87,17 +86,14 @@ import GHC.Core.Ppr( {- instances -} )
 
 import GHC.Types.ForeignCall ( ForeignCall )
 import GHC.Types.Id
-import GHC.Types.Name        ( isDynLinkName )
 import GHC.Types.Tickish     ( StgTickish )
 import GHC.Types.Var.Set
 import GHC.Types.Literal     ( Literal, literalType )
 import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe )
 
-import GHC.Unit.Module       ( Module )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic.Plain
 
-import GHC.Platform
 import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
 
 import Data.ByteString ( ByteString )
@@ -138,51 +134,6 @@ data StgArg
   = StgVarArg  Id
   | StgLitArg  Literal
 
--- | Does this constructor application refer to anything in a different
--- *Windows* DLL?
--- If so, we can't allocate it statically
-isDllConApp
-  :: Platform
-  -> Bool          -- is Opt_ExternalDynamicRefs enabled?
-  -> Module
-  -> DataCon
-  -> [StgArg]
-  -> Bool
-isDllConApp platform ext_dyn_refs this_mod con args
- | not ext_dyn_refs    = False
- | platformOS platform == OSMinGW32
-    = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
- | otherwise = False
-  where
-    -- NB: typePrimRep1 is legit because any free variables won't have
-    -- unlifted type (there are no unlifted things at top level)
-    is_dll_arg :: StgArg -> Bool
-    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
-                             && isDynLinkName platform this_mod (idName v)
-    is_dll_arg _             = False
-
--- True of machine addresses; these are the things that don't work across DLLs.
--- The key point here is that VoidRep comes out False, so that a top level
--- nullary GADT constructor is False for isDllConApp
---
---    data T a where
---      T1 :: T Int
---
--- gives
---
---    T1 :: forall a. (a~Int) -> T a
---
--- and hence the top-level binding
---
---    $WT1 :: T Int
---    $WT1 = T1 Int (Coercion (Refl Int))
---
--- The coercion argument here gets VoidRep
-isAddrRep :: PrimOrVoidRep -> Bool
-isAddrRep (NVRep AddrRep)      = True
-isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
-isAddrRep _                    = False
-
 -- | Type of an @StgArg@
 --
 -- Very half baked because we have lost the type arguments.
@@ -721,24 +672,35 @@ UpdateFlag
 
 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 
-A @ReEntrant@ closure may be entered multiple times, but should not be updated
-or blackholed. An @Updatable@ closure should be updated after evaluation (and
-may be blackholed during evaluation). A @SingleEntry@ closure will only be
-entered once, and so need not be updated but may safely be blackholed.
 -}
 
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
+data UpdateFlag
+  = ReEntrant
+      -- ^ A @ReEntrant@ closure may be entered multiple times, but should not
+      -- be updated or blackholed.
+  | Updatable
+      -- ^ An @Updatable@ closure should be updated after evaluation (and may be
+      -- blackholed during evaluation).
+  | SingleEntry
+      -- ^ A @SingleEntry@ closure will only be entered once, and so need not be
+      -- updated but may safely be blackholed.
+  | JumpedTo
+      -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times
+      -- but has no heap-allocated associated closure.
+  deriving (Show,Eq)
 
 instance Outputable UpdateFlag where
     ppr u = char $ case u of
                        ReEntrant   -> 'r'
                        Updatable   -> 'u'
                        SingleEntry -> 's'
+                       JumpedTo    -> 'j'
 
 isUpdatable :: UpdateFlag -> Bool
 isUpdatable ReEntrant   = False
 isUpdatable SingleEntry = False
 isUpdatable Updatable   = True
+isUpdatable JumpedTo    = False
 
 {-
 ************************************************************************