ghc-lib 0.20201101 → 0.20201201

raw patch · 126 files changed

+7158/−6067 lines, 126 filesdep +parsecdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependencies added: parsec

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +20/−8
• compiler/GHC/ByteCode/Asm.hs +9/−0
• compiler/GHC/Cmm/Info/Build.hs +3/−4
• compiler/GHC/Cmm/Sink.hs +11/−4
• compiler/GHC/CmmToAsm.hs +44/−44
• compiler/GHC/CmmToAsm/Dwarf.hs +12/−9
• compiler/GHC/CmmToAsm/Dwarf/Constants.hs +2/−2
• compiler/GHC/CmmToAsm/Dwarf/Types.hs +22/−8
• compiler/GHC/CmmToAsm/Monad.hs +7/−6
• compiler/GHC/CmmToAsm/PIC.hs +21/−26
• compiler/GHC/CmmToAsm/Ppr.hs +11/−3
• compiler/GHC/CmmToAsm/Reg/Graph.hs +2/−1
• compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +5/−1
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +3/−3
• compiler/GHC/CmmToAsm/Reg/Linear.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Target.hs +5/−5
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +95/−21
• compiler/GHC/CmmToAsm/X86/Cond.hs +16/−16
• compiler/GHC/CmmToAsm/X86/Ppr.hs +30/−9
• compiler/GHC/CmmToC.hs +79/−102
• compiler/GHC/CmmToLlvm/Base.hs +7/−2
• compiler/GHC/Core/Opt/CprAnal.hs +1/−1
• compiler/GHC/Core/Opt/DmdAnal.hs +161/−126
• compiler/GHC/Core/Opt/Pipeline.hs +16/−10
• compiler/GHC/Core/Opt/SetLevels.hs +2/−2
• compiler/GHC/Core/Opt/Simplify.hs +11/−11
• compiler/GHC/Core/Opt/Simplify/Utils.hs +5/−5
• compiler/GHC/Core/Opt/SpecConstr.hs +7/−6
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +7/−8
• compiler/GHC/CoreToByteCode.hs +81/−46
• compiler/GHC/CoreToStg.hs +5/−5
• compiler/GHC/CoreToStg/Prep.hs +2/−2
• compiler/GHC/Driver/Backpack.hs +6/−3
• compiler/GHC/Driver/CodeOutput.hs +7/−1
• compiler/GHC/Driver/Main.hs +139/−91
• compiler/GHC/Driver/Make.hs +10/−9
• compiler/GHC/Driver/MakeFile.hs +5/−5
• compiler/GHC/Driver/Pipeline.hs +102/−403
• compiler/GHC/HsToCore.hs +1/−1
• compiler/GHC/HsToCore/Docs.hs +15/−15
• compiler/GHC/HsToCore/Foreign/Call.hs +4/−30
• compiler/GHC/HsToCore/Foreign/Decl.hs +10/−4
• compiler/GHC/HsToCore/Pmc.hs +4/−1
• compiler/GHC/HsToCore/Pmc/Ppr.hs +2/−15
• compiler/GHC/HsToCore/Quote.hs +118/−104
• compiler/GHC/HsToCore/Usage.hs +3/−1
• compiler/GHC/Iface/Ext/Ast.hs +37/−43
• compiler/GHC/Iface/Load.hs +30/−22
• compiler/GHC/Iface/Make.hs +2/−2
• compiler/GHC/Iface/Recomp.hs +99/−11
• compiler/GHC/Iface/Recomp/Flags.hs +2/−2
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +2/−1
• compiler/GHC/IfaceToCore.hs +11/−14
• compiler/GHC/Linker.hs +36/−0
• compiler/GHC/Linker/Dynamic.hs +264/−0
• compiler/GHC/Linker/ExtraObj.hs +260/−0
• compiler/GHC/Linker/Loader.hs +1720/−0
• compiler/GHC/Linker/MacOS.hs +183/−0
• compiler/GHC/Linker/Static.hs +341/−0
• compiler/GHC/Linker/Unit.hs +134/−0
• compiler/GHC/Linker/Windows.hs +64/−0
• compiler/GHC/Rename/HsType.hs +76/−113
• compiler/GHC/Rename/Module.hs +64/−82
• compiler/GHC/Rename/Names.hs +1/−2
• compiler/GHC/Rename/Utils.hs +4/−7
• compiler/GHC/Runtime/Debugger.hs +6/−5
• compiler/GHC/Runtime/Eval.hs +15/−16
• compiler/GHC/Runtime/Heap/Inspect.hs +5/−1
• compiler/GHC/Runtime/Interpreter.hs +4/−3
• compiler/GHC/Runtime/Linker.hs +0/−1802
• compiler/GHC/Runtime/Loader.hs +18/−17
• compiler/GHC/Stg/Lift/Analysis.hs +20/−30
• compiler/GHC/StgToCmm/ArgRep.hs +29/−24
• compiler/GHC/StgToCmm/DataCon.hs +16/−1
• compiler/GHC/StgToCmm/Layout.hs +6/−4
• compiler/GHC/StgToCmm/Prim.hs +129/−71
• compiler/GHC/StgToCmm/Ticky.hs +4/−3
• compiler/GHC/StgToCmm/Utils.hs +6/−0
• compiler/GHC/SysTools.hs +1/−297
• compiler/GHC/SysTools/ExtraObj.hs +0/−251
• compiler/GHC/SysTools/Tasks.hs +0/−37
• compiler/GHC/Tc/Deriv.hs +8/−11
• compiler/GHC/Tc/Deriv/Generate.hs +11/−12
• compiler/GHC/Tc/Errors.hs +8/−3
• compiler/GHC/Tc/Errors/Hole.hs +1/−1
• compiler/GHC/Tc/Gen/App.hs +4/−4
• compiler/GHC/Tc/Gen/Bind.hs +1/−1
• compiler/GHC/Tc/Gen/Foreign.hs +1/−1
• compiler/GHC/Tc/Gen/Head.hs +1/−1
• compiler/GHC/Tc/Gen/HsType.hs +487/−302
• compiler/GHC/Tc/Gen/Pat.hs +12/−0
• compiler/GHC/Tc/Gen/Sig.hs +58/−61
• compiler/GHC/Tc/Gen/Splice.hs +3/−3
• compiler/GHC/Tc/Instance/Typeable.hs +1/−1
• compiler/GHC/Tc/Module.hs +35/−37
• compiler/GHC/Tc/Solver.hs +36/−14
• compiler/GHC/Tc/Solver/Canonical.hs +4/−4
• compiler/GHC/Tc/Solver/Flatten.hs +1/−1
• compiler/GHC/Tc/TyCl.hs +89/−81
• compiler/GHC/Tc/TyCl/Class.hs +4/−6
• compiler/GHC/Tc/TyCl/Instance.hs +19/−22
• compiler/GHC/Tc/TyCl/PatSyn.hs +81/−23
• compiler/GHC/Tc/Utils/Backpack.hs +2/−2
• compiler/GHC/Tc/Utils/Env.hs +2/−2
• compiler/GHC/Tc/Utils/Instantiate.hs +24/−7
• compiler/GHC/Tc/Utils/Monad.hs +11/−6
• compiler/GHC/Tc/Utils/Unify.hs +10/−5
• compiler/GHC/Tc/Validity.hs +9/−9
• compiler/GHC/ThToHs.hs +75/−51
• compiler/GHC/Unit/Finder.hs +1/−1
• ghc-lib.cabal +21/−6
• ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +12/−0
• ghc-lib/stage0/compiler/build/primop-commutable.hs-incl +6/−6
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +36/−24
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +17/−9
• ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +11/−3
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +36/−24
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +37/−25
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +4/−8
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1226/−1214
• ghc-lib/stage0/lib/ghcversion.h +2/−2
• ghc-lib/stage0/lib/llvm-targets +25/−24
• includes/CodeGen.Platform.hs +1/−2
• libraries/ghci/GHCi/InfoTable.hsc +3/−3
• libraries/ghci/GHCi/Run.hs +3/−3

@@ -215,7 +215,7 @@         FamInst,          -- ** Types and Kinds-        Type, splitForAllTys, funResultTy,+        Type, splitForAllTyCoVars, funResultTy,         pprParendType, pprTypeApp,         Kind,         PredType,@@ -313,6 +313,7 @@ import GHC.Driver.Ppr  import GHC.ByteCode.Types+import GHC.Runtime.Loader import GHC.Runtime.Eval import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter@@ -621,12 +622,6 @@ -- 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@@ -735,6 +730,8 @@ getProgramDynFlags = getSessionDynFlags  -- | Set the 'DynFlags' used to evaluate interactive expressions.+-- Also initialise (load) plugins.+-- -- Note: this cannot be used for changes to packages.  Use -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the -- 'unitState' into the interactive @DynFlags@.@@ -742,7 +739,22 @@ setInteractiveDynFlags dflags = do   dflags' <- checkNewDynFlags dflags   dflags'' <- checkNewInteractiveDynFlags dflags'-  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}+  modifySessionM $ \hsc_env0 -> do+    let ic0 = hsc_IC hsc_env0++    -- Initialise (load) plugins in the interactive environment with the new+    -- DynFlags+    plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $+                    hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}++    -- Update both plugins cache and DynFlags in the interactive context.+    return $ hsc_env0+                { hsc_IC = ic0+                    { ic_plugins = hsc_plugins plugin_env+                    , ic_dflags  = hsc_dflags  plugin_env+                    }+                }+  -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags

@@ -464,6 +464,12 @@     literal (LitNumber nt i) = case nt of       LitNumInt     -> int (fromIntegral i)       LitNumWord    -> int (fromIntegral i)+      LitNumInt8    -> int8 (fromIntegral i)+      LitNumWord8   -> int8 (fromIntegral i)+      LitNumInt16   -> int16 (fromIntegral i)+      LitNumWord16  -> int16 (fromIntegral i)+      LitNumInt32   -> int32 (fromIntegral i)+      LitNumWord32  -> int32 (fromIntegral i)       LitNumInt64   -> int64 (fromIntegral i)       LitNumWord64  -> int64 (fromIntegral i)       LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"@@ -478,6 +484,9 @@     float = words . mkLitF     double = words . mkLitD platform     int = words . mkLitI+    int8 = words . mkLitI64 platform+    int16 = words . mkLitI64 platform+    int32 = words . mkLitI64 platform     int64 = words . mkLitI64 platform     words ws = lit (map BCONPtrWord ws)     word w = words [w]

@@ -946,7 +946,8 @@   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 @@            in                state{ moduleSRTMap = srt_map } -    this_mod = thisModule topSRT-     allStaticData =       all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls @@ -1048,7 +1047,7 @@           -- 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.

@@ -449,6 +449,7 @@                         || l `elemLRegSet` skipped                         || not (okToInline platform rhs node) +        -- How often is l used in the current node.         l_usages = lookupUFM usages l         l_live   = l `elemRegSet` live @@ -554,10 +555,16 @@  regsUsedIn :: LRegSet -> CmmExpr -> Bool regsUsedIn ls _ | nullLRegSet ls = False-regsUsedIn ls e = wrapRecExpf f e False-  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True-        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True-        f _ z = z+regsUsedIn ls e = go ls e False+  where use :: LRegSet -> CmmExpr -> Bool -> Bool+        use ls (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True+        use ls (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True+        use _ls _ z = z++        go :: LRegSet -> CmmExpr -> Bool -> Bool+        go ls (CmmMachOp _ es) z = foldr (go ls) z es+        go ls (CmmLoad addr _) z = go ls addr z+        go ls e                z = use ls e z  -- we don't inline into CmmUnsafeForeignCall if the expression refers -- to global registers.  This is a HACK to avoid global registers

@@ -152,11 +152,11 @@               -> 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)@@ -166,7 +166,7 @@       ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"       ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"       ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"-      ArchARM64     -> panic "nativeCodeGen: No NCG for ARM64"+      ArchAArch64   -> panic "nativeCodeGen: No NCG for AArch64"       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"@@ -221,20 +221,20 @@ 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 @@         -- 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 @@ cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => DynFlags               -> NCGConfig-              -> Module -> ModLocation+              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> UniqSupply@@ -308,7 +308,7 @@               -> 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 @@                   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 @@               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 @@                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => DynFlags               -> NCGConfig-              -> Module -> ModLocation+              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> LabelMap DebugBlock@@ -366,7 +366,7 @@               -> 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 @@         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 @@ 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 @@                 , 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 @@         -- 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 @@         -- 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 @@  -- | 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 @@              else Outputable.empty)   where-        config   = initNCGConfig dflags         platform = ncgPlatform config          -- Generate "symbol stubs" for all external symbols that might@@ -915,7 +914,7 @@  genMachCode         :: NCGConfig-        -> Module -> ModLocation+        -> ModLocation         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])         -> DwarfFiles         -> LabelMap DebugBlock@@ -928,9 +927,9 @@                 , 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 @@     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 @@ 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@@ -1144,9 +1142,10 @@            -> 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@@ -1188,8 +1187,9 @@             ArchX86    -> v             _          -> Nothing -   , ncgDwarfEnabled        = debugLevel dflags > 0+   , 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+   , ncgDwarfStripBlockInfo = debugLevel dflags <  2 -- We strip out block information when running with -g0 or -g1.+   , ncgDwarfSourceNotes    = debugLevel dflags >= 3 -- We produce GHC-specific source-note DIEs only with -g3    }-

@@ -45,7 +45,7 @@         | otherwise                     = dbg   compPath <- getCurrentDirectory   let lowLabel = dblCLabel $ head procs-      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs+      highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs       dwarfUnit = DwarfCompileUnit         { dwChildren = map (procToDwarf config) (map stripBlocks procs)         , dwName = fromMaybe "" (ml_hs_file modLoc)@@ -99,10 +99,10 @@ -- scattered in the final binary. Without split sections, we could make a -- single arange based on the first/last proc. mkDwarfARange :: DebugBlock -> DwarfARange-mkDwarfARange proc = DwarfARange start end+mkDwarfARange proc = DwarfARange lbl end   where-    start = dblCLabel proc-    end = mkAsmTempEndLabel start+    lbl = dblCLabel proc+    end = mkAsmTempProcEndLabel lbl  -- | Header for a compilation unit, establishing global format -- parameters@@ -176,7 +176,7 @@ -- | Generate DWARF info for a procedure debug block procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo procToDwarf config prc-  = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)+  = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)                     , dwName     = case dblSourceTick prc of                          Just s@SourceNote{} -> sourceName s                          _otherwise -> show (dblLabel prc)@@ -195,14 +195,17 @@   goodParent _ = True  -- | Generate DWARF info for a block-blockToDwarf :: DebugBlock -> DwarfInfo-blockToDwarf blk-  = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)-                              ++ map blockToDwarf (dblBlocks blk)+blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo+blockToDwarf config blk+  = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes                , dwLabel    = dblCLabel blk                , dwMarker   = marker                }   where+    srcNotes+      | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)+      | otherwise                  = []+     marker       | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk       | otherwise                 = Nothing   -- block was optimized out

@@ -48,7 +48,7 @@ -- * Dwarf attributes dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,   dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,-  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word+  dW_AT_use_UTF8, dW_AT_linkage_name :: Word dW_AT_name              = 0x03 dW_AT_stmt_list         = 0x10 dW_AT_low_pc            = 0x11@@ -59,7 +59,7 @@ dW_AT_external          = 0x3f dW_AT_frame_base        = 0x40 dW_AT_use_UTF8          = 0x53-dW_AT_MIPS_linkage_name = 0x2007+dW_AT_linkage_name      = 0x6e  -- * Custom DWARF attributes -- Chosen a more or less random section of the vendor-extensible region

@@ -105,7 +105,7 @@       -- DwAbbrSubprogramWithParent       subprogramAttrs =            [ (dW_AT_name, dW_FORM_string)-           , (dW_AT_MIPS_linkage_name, dW_FORM_string)+           , (dW_AT_linkage_name, dW_FORM_string)            , (dW_AT_external, dW_FORM_flag)            , (dW_AT_low_pc, dW_FORM_addr)            , (dW_AT_high_pc, dW_FORM_addr)@@ -178,7 +178,8 @@   $$ pprString producer   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir-  $$ pprWord platform (pdoc platform lowLabel)+     -- Offset due to Note [Info Offset]+  $$ pprWord platform (pdoc platform lowLabel <> text "-1")   $$ pprWord platform (pdoc platform highLabel)   $$ if haveSrc      then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)@@ -189,8 +190,9 @@   $$ pprString name   $$ pprLabelString platform label   $$ pprFlag (externallyVisibleCLabel label)-  $$ pprWord platform (pdoc platform label)-  $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel label)+     -- Offset due to Note [Info Offset]+  $$ pprWord platform (pdoc platform label <> text "-1")+  $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label)   $$ pprByte 1   $$ pprByte dW_OP_call_frame_cfa   $$ parentValue@@ -256,7 +258,10 @@      $$ pprWord platform (char '0')  pprDwarfARange :: Platform -> DwarfARange -> SDoc-pprDwarfARange platform arng = pprWord platform (pdoc platform $ dwArngStartLabel arng) $$ pprWord platform length+pprDwarfARange platform arng =+    -- Offset due to Note [Info offset].+    pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")+    $$ pprWord platform length   where     length = pdoc platform (dwArngEndLabel arng)              <> char '-' <> pdoc platform (dwArngStartLabel arng)@@ -354,9 +359,9 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)   = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")         fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")-        procEnd     = mkAsmTempEndLabel procLbl+        procEnd     = mkAsmTempProcEndLabel procLbl         ifInfo str  = if hasInfo then text str else empty-                      -- see [Note: Info Offset]+                      -- see Note [Info Offset]     in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon             , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)             , pdoc platform fdeLabel <> colon@@ -398,7 +403,7 @@          in if oldUws == uws              then (empty, oldUws)-             else let -- see [Note: Info Offset]+             else let -- see Note [Info Offset]                       needsOffset = firstDecl && hasInfo                       lblDoc = pdoc platform lbl <>                                if needsOffset then text "-1" else empty@@ -407,6 +412,7 @@                   in (doc, uws)  -- Note [Info Offset]+-- ~~~~~~~~~~~~~~~~~~ -- -- GDB was pretty much written with C-like programs in mind, and as a -- result they assume that once you have a return address, it is a@@ -425,6 +431,14 @@ -- Note that this will not prevent GDB from failing to look-up the -- correct function name for the frame, as that uses the symbol table, -- which we can not manipulate as easily.+--+-- We apply this offset in several places:+--+--  * unwind information in .debug_frames+--  * the subprogram and lexical_block DIEs in .debug_info+--  * the ranges in .debug_aranges+--+-- In the latter two cases we apply the offset unconditionally. -- -- There's a GDB patch to address this at [1]. At the moment of writing -- it's not merged, so I recommend building GDB with the patch if you

@@ -80,6 +80,8 @@     canShortcut               :: instr -> Maybe jumpDest,     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,+    -- | 'Module' is only for printing internal labels. See Note [Internal proc+    -- labels] in CLabel.     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],@@ -107,7 +109,6 @@                 natm_imports     :: [(CLabel)],                 natm_pic         :: Maybe Reg,                 natm_config      :: NCGConfig,-                natm_this_module :: Module,                 natm_modloc      :: ModLocation,                 natm_fileid      :: DwarfFiles,                 natm_debug_map   :: LabelMap DebugBlock,@@ -125,9 +126,9 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> NCGConfig -> Module -> ModLocation ->+mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation ->                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State-mkNatM_State us delta config this_mod+mkNatM_State us delta config         = \loc dwf dbg cfg ->                 NatM_State                         { natm_us = us@@ -135,7 +136,6 @@                         , natm_imports = []                         , natm_pic = Nothing                         , natm_config = config-                        , natm_this_module = this_mod                         , natm_modloc = loc                         , natm_fileid = dwf                         , natm_debug_map = dbg@@ -198,10 +198,11 @@ setDeltaNat :: Int -> NatM () setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) - getThisModuleNat :: NatM Module-getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)+getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st) +instance HasModule NatM where+  getModule = getThisModuleNat  addImportNat :: CLabel -> NatM () addImportNat imp

@@ -65,7 +65,6 @@ import GHC.Cmm.CLabel  import GHC.Types.Basic-import GHC.Unit.Module  import GHC.Utils.Outputable import GHC.Utils.Panic@@ -95,11 +94,9 @@  class Monad m => CmmMakeDynamicReferenceM m where     addImport :: CLabel -> m ()-    getThisModule :: m Module  instance CmmMakeDynamicReferenceM NatM where     addImport = addImportNat-    getThisModule = getThisModuleNat  cmmMakeDynamicReference   :: CmmMakeDynamicReferenceM m@@ -113,13 +110,11 @@   = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through    | otherwise-  = do this_mod <- getThisModule-       let platform = ncgPlatform config+  = do let platform = ncgPlatform config        case howToAccessLabel                 config                 (platformArch platform)                 (platformOS   platform)-                this_mod                 referenceKind lbl of          AccessViaStub -> do@@ -208,7 +203,7 @@         | AccessViaSymbolPtr         | AccessDirectly -howToAccessLabel :: NCGConfig -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle+howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle  -- Windows -- In Windows speak, a "module" is a set of objects linked into the@@ -231,7 +226,7 @@ -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. ---howToAccessLabel config _ OSMinGW32 this_mod _ lbl+howToAccessLabel config _arch OSMinGW32 _kind lbl          -- Assume all symbols will be in the same PE, so just access them directly.         | not (ncgExternalDynamicRefs config)@@ -239,7 +234,7 @@          -- If the target symbol is in another PE we need to access it via the         --      appropriate __imp_SYMBOL pointer.-        | labelDynamic config this_mod lbl+        | labelDynamic config lbl         = AccessViaSymbolPtr          -- Target symbol is in the same PE as the caller, so just access it directly.@@ -255,9 +250,9 @@ -- It is always possible to access something indirectly, -- even when it's not necessary. ---howToAccessLabel config arch OSDarwin this_mod DataReference lbl+howToAccessLabel config arch OSDarwin DataReference lbl         -- data access to a dynamic library goes via a symbol pointer-        | labelDynamic config this_mod lbl+        | labelDynamic config lbl         = AccessViaSymbolPtr          -- when generating PIC code, all cross-module data references must@@ -276,21 +271,21 @@         | otherwise         = AccessDirectly -howToAccessLabel config arch OSDarwin this_mod JumpReference lbl+howToAccessLabel config arch OSDarwin JumpReference lbl         -- dyld code stubs don't work for tailcalls because the         -- stack alignment is only right for regular calls.         -- Therefore, we have to go via a symbol pointer:         | arch == ArchX86 || arch == ArchX86_64-        , labelDynamic config this_mod lbl+        , labelDynamic config lbl         = AccessViaSymbolPtr  -howToAccessLabel config arch OSDarwin this_mod _ lbl+howToAccessLabel config arch OSDarwin _kind lbl         -- Code stubs are the usual method of choice for imported code;         -- not needed on x86_64 because Apple's new linker, ld64, generates         -- them automatically.         | arch /= ArchX86_64-        , labelDynamic config this_mod lbl+        , labelDynamic config lbl         = AccessViaStub          | otherwise@@ -301,7 +296,7 @@ -- AIX  -- quite simple (for now)-howToAccessLabel _config _arch OSAIX _this_mod kind _lbl+howToAccessLabel _config _arch OSAIX kind _lbl         = case kind of             DataReference -> AccessViaSymbolPtr             CallReference -> AccessDirectly@@ -318,7 +313,7 @@ -- from position independent code. It is also required from the main program -- when dynamic libraries containing Haskell code are used. -howToAccessLabel _ (ArchPPC_64 _) os _ kind _+howToAccessLabel _config (ArchPPC_64 _) os kind _lbl         | osElfTarget os         = case kind of           -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC@@ -330,7 +325,7 @@           -- regular calls are handled by the runtime linker           _             -> AccessDirectly -howToAccessLabel config _ os _ _ _+howToAccessLabel config _arch os _kind _lbl         -- no PIC -> the dynamic linker does everything for us;         --           if we don't dynamically link to Haskell code,         --           it actually manages to do so without messing things up.@@ -339,11 +334,11 @@           not (ncgExternalDynamicRefs config)         = AccessDirectly -howToAccessLabel config arch os this_mod DataReference lbl+howToAccessLabel config arch os DataReference lbl         | osElfTarget os         = case () of             -- A dynamic label needs to be accessed via a symbol pointer.-          _ | labelDynamic config this_mod lbl+          _ | labelDynamic config lbl             -> AccessViaSymbolPtr              -- For PowerPC32 -fPIC, we have to access even static data@@ -369,25 +364,25 @@         -- (AccessDirectly, because we get an implicit symbol stub)         -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel config arch os this_mod CallReference lbl+howToAccessLabel config arch os CallReference lbl         | osElfTarget os-        , labelDynamic config this_mod lbl && not (ncgPIC config)+        , labelDynamic config lbl && not (ncgPIC config)         = AccessDirectly          | osElfTarget os         , arch /= ArchX86-        , labelDynamic config this_mod lbl+        , labelDynamic config lbl         , ncgPIC config         = AccessViaStub -howToAccessLabel config _ os this_mod _ lbl+howToAccessLabel config _arch os _kind lbl         | osElfTarget os-        = if labelDynamic config this_mod lbl+        = if labelDynamic config lbl             then AccessViaSymbolPtr             else AccessDirectly  -- all other platforms-howToAccessLabel config _ _ _ _ _+howToAccessLabel config _arch _os _kind _lbl         | not (ncgPIC config)         = AccessDirectly 

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-}  ----------------------------------------------------------------------------- --@@ -38,9 +38,17 @@ import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import GHC.Exts+import GHC.Exts hiding (extendWord8#) import GHC.Word +#if MIN_VERSION_base(4,16,0)+import GHC.Base (extendWord8#)+#else+extendWord8# :: Word# -> Word#+extendWord8# w = w+{-# INLINE extendWord8# #-}+#endif+ -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing @@ -103,7 +111,7 @@        -- we know that the Chars we create are in the ASCII range        -- so we bypass the check in "chr"        chr' :: Word8 -> Char-       chr' (W8# w#) = C# (chr# (word2Int# w#))+       chr' (W8# w#) = C# (chr# (word2Int# (extendWord8# w#)))         octal :: Word8 -> String        octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)

@@ -283,7 +283,8 @@                         , raCoalesced   = rmCoalesce                         , raSpillStats  = spillStats                         , raSpillCosts  = spillCosts-                        , raSpilled     = code_spilled }+                        , raSpilled     = code_spilled+                        , raPlatform    = platform }                  -- Bundle up all the register allocator statistics.                 --   .. but make sure to drop them on the floor if they're not

@@ -79,7 +79,11 @@         , raSpillCosts  :: SpillCostInfo            -- | Code with spill instructions added.-        , raSpilled     :: [LiveCmmDecl statics instr] }+        , raSpilled     :: [LiveCmmDecl statics instr]++          -- | Target platform+        , raPlatform    :: !Platform+        }           -- a successful coloring

@@ -115,7 +115,7 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAArch64   -> panic "trivColorable ArchAArch64"                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"@@ -146,7 +146,7 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 0                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAArch64   -> panic "trivColorable ArchAArch64"                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"@@ -179,7 +179,7 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAArch64   -> panic "trivColorable ArchAArch64"                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"

@@ -223,7 +223,7 @@       ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"-      ArchARM64      -> panic "linearRegAlloc ArchARM64"+      ArchAArch64    -> panic "linearRegAlloc ArchAArch64"       ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"

@@ -78,7 +78,7 @@    ArchSPARC     -> SPARC.Instr.maxSpillSlots config    ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"    ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"-   ArchARM64     -> panic "maxSpillSlots ArchARM64"+   ArchAArch64   -> panic "maxSpillSlots ArchAArch64"    ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config    ArchAlpha     -> panic "maxSpillSlots ArchAlpha"    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"

@@ -48,7 +48,7 @@       ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.virtualRegSqueeze       ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"-      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"+      ArchAArch64   -> panic "targetVirtualRegSqueeze ArchAArch64"       ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"@@ -67,7 +67,7 @@       ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.realRegSqueeze       ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"-      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"+      ArchAArch64   -> panic "targetRealRegSqueeze ArchAArch64"       ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"@@ -85,7 +85,7 @@       ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"       ArchPPC_64 _  -> PPC.classOfRealReg       ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"-      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"+      ArchAArch64   -> panic "targetClassOfRealReg ArchAArch64"       ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"@@ -103,7 +103,7 @@       ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"       ArchPPC_64 _  -> PPC.mkVirtualReg       ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"-      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"+      ArchAArch64   -> panic "targetMkVirtualReg ArchAArch64"       ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"@@ -121,7 +121,7 @@       ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"       ArchPPC_64 _  -> PPC.regDotColor       ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"-      ArchARM64     -> panic "targetRegDotColor ArchARM64"+      ArchAArch64   -> panic "targetRegDotColor ArchAArch64"       ArchAlpha     -> panic "targetRegDotColor ArchAlpha"       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"

@@ -1052,7 +1052,9 @@     --------------------     add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register     add_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger y = add_int rep x y+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x y     add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y       where format = intFormat rep     -- TODO: There are other interesting patterns we want to replace@@ -1061,7 +1063,9 @@     --------------------     sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register     sub_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger (-y) = add_int rep x (-y)+        | is32BitInteger (-y)+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x (-y)     sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y      -- our three-operand add instruction:@@ -1824,7 +1828,36 @@ codes are set according to the supplied comparison operation. -} +{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or and+    perform a single conditional jump based on the+    result.++    * Other comparisons:++    We map all other comparisons to the >= operation.+    Why? Because it's easy to encode it with a single+    conditional jump.++    We do this by first computing [r1_lo - r2_lo]+    and use the carry flag to compute+    [r1_high - r2_high - CF].++    At which point if r1 >= r2 then the result will be+    positive. Otherwise negative so we can branch on this+    condition.++-}++ genCondBranch     :: BlockId      -- the source of the jump     -> BlockId      -- the true branch target@@ -1841,23 +1874,64 @@                -> NatM InstrBlock  -- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit] genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])   | is32Bit, Just W64 <- maybeIntComparison mop = do-  ChildCode64 code1 r1_lo <- iselExpr64 e1-  ChildCode64 code2 r2_lo <- iselExpr64 e2-  let r1_hi = getHiVRegFromLo r1_lo-      r2_hi = getHiVRegFromLo r2_lo-      cond = machOpToCond mop-      Just cond' = maybeFlipCond cond-  --TODO: Update CFG for x86-  let code = code1 `appOL` code2 `appOL` toOL [-        CMP II32 (OpReg r2_hi) (OpReg r1_hi),-        JXX cond true,-        JXX cond' false,-        CMP II32 (OpReg r2_lo) (OpReg r1_lo),-        JXX cond true] `appOL` genBranch false-  return code +  -- The resulting registers here are both the lower part of+  -- the register as well as a way to get at the higher part.+  ChildCode64 code1 r1 <- iselExpr64 e1+  ChildCode64 code2 r2 <- iselExpr64 e2+  let cond = machOpToCond mop :: Cond++  let cmpCode = intComparison cond true false r1 r2+  return $ code1 `appOL` code2 `appOL` cmpCode++  where+    intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock+    intComparison cond true false r1_lo r2_lo =+      case cond of+        -- Impossible results of machOpToCond+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> cmpExact+        NE  -> cmpExact+        -- [x >= y]+        GE  -> cmpGE+        GEU -> cmpGE+        -- [x >  y] <==> ![y >= x]+        GTT -> intComparison GE  false true r2_lo r1_lo+        GU  -> intComparison GEU false true r2_lo r1_lo+        -- [x <= y] <==> [y >= x]+        LE  -> intComparison GE  true false r2_lo r1_lo+        LEU -> intComparison GEU true false r2_lo r1_lo+        -- [x <  y] <==> ![x >= x]+        LTT -> intComparison GE  false true r1_lo r2_lo+        LU  -> intComparison GEU false true r1_lo r2_lo+      where+        r1_hi = getHiVRegFromLo r1_lo+        r2_hi = getHiVRegFromLo r2_lo+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)+            , XOR II32 (OpReg r2_lo) (OpReg r1_lo)+            , OR  II32 (OpReg r1_hi)  (OpReg r1_lo)+            , JXX cond true+            , JXX ALWAYS false+            ]+        cmpGE = toOL+            [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg r1_hi)+            , JXX cond true+            , JXX ALWAYS false ]+ genCondBranch' _ bid id false bool = do   CondCode is_float cond cond_code <- getCondCode bool   use_sse2 <- sse2Enabled@@ -2047,12 +2121,12 @@         -- final move should go away, because it's the last use of arg         -- and the first use of dst_r.         AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ], bid)+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)         AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ], bid)+                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)         -- In these cases we need a new block id, and have to return it so         -- that later instruction selection can reference it.         AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)

@@ -11,22 +11,22 @@  data Cond         = ALWAYS        -- What's really used? ToDo-        | EQQ-        | GE-        | GEU-        | GTT-        | GU-        | LE-        | LEU-        | LTT-        | LU-        | NE-        | NEG-        | POS-        | CARRY-        | OFLO-        | PARITY-        | NOTPARITY+        | EQQ           -- je/jz -> zf = 1+        | GE            -- jge+        | GEU           -- ae+        | GTT           -- jg+        | GU            -- ja+        | LE            -- jle+        | LEU           -- jbe+        | LTT           -- jl+        | LU            -- jb+        | NE            -- jne+        | NEG           -- js+        | POS           -- jns+        | CARRY         -- jc+        | OFLO          -- jo+        | PARITY        -- jp+        | NOTPARITY     -- jnp         deriving Eq  condToUnsigned :: Cond -> Cond

@@ -90,19 +90,21 @@         -- special case for code without info table:         pprSectionAlign config (Section Text lbl) $$         pprProcAlignment config $$+        pprProcLabel config lbl $$         pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed         vcat (map (pprBasicBlock config top_info) blocks) $$-        (if ncgDwarfEnabled config-         then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+        ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$         pprSizeDecl platform lbl      Just (CmmStaticsRaw info_lbl _) ->       pprSectionAlign config (Section Text info_lbl) $$       pprProcAlignment config $$+      pprProcLabel config lbl $$       (if platformHasSubsectionsViaSymbols platform           then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'           else empty) $$       vcat (map (pprBasicBlock config top_info) blocks) $$+      ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$       -- above: Even the first block gets a label, because with branch-chain       -- elimination, it might be the target of a goto.       (if platformHasSubsectionsViaSymbols platform@@ -114,6 +116,25 @@        else empty) $$       pprSizeDecl platform info_lbl +-- | Output an internal proc label. See Note [Internal proc labels] in CLabel.+pprProcLabel :: NCGConfig -> CLabel -> SDoc+pprProcLabel config lbl+  | ncgExposeInternalSymbols config+  , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl+  = lbl' <> char ':'+  | otherwise+  = empty++pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name+                -> SDoc+pprProcEndLabel platform lbl =+    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'++pprBlockEndLabel :: Platform -> CLabel -- ^ Block name+                 -> SDoc+pprBlockEndLabel platform lbl =+    pdoc platform (mkAsmTempEndLabel lbl) <> char ':'+ -- | Output the ELF .size directive. pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl@@ -126,9 +147,11 @@   = maybe_infotable $     pprLabel platform asmLbl $$     vcat (map (pprInstr platform) instrs) $$-    (if ncgDwarfEnabled config-      then pdoc (ncgPlatform config) (mkAsmTempEndLabel asmLbl) <> char ':'-      else empty+    ppWhen (ncgDwarfEnabled config) (+      -- Emit both end labels since this may end up being a standalone+      -- top-level block+      pprBlockEndLabel platform asmLbl+      <> pprProcEndLabel platform asmLbl     )   where     asmLbl = blockLbl blockid@@ -141,10 +164,8 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           (if ncgDwarfEnabled config-               then pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':'-               else empty-           )+           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':')+     -- Make sure the info table has the right .loc for the block     -- coming right after it. See [Note: Info Offset]     infoTableLoc = case instrs of

@@ -159,8 +159,14 @@          -- See Note [StgWord alignment]          , pprAlignment (wordWidth platform)          , text "= {" ]-    $$ nest 8 (commafy (pprStatics platform ds))+    $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds))     $$ text "};"+  where+    toLits :: [CmmStatic] -> [CmmLit]+    toLits = map f+      where+        f (CmmStaticLit lit) = lit+        f static             = pprPanic "pprWordArray: Unexpected literal"  (pprStatic platform static)  pprAlignment :: Width -> SDoc pprAlignment words =@@ -501,59 +507,69 @@ -- --------------------------------------------------------------------------- -- Static data -pprStatics :: Platform -> [CmmStatic] -> [SDoc]-pprStatics platform = pprStatics'+-- | Produce a list of word sized literals encoding the given list of 'CmmLit's.+staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]+staticLitsToWords platform = go . foldMap decomposeMultiWord   where-    pprStatics' = \case-      [] -> []-      (CmmStaticLit (CmmFloat f W32) : rest)-        -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding-        | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest-        -> pprLit1 platform (floatToWord platform f) : pprStatics' rest'-        -- adjacent floats aren't padded but combined into a single word-        | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest-        -> pprLit1 platform (floatPairToWord platform f g) : pprStatics' rest'-        | wordWidth platform == W32-        -> pprLit1 platform (floatToWord platform f) : pprStatics' rest-        | otherwise-        -> pprPanic "pprStatics: float" (vcat (map ppr' rest))-          where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)-                ppr' _other           = text "bad static!"--      (CmmStaticLit (CmmFloat f W64) : rest)-        -> map (pprLit1 platform) (doubleToWords platform f) ++ pprStatics' rest+    -- rem_bytes is how many bytes remain in the word we are currently filling.+    -- accum is the word we are filling.+    go :: [CmmLit] -> [SDoc]+    go [] = []+    go lits@(lit : _)+      | Just _ <- isSubWordLit lit+      = goSubWord wordWidthBytes 0 lits+    go (lit : rest)+      = pprLit1 platform lit : go rest -      (CmmStaticLit (CmmInt i W64) : rest)-        | wordWidth platform == W32-        -> case platformByteOrder platform of-            BigEndian    -> pprStatics' (CmmStaticLit (CmmInt q W32) :-                                         CmmStaticLit (CmmInt r W32) : rest)-            LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) :-                                         CmmStaticLit (CmmInt q W32) : rest)-           where r = i .&. 0xffffffff-                 q = i `shiftR` 32+    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]+    goSubWord rem_bytes accum (lit : rest)+      | Just (bytes, w) <- isSubWordLit lit+      , rem_bytes >= widthInBytes w+      = let accum' =+              case platformByteOrder platform of+                BigEndian    -> (accum `shiftL` widthInBits w) .|. bytes+                LittleEndian -> (accum `shiftL` widthInBits w) .|. byteSwap w bytes+        in goSubWord (rem_bytes - widthInBytes w) accum' rest+    goSubWord rem_bytes accum rest+      = pprWord (byteSwap (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest -      (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)-        | wordWidth platform == W64-        -> case platformByteOrder platform of-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)+    -- Decompose multi-word or floating-point literals into multiple+    -- single-word (or smaller) literals.+    decomposeMultiWord :: CmmLit -> [CmmLit]+    decomposeMultiWord (CmmFloat n W64)+      -- This will produce a W64 integer, which will then be broken up further+      -- on the next iteration on 32-bit platforms.+      = [doubleToWord64 n]+    decomposeMultiWord (CmmFloat n W32)+      = [floatToWord32 n]+    decomposeMultiWord (CmmInt n W64)+      | W32 <- wordWidth platform+      = [CmmInt hi W32, CmmInt lo W32]+      where+        hi = n `shiftR` 32+        lo = n .&. 0xffffffff+    decomposeMultiWord lit = [lit] -      (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)-        | wordWidth platform == W32-        -> case platformByteOrder platform of-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)+    -- Decompose a sub-word-sized literal into the integer value and its+    -- (sub-word-sized) width.+    isSubWordLit :: CmmLit -> Maybe (Integer, Width)+    isSubWordLit lit =+      case lit of+        CmmInt n w+          | w < wordWidth platform   -> Just (n, w)+        _                            -> Nothing -      (CmmStaticLit (CmmInt _ w) : _)-        | w /= wordWidth platform-        -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)+    wordWidthBytes = widthInBytes $ wordWidth platform -      (CmmStaticLit lit : rest)-        -> pprLit1 platform lit : pprStatics' rest+    pprWord :: Integer -> SDoc+    pprWord n = pprHexVal platform n (wordWidth platform) -      (other : _)-        -> pprPanic "pprStatics: other" (pprStatic platform other)+byteSwap :: Width -> Integer -> Integer+byteSwap width n = foldl' f 0 bytes+  where+    f acc m = (acc `shiftL` 8) .|. m+    bytes = [ byte i | i <- [0..widthInBytes width - 1] ]+    byte i = (n `shiftR` (i*8)) .&. 0xff  pprStatic :: Platform -> CmmStatic -> SDoc pprStatic platform s = case s of@@ -1158,7 +1174,7 @@           bewareLoadStoreAlignment ArchMipseb   = True           bewareLoadStoreAlignment ArchMipsel   = True           bewareLoadStoreAlignment (ArchARM {}) = True-          bewareLoadStoreAlignment ArchARM64    = True+          bewareLoadStoreAlignment ArchAArch64  = True           bewareLoadStoreAlignment ArchSPARC    = True           bewareLoadStoreAlignment ArchSPARC64  = True           -- Pessimistically assume that they will also cause problems@@ -1252,69 +1268,30 @@ -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. -castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-castFloatToWord32Array = U.castSTUArray--castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-castDoubleToWord64Array = U.castSTUArray--floatToWord :: Platform -> Rational -> CmmLit-floatToWord platform r-  = runST (do+floatToWord32 :: Rational -> CmmLit+floatToWord32 r+  = runST $ do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 (fromRational r)         arr' <- castFloatToWord32Array arr         w32 <- readArray arr' 0-        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))-    )-    where wo | wordWidth platform == W64-             , BigEndian <- platformByteOrder platform-             = 32-             | otherwise-             = 0--floatPairToWord :: Platform -> Rational -> Rational -> CmmLit-floatPairToWord platform r1 r2-  = runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r1)-        writeArray arr 1 (fromRational r2)-        arr' <- castFloatToWord32Array arr-        w32_1 <- readArray arr' 0-        w32_2 <- readArray arr' 1-        return (pprWord32Pair w32_1 w32_2)-    )-    where pprWord32Pair w32_1 w32_2-              | BigEndian <- platformByteOrder platform =-                  CmmInt ((shiftL i1 32) .|. i2) W64-              | otherwise =-                  CmmInt ((shiftL i2 32) .|. i1) W64-              where i1 = toInteger w32_1-                    i2 = toInteger w32_2+        return (CmmInt (toInteger w32) W32)+  where+    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)+    castFloatToWord32Array = U.castSTUArray -doubleToWords :: Platform -> Rational -> [CmmLit]-doubleToWords platform r-  = runST (do+doubleToWord64 :: Rational -> CmmLit+doubleToWord64 r+  = runST $ do         arr <- newArray_ ((0::Int),1)         writeArray arr 0 (fromRational r)         arr' <- castDoubleToWord64Array arr         w64 <- readArray arr' 0-        return (pprWord64 w64)-    )-    where targetWidth = wordWidth platform-          pprWord64 w64-              | targetWidth == W64 =-                  [ CmmInt (toInteger w64) targetWidth ]-              | targetWidth == W32 =-                  [ CmmInt (toInteger targetW1) targetWidth-                  , CmmInt (toInteger targetW2) targetWidth-                  ]-              | otherwise = panic "doubleToWords.pprWord64"-              where (targetW1, targetW2) = case platformByteOrder platform of-                        BigEndian    -> (wHi, wLo)-                        LittleEndian -> (wLo, wHi)-                    wHi = w64 `shiftR` 32-                    wLo = w64 .&. 0xFFFFffff+        return $ CmmInt (toInteger w64) W64+  where+    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)+    castDoubleToWord64Array = U.castSTUArray+  -- --------------------------------------------------------------------------- -- Utils

@@ -476,13 +476,15 @@ ghcInternalFunctions = do     platform <- getPlatform     let w = llvmWord platform+        cint = LMInt $ widthInBits $ cIntWidth platform+    mk "memcmp" cint [i8Ptr, i8Ptr, w]     mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]     mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]     mk "memset" i8Ptr [i8Ptr, w, w]     mk "newSpark" w [i8Ptr, i8Ptr]   where     mk n ret args = do-      let n' = llvmDefLabel $ fsLit n+      let n' = fsLit n           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret                                  FixedArgs (tysToParams args) Nothing       renderLlvm $ ppLlvmFunctionDecl decl@@ -516,7 +518,10 @@   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing   case m_ty of     -- Directly reference if we have seen it already-    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global+    Just ty -> do+      if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])+        then return $ mkGlbVar (llvmLbl) ty Global+        else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global     -- Otherwise use a forward alias of it     Nothing -> do       saveAlias llvmLbl

@@ -319,7 +319,7 @@     -- See Note [CPR for thunks]     stays_thunk = is_thunk && not_strict     is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)-    not_strict  = not (isStrictDmd (idDemandInfo id))+    not_strict  = not (isStrUsedDmd (idDemandInfo id))     -- See Note [CPR for sum types]     (_, ret_ty) = splitPiTys (idType id)     not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)

@@ -44,6 +44,8 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set +-- import GHC.Driver.Ppr+ {- ************************************************************************ *                                                                      *@@ -76,12 +78,12 @@   = ( extendAnalEnv TopLevel env id sig     , NonRec (setIdStrictness id sig) rhs')   where-    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs+    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs  dmdAnalTopBind env (Rec pairs)   = (env', Rec pairs')   where-    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs+    (env', _, pairs')  = dmdFix TopLevel env topSubDmd pairs                 -- We get two iterations automatically                 -- c.f. the NonRec case above @@ -143,21 +145,20 @@ dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*             -> CoreExpr -- Should obey the let/app invariant-            -> (BothDmdArg, CoreExpr)-dmdAnalStar env dmd e-  | (dmd_shell, cd) <- toCleanDmd dmd-  , (dmd_ty, e')    <- dmdAnal env cd e+            -> (PlusDmdArg, CoreExpr)+dmdAnalStar env (n :* cd) e+  | (dmd_ty, e')    <- dmdAnal env cd e   = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )     -- The argument 'e' should satisfy the let/app invariant     -- See Note [Analysing with absent demand] in GHC.Types.Demand-    (postProcessDmdType dmd_shell dmd_ty, e')+    (toPlusDmdArg $ multDmdType n dmd_ty, e')  -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv-        -> CleanDemand         -- The main one takes a *CleanDemand*+        -> SubDemand         -- The main one takes a *SubDemand*         -> CoreExpr -> (DmdType, CoreExpr) --- The CleanDemand is always strict and not absent+-- The SubDemand is always strict and not absent --    See Note [Ensure demand is strict]  dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $@@ -172,7 +173,7 @@   = (dmdTransform env var dmd, Var var)  dmdAnal' env dmd (Cast e co)-  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)+  = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)   where     (dmd_ty, e') = dmdAnal env dmd e @@ -206,7 +207,7 @@ --         , text "arg dmd_ty =" <+> ppr arg_ty --         , text "res dmd_ty =" <+> ppr res_ty --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])-    (res_ty `bothDmdType` arg_ty, App fun' arg')+    (res_ty `plusDmdType` arg_ty, App fun' arg')  dmdAnal' env dmd (Lam var body)   | isTyVar var@@ -216,23 +217,35 @@     (body_ty, Lam var body')    | otherwise-  = let (body_dmd, defer_and_use) = peelCallDmd dmd+  = let (n, body_dmd)    = peelCallDmd dmd           -- body_dmd: a demand to analyze the body          (body_ty, body') = dmdAnal env body_dmd body         (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var     in-    (postProcessUnsat defer_and_use lam_ty, Lam var' body')+    (multDmdType n lam_ty, Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])-  -- Only one alternative with a product constructor-  | let tycon = dataConTyCon dc-  , isJust (isDataProductTyCon_maybe tycon)+dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)])+  -- Only one alternative.+  -- If it's a DataAlt, it should be a product constructor.+  | is_non_sum_alt alt   = let         (rhs_ty, rhs')           = dmdAnal env dmd rhs         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs         (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr-        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds+        -- Evaluation cardinality on the case binder is irrelevant and a no-op.+        -- What matters is its nested sub-demand!+        (_ :* case_bndr_sd)      = case_bndr_dmd+        -- Compute demand on the scrutinee+        (bndrs', scrut_sd)+          | DataAlt _ <- alt+          , id_dmds <- addCaseBndrDmd case_bndr_sd dmds+          -- See Note [Demand on scrutinee of a product case]+          = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds)+          | otherwise+          -- __DEFAULT and literal alts. Simply add demands and discard the+          -- evaluation cardinality, as we evaluate the scrutinee exactly once.+          = ASSERT( null bndrs ) (bndrs, case_bndr_sd)         fam_envs                 = ae_fam_envs env         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"@@ -241,28 +254,26 @@           | otherwise           = alt_ty2 -        -- Compute demand on the scrutinee-        -- See Note [Demand on scrutinee of a product case]-        scrut_dmd          = mkProdDmd id_dmds-        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut-        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty+        (scrut_ty, scrut') = dmdAnal env scrut_sd scrut+        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty         case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd-        bndrs'             = setBndrsDemandInfo bndrs id_dmds     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd --                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')---                                   , text "id_dmds" <+> ppr id_dmds---                                   , text "scrut_dmd" <+> ppr scrut_dmd+--                                   , text "scrut_sd" <+> ppr scrut_sd --                                   , text "scrut_ty" <+> ppr scrut_ty --                                   , text "alt_ty" <+> ppr alt_ty2 --                                   , text "res_ty" <+> ppr res_ty ]) $-    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])+    (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')])+    where+      is_non_sum_alt (DataAlt dc) = isJust $ isDataProductTyCon_maybe $ dataConTyCon dc+      is_non_sum_alt _            = True  dmdAnal' env dmd (Case scrut case_bndr ty alts)   = let      -- Case expression with multiple alternatives-        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts-        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut+        (alt_tys, alts')     = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts+        (scrut_ty, scrut')   = dmdAnal env topSubDmd scrut         (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr                                -- NB: Base case is botDmdType, for empty case alternatives                                --     This is a unit for lubDmdType, and the right result@@ -274,7 +285,7 @@           = deferAfterPreciseException alt_ty           | otherwise           = alt_ty-        res_ty               = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty+        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty      in --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut@@ -304,7 +315,7 @@     id'                = setIdDemandInfo id id_dmd      (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs-    final_ty           = body_ty' `bothDmdType` rhs_ty+    final_ty           = body_ty' `plusDmdType` rhs_ty  dmdAnal' env dmd (Let (NonRec id rhs) body)   = (body_ty2, Let (NonRec id2 rhs') body')@@ -373,21 +384,77 @@   | otherwise   = False -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)-dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)-  | null bndrs    -- Literals, DEFAULT, and nullary constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs-  = (rhs_ty, (con, [], rhs'))--  | otherwise     -- Non-nullary data constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalSumAlt env dmd case_bndr (con,bndrs,rhs)+  | (rhs_ty, rhs') <- dmdAnal env dmd rhs   , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs-  , let case_bndr_dmd = findIdDemand alt_ty case_bndr-        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds+  , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr+        -- See Note [Demand on scrutinee of a product case]+        id_dmds             = addCaseBndrDmd case_bndr_sd dmds   = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) -{- Note [Which scrutinees may throw precise exceptions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{-+Note [Analysing with absent demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we analyse an expression with demand A.  The "A" means+"absent", so this expression will never be needed.  What should happen?+There are several wrinkles:++* We *do* want to analyse the expression regardless.+  Reason: Note [Always analyse in virgin pass]++  But we can post-process the results to ignore all the usage+  demands coming back. This is done by multDmdType.++* In a previous incarnation of GHC we needed to be extra careful in the+  case of an *unlifted type*, because unlifted values are evaluated+  even if they are not used.  Example (see #9254):+     f :: (() -> (# Int#, () #)) -> ()+          -- Strictness signature is+          --    <CS(S(A,SU))>+          -- I.e. calls k, but discards first component of result+     f k = case k () of (# _, r #) -> r++     g :: Int -> ()+     g y = f (\n -> (# case y of I# y2 -> y2, n #))++  Here f's strictness signature says (correctly) that it calls its+  argument function and ignores the first component of its result.+  This is correct in the sense that it'd be fine to (say) modify the+  function so that always returned 0# in the first component.++  But in function g, we *will* evaluate the 'case y of ...', because+  it has type Int#.  So 'y' will be evaluated.  So we must record this+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that+  'y' is bound to an aBSENT_ERROR thunk.++  However, the argument of toSubDmd always satisfies the let/app+  invariant; so if it is unlifted it is also okForSpeculation, and so+  can be evaluated in a short finite time -- and that rules out nasty+  cases like the one above.  (I'm not quite sure why this was a+  problem in an earlier version of GHC, but it isn't now.)++Note [Always analyse in virgin pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tricky point: make sure that we analyse in the 'virgin' pass. Consider+   rec { f acc x True  = f (...rec { g y = ...g... }...)+         f acc x False = acc }+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.+That might mean that we analyse the sub-expression containing the+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*+E, but just returned botType.++Then in the *next* (non-virgin) iteration for 'f', we might analyse E+in a weaker demand, and that will trigger doing a fixpoint iteration+for g.  But *because it's not the virgin pass* we won't start g's+iteration at bottom.  Disaster.  (This happened in $sfibToList' of+nofib/spectral/fibheaps.)++So in the virgin pass we make sure that we do analyse the expression+at least once, to initialise its signatures.++Note [Which scrutinees may throw precise exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is the specification of 'exprMayThrowPreciseExceptions', which is important for Scenario 2 of Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.@@ -438,6 +505,9 @@  Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+FIXME: This Note should be named [LetUp vs. LetDown] and probably predates+said separation. SG+ We use different strategies for strictness and usage/cardinality to "unleash" demands captured on free variables by bindings. Let us consider the example:@@ -484,13 +554,14 @@ ************************************************************************ -} -dmdTransform :: AnalEnv         -- The strictness environment-             -> Id              -- The function-             -> CleanDemand     -- The demand on the function-             -> DmdType         -- The demand type of the function in this context-        -- Returned DmdEnv includes the demand on-        -- this function plus demand on its free variables+dmdTransform :: AnalEnv         -- ^ The strictness environment+             -> Id              -- ^ The function+             -> SubDemand       -- ^ The demand on the function+             -> DmdType         -- ^ The demand type of the function in this context+                                -- Returned DmdEnv includes the demand on+                                -- this function plus demand on its free variables +-- See Note [What are demand signatures?] in "GHC.Types.Demand" dmdTransform env var dmd   -- Data constructors   | isDataConWorkId var@@ -499,7 +570,8 @@   -- Used to be controlled by a flag.   -- See #18429 for some perf measurements.   | Just _ <- isClassOpId_maybe var-  = dmdTransformDictSelSig (idStrictness var) dmd+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $+    dmdTransformDictSelSig (idStrictness var) dmd   -- Imported functions   | isGlobalId var   , let res = dmdTransformSig (idStrictness var) dmd@@ -512,14 +584,14 @@   = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $     if isTopLevel top_lvl     then fn_ty   -- Don't record demand on top-level things-    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)+    else addVarDmd fn_ty var (C_11 :* dmd)   -- Everything else:   --   * Local let binders for which we use LetUp (cf. 'useLetUp')   --   * Lambda binders   --   * Case and constructor field binders   | otherwise   = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $-    unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))+    unitDmdType (unitVarEnv var (C_11 :* dmd))  {- ********************************************************************* *                                                                      *@@ -541,14 +613,15 @@ -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. dmdAnalRhsLetDown   :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive-  -> AnalEnv -> CleanDemand+  -> AnalEnv -> SubDemand   -> Id -> CoreExpr   -> (DmdEnv, StrictSig, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsLetDown rec_flag env let_dmd id rhs-  = (lazy_fv, sig, rhs')+  = -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $+    (lazy_fv, sig, rhs')   where     rhs_arity = idArity id     rhs_dmd -- See Note [Demand analysis for join points]@@ -567,32 +640,41 @@     sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)      -- See Note [Aggregated demand for cardinality]+    -- FIXME: That Note doesn't explain the following lines at all. The reason+    --        is really much different: When we have a recursive function, we'd+    --        have to also consider the free vars of the strictness signature+    --        when checking whether we found a fixed-point. That is expensive;+    --        we only want to check whether argument demands of the sig changed.+    --        reuseEnv makes it so that the FV results are stable as long as the+    --        last argument demands were. Strictness won't change. But used-once+    --        might turn into used-many even if the signature was stable and+    --        we'd have to do an additional iteration. reuseEnv makes sure that+    --        we never get used-once info for FVs of recursive functions.     rhs_fv1 = case rec_flag of                 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)                 Nothing -> rhs_fv      rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs--    -- See Note [Lazy and unleashable free variables]-    (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2-     -- Find the RHS free vars of the unfoldings and RULES     -- See Note [Absence analysis for stable unfoldings and RULES]     extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $                 idCoreRules id +    -- See Note [Lazy and unleashable free variables]+    (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2+     unf = realIdUnfolding id     unf_fvs | isStableUnfolding unf             , Just unf_body <- maybeUnfoldingTemplate unf             = exprFreeIds unf_body             | otherwise = emptyVarSet --- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for+-- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for -- unleashing on the given function's @rhs@, by creating -- a call demand of @rhs_arity@ -- See Historical Note [Product demands for function body]-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand+mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd  -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs@@ -694,12 +776,14 @@ is /at least/ the number of manifest lambdas, but might be higher for PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). -Because idArity of a function varies independently of its cardinality properties-(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode-the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'-(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to-unleash a demand signature when the incoming number of arguments is less than-that. See Note [What are demand signatures?] for more details on soundness.+Because idArity of a function varies independently of its cardinality+properties (cf. Note [idArity varies independently of dmdTypeDepth]), we+implicitly encode the arity for when a demand signature is sound to unleash+in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in+GHC.Types.Demand). It is unsound to unleash a demand signature when the+incoming number of arguments is less than that.+See Note [What are demand signatures?] in GHC.Types.Demand for more details+on soundness.  Why idArity arguments? Because that's a conservative estimate of how many arguments we must feed a function before it does anything interesting with them.@@ -759,57 +843,6 @@ With the CoreLint check, we would have to zap `go`'s perfectly viable strictness signature. -Note [What are demand signatures?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand analysis interprets expressions in the abstract domain of demand-transformers. Given an incoming demand we put an expression under, its abstract-transformer gives us back a demand type denoting how other things (like-arguments and free vars) were used when the expression was evaluated.-Here's an example:--  f x y =-    if x + expensive-      then \z -> z + y * ...-      else \z -> z * ...--The abstract transformer (let's call it F_e) of the if expression (let's call it-e) would transform an incoming head demand <S,HU> into a demand type like-{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:--     Demand ---F_e---> DmdType-     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>--Let's assume that the demand transformers we compute for an expression are-correct wrt. to some concrete semantics for Core. How do demand signatures fit-in? They are strange beasts, given that they come with strict rules when to-it's sound to unleash them.--Fortunately, we can formalise the rules with Galois connections. Consider-f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of-the actual abstract transformer of f's RHS for arity 2. So, what happens is that-we abstract *once more* from the abstract domain we already are in, replacing-the incoming Demand by a simple lattice with two elements denoting incoming-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom-element). Here's the diagram:--     A_2 -----f_f----> DmdType-      ^                   |-      | α               γ |-      |                   v-     Demand ---F_f---> DmdType--With-  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness-  α(_)         =  <2-  γ(ty)        =  ty-and F_f being the abstract transformer of f's RHS and f_f being the abstracted-abstract transformer computable from our demand signature simply by--  f_f(>=2) = {}<S,1*U><L,U>-  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>--where postProcessUnsat makes a proper top element out of the given demand type.- Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -899,7 +932,7 @@ -- Recursive bindings dmdFix :: TopLevelFlag        -> AnalEnv                            -- Does not include bindings for this binding-       -> CleanDemand+       -> SubDemand        -> [(Id,CoreExpr)]        -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info @@ -954,10 +987,11 @@                 -- so this can significantly reduce the number of iterations needed          my_downRhs (env, lazy_fv) (id,rhs)-          = ((env', lazy_fv'), (id', rhs'))+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $+            ((env', lazy_fv'), (id', rhs'))           where             (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1+            lazy_fv'              = plusVarEnv_C plusDmd lazy_fv lazy_fv1             env'                  = extendAnalEnv top_lvl env id sig             id'                   = setIdStrictness id sig @@ -1043,11 +1077,11 @@  addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res+  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res  addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs+  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs         -- Using bothDmdType (rather than just both'ing the envs)         -- is vital.  Consider         --      let f = \x -> (x,y)@@ -1109,13 +1143,13 @@ -- For lambdas we add the demand to the argument demands -- Only called for Ids   = ASSERT( isId id )-    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $     (final_ty, setIdDemandInfo id dmd)   where       -- Watch out!  See note [Lambda-bound unfoldings]     final_ty = case maybeUnfoldingTemplate (idUnfolding id) of                  Nothing  -> main_ty-                 Just unf -> main_ty `bothDmdType` unf_ty+                 Just unf -> main_ty `plusDmdType` unf_ty                           where                              (unf_ty, _) = dmdAnalStar env dmd unf @@ -1314,7 +1348,8 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) -- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id-  = (dmd_ty', dmd')+  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $+    (dmd_ty', dmd')   where     dmd' = strictify $            trimToType starting_dmd (findTypeShape fam_envs id_ty)

@@ -16,6 +16,7 @@ import GHC.Driver.Ppr import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env+import GHC.Platform.Ways  ( hasWay, Way(WayProf) )  import GHC.Core import GHC.Core.Opt.CSE  ( cseProgram )@@ -44,6 +45,7 @@ import GHC.Core.Opt.CallArity    ( callArityAnalProgram ) import GHC.Core.Opt.Exitify      ( exitifyProgram ) import GHC.Core.Opt.WorkWrap     ( wwTopBinds )+import GHC.Core.Opt.CallerCC     ( addCallerCostCentres ) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -58,7 +60,6 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.Deps -import GHC.Runtime.Loader -- ( initializePlugins ) import GHC.Runtime.Context  import GHC.Types.SrcLoc@@ -67,7 +68,6 @@ import GHC.Types.Basic import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Types.Demand import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr@@ -87,18 +87,14 @@                                 , mg_loc     = loc                                 , mg_deps    = deps                                 , mg_rdr_env = rdr_env })-  = do { -- make sure all plugins are loaded--       ; let builtin_passes = getCoreToDo dflags+  = do { let builtin_passes = getCoreToDo dflags              orph_mods = mkModuleSet (mod : dep_orphs deps)              uniq_mask = 's'        ;        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod                                     orph_mods print_unqual loc $                            do { hsc_env' <- getHscEnv-                              ; dflags' <- liftIO $ initializePlugins hsc_env'-                                                      (hsc_dflags hsc_env')-                              ; all_passes <- withPlugins dflags'+                              ; all_passes <- withPlugins hsc_env'                                                 installCoreToDos                                                 builtin_passes                               ; runCorePasses all_passes guts }@@ -156,6 +152,7 @@     pre_inline_on = gopt Opt_SimplPreInlining             dflags     ww_on         = gopt Opt_WorkerWrapper                dflags     static_ptrs   = xopt LangExt.StaticPointers           dflags+    profiling     = ways dflags `hasWay` WayProf      maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) @@ -222,12 +219,16 @@           }         ] +    add_caller_ccs =+        runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs+     core_todo =      if opt_level == 0 then        [ static_ptrs_float_outwards,          CoreDoSimplify max_iter              (base_mode { sm_phase = FinalPhase                         , sm_names = ["Non-opt simplification"] })+       , add_caller_ccs        ]       else {- opt_level >= 1 -} [@@ -371,7 +372,9 @@         -- can become /exponentially/ more expensive. See #11731, #12996.         runWhen (strictness || late_dmd_anal) CoreDoDemand, -        maybe_rule_check FinalPhase+        maybe_rule_check FinalPhase,++        add_caller_ccs      ]      -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -510,6 +513,9 @@ doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}                                        specConstrProgram +doCorePass CoreAddCallerCcs          = {-# SCC "AddCallerCcs" #-}+                                       addCallerCostCentres+ doCorePass CoreDoPrintCore              = observe   printCore doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat doCorePass CoreDoNothing                = return@@ -1096,6 +1102,6 @@                }       binds_plus_dmds = dmdAnalProgram opts fam_envs binds   Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds+    dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_dmds `seq` return binds_plus_dmds

@@ -103,7 +103,7 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig )+import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString )@@ -469,7 +469,7 @@     lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)     lvl_arg strs arg | (str1 : strs') <- strs                      , is_val_arg arg-                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg+                     = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg                           ; return (strs', arg') }                      | otherwise                      = do { arg' <- lvlMFE env False arg

@@ -41,15 +41,15 @@ import GHC.Core import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd-                        , mkClosedStrictSig, topDmd, seqDmd, botDiv )+import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd+                        , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv ) import GHC.Types.Cpr    ( mkCprSig, botCpr ) import GHC.Core.Ppr     ( pprCoreExpr ) import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType+import GHC.Core.Opt.Arity ( ArityType(..)                           , pushCoTyArg, pushCoValArg                           , idArityType, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )@@ -796,8 +796,8 @@ addLetBndrInfo new_bndr new_arity_type new_unf   = new_bndr `setIdInfo` info5   where-    new_arity = arityTypeArity new_arity_type-    is_bot    = isBotArityType new_arity_type+    AT oss div = new_arity_type+    new_arity  = length oss      info1 = idInfo new_bndr `setArityInfo` new_arity @@ -816,11 +816,11 @@           = info2      -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | is_bot    = info3 `setStrictnessInfo` bot_sig-                              `setCprInfo`        bot_cpr-          | otherwise = info3+    info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig+                                     `setCprInfo`        bot_cpr+          | otherwise        = info3 -    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv+    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div     bot_cpr = mkCprSig new_arity botCpr       -- Zap call arity info. We have used it by now (via@@ -2481,7 +2481,7 @@      scrut_is_demanded_var :: CoreExpr -> Bool     scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)     scrut_is_demanded_var _          = False    This only fired if the scrutinee was a /variable/, which seems@@ -2709,7 +2709,7 @@    | otherwise  -- Scrut has a lifted type   = exprIsHNF scrut-    || isStrictDmd (idDemandInfo case_bndr)+    || isStrUsedDmd (idDemandInfo case_bndr)     -- See Note [Case-to-let for strictly-used binders]  --------------------------------------------------

@@ -329,7 +329,7 @@ isStrictArgInfo :: ArgInfo -> Bool -- True if the function is strict in the next argument isStrictArgInfo (ArgInfo { ai_dmds = dmds })-  | dmd:_ <- dmds = isStrictDmd dmd+  | dmd:_ <- dmds = isStrUsedDmd dmd   | otherwise     = False  argInfoAppArgs :: [ArgSpec] -> [OutExpr]@@ -576,13 +576,13 @@     add_type_strictness fun_ty dmds       | null dmds = [] -      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+      | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty       = add_type_strictness fun_ty' dmds     -- Look through foralls        | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds       , let dmd' = case isLiftedType_maybe arg_ty of-                       Just False -> strictenDmd dmd+                       Just False -> strictifyDmd dmd                        _          -> dmd       = dmd' : add_type_strictness fun_ty' rest_dmds           -- If the type is levity-polymorphic, we can't know whether it's@@ -1662,8 +1662,8 @@   | Just join_arity <- isJoinId_maybe bndr   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs              oss   = [idOneShotInfo id | id <- join_bndrs, isId id]-             arity_type | exprIsDeadEnd join_body = ABot (length oss)-                        | otherwise               = ATop oss+             arity_type | exprIsDeadEnd join_body = mkBotArityType oss+                        | otherwise               = mkTopArityType oss        ; return (arity_type, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because

@@ -971,7 +971,7 @@ --------------------------------------------------- -- See Note [Forcing specialisation] forceSpecBndr :: ScEnv -> Var    -> Bool-forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var+forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var  forceSpecFunTy :: ScEnv -> Type -> Bool forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys@@ -1724,11 +1724,12 @@     go env _      _                = env      go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d-    go_one env d e-           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict-           , (Var _, args) <- collectArgs e = go env ds args-    go_one env _         _ = env+    go_one env d          (Var v) = extendVarEnv_C plusDmd env v d+    go_one env (_n :* cd) e -- NB: _n does not have to be strict+      | (Var _, args) <- collectArgs e+      , Just ds <- viewProd (length args) cd+      = go env ds args+    go_one env _               _       = env  {- Note [spec_usg includes rhs_usg]

@@ -434,7 +434,7 @@                   apply_or_bind_then work_fn_args (varToCoreExpr id),                   res_ty) } -  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty+  | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty   = do  { uniq <- getUniqueM         ; let (subst', tv') = cloneTyVarBndr subst tv uniq                 -- See Note [Freshen WW arguments]@@ -610,7 +610,7 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd =   case deepSplitProductType_maybe fam_envs ty of     Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys }-      | isStrictDmd dmd+      | isStrUsedDmd dmd       -- See Note [Unpacking arguments with product and polymorphic demands]       , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)       -- See Note [Do not unpack class dictionaries]@@ -621,12 +621,11 @@     _ -> Nothing   where     split_prod_dmd_arity dmd arty-      -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would-      -- it know the arity?), but it should behave like <S, U(AAAA)>, for some+      -- For seqDmd, it should behave like <S(AAAA)>, for some       -- suitable arity-      | isSeqDmd dmd = Just (replicate arty absDmd)-      -- Otherwise splitProdDmd_maybe does the job-      | otherwise    = splitProdDmd_maybe dmd+      | isSeqDmd dmd        = Just (replicate arty absDmd)+      | _ :* Prod ds <- dmd = Just ds+      | otherwise           = Nothing  unbox_one :: DynFlags -> FamInstEnvs -> Var           -> [Demand]@@ -1026,7 +1025,7 @@        | Just (tc, tc_args)  <- splitTyConApp_maybe ty        = go_tc rec_tc tc tc_args -       | Just (_, ty') <- splitForAllTy_maybe ty+       | Just (_, ty') <- splitForAllTyCoVar_maybe ty        = go rec_tc ty'         | otherwise

@@ -403,7 +403,7 @@          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))           -- make the arg bitmap-         bits = argBits platform (reverse (map bcIdArgRep all_args))+         bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))          bitmap_size = genericLength bits          bitmap = mkBitmap platform bits      body_code <- schemeER_wrk sum_szsb_args p_init body@@ -508,13 +508,17 @@ -- Delegate tail-calls to schemeT. schemeE d s p e@(AnnApp _ _) = schemeT d s p e -schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))+schemeE d s p e@(AnnLit lit)     = do+    platform <- profilePlatform <$> getProfile+    returnUnboxedAtom d s p e (typeArgRep platform (literalType lit)) schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V  schemeE d s p e@(AnnVar v)       -- See Note [Not-necessarily-lifted join points], step 3.     | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]-    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)+    | isUnliftedType (idType v) = do+        platform <- profilePlatform <$> getProfile+        returnUnboxedAtom d s p e (bcIdArgRep platform v)     | otherwise                 = schemeT d s p e  schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))@@ -830,18 +834,19 @@    -- Case 2: Constructor application    | Just con <- maybe_saturated_dcon    , isUnboxedTupleDataCon con-   = case args_r_to_l of-        [arg1,arg2] | isVAtom arg1 ->+   = do+     platform <- profilePlatform <$> getProfile+     case args_r_to_l of+        [arg1,arg2] | isVAtom platform arg1 ->                   unboxedTupleReturn d s p arg2-        [arg1,arg2] | isVAtom arg2 ->+        [arg1,arg2] | isVAtom platform arg2 ->                   unboxedTupleReturn d s p arg1         _other -> multiValException     -- Case 3: Ordinary data constructor    | Just con <- maybe_saturated_dcon    = do alloc_con <- mkConAppCode d s p con args_r_to_l-        dflags <- getDynFlags-        let platform = targetPlatform dflags+        platform <- profilePlatform <$> getProfile         return (alloc_con         `appOL`                 mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`                 ENTER)@@ -922,7 +927,9 @@  unboxedTupleReturn     :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)+unboxedTupleReturn d s p arg = do+   platform <- profilePlatform <$> getProfile+   returnUnboxedAtom d s p arg (atomRep platform arg)  -- ----------------------------------------------------------------------------- -- Generate code for a tail-call@@ -934,13 +941,14 @@     -> Id     -> [AnnExpr' Id DVarSet]     -> BcM BCInstrList-doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)+doTailCall init_d s p fn args = do+   platform <- profilePlatform <$> getProfile+   do_pushes init_d args (map (atomRep platform) args)   where   do_pushes !d [] reps = do         ASSERT( null reps ) return ()         (push_fn, sz) <- pushAtom d p (AnnVar fn)-        dflags <- getDynFlags-        let platform = targetPlatform dflags+        platform <- profilePlatform <$> getProfile         ASSERT( sz == wordSize platform ) return ()         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)         return (push_fn `appOL` (slide `appOL` unitOL ENTER))@@ -948,8 +956,7 @@       let (push_apply, n, rest_of_reps) = findPushSeq reps           (these_args, rest_of_args) = splitAt n args       (next_d, push_code) <- push_seq d these_args-      dflags <- getDynFlags-      let platform = targetPlatform dflags+      platform <- profilePlatform <$> getProfile       instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps       --                          ^^^ for the PUSH_APPLY_ instruction       return (push_code `appOL` (push_apply `consOL` instrs))@@ -1137,8 +1144,8 @@           -- NB: unboxed tuple cases bind the scrut binder to the same offset           -- as one of the alt binders, so we have to remove any duplicates here:           rel_slots = nub $ map fromIntegral $ concatMap spread binds-          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]-                              | otherwise                      = []+          spread (id, offset) | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]+                              | otherwise                                = []                 where rel_offset = trunc16W $ bytesToWords platform (d - offset)       alt_stuff <- mapM codeAlt alts@@ -1157,7 +1164,7 @@      alt_bco' <- emitBc alt_bco      let push_alts             | isAlgCase = PUSH_ALTS alt_bco'-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)      return (push_alts `consOL` scrut_code)  @@ -1374,7 +1381,7 @@          -- slide and return          d_after_r_min_s = bytesToWords platform (d_after_r - s)          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)-                        `snocOL` RETURN_UBX (toArgRep r_rep)+                        `snocOL` RETURN_UBX (toArgRep platform r_rep)          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $      return (          push_args `appOL`@@ -1387,6 +1394,12 @@      VoidRep     -> FFIVoid      IntRep      -> signed_word      WordRep     -> unsigned_word+     Int8Rep     -> FFISInt8+     Word8Rep    -> FFIUInt8+     Int16Rep    -> FFISInt16+     Word16Rep   -> FFIUInt16+     Int32Rep    -> FFISInt32+     Word32Rep   -> FFIUInt32      Int64Rep    -> FFISInt64      Word64Rep   -> FFIUInt64      AddrRep     -> FFIPointer@@ -1405,6 +1418,12 @@    = case pr of         IntRep    -> mkLitInt  platform 0         WordRep   -> mkLitWord platform 0+        Int8Rep   -> mkLitInt8 0+        Word8Rep  -> mkLitWord8 0+        Int16Rep  -> mkLitInt16 0+        Word16Rep -> mkLitWord16 0+        Int32Rep  -> mkLitInt32 0+        Word32Rep -> mkLitWord32 0         Int64Rep  -> mkLitInt64 0         Word64Rep -> mkLitWord64 0         AddrRep   -> LitNullAddr@@ -1621,24 +1640,39 @@  pushAtom _ _ (AnnLit lit) = do      platform <- targetPlatform <$> getDynFlags-     let code rep-             = let size_words = WordOff (argRepSizeW platform rep)-               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),-                           wordsToBytes platform size_words)+     let code :: PrimRep -> BcM (BCInstrList, ByteOff)+         code rep =+            return (unitOL instr, size_bytes)+          where+            size_bytes = ByteOff $ primRepSizeB platform rep+            -- Here we handle the non-word-width cases specifically since we+            -- must emit different bytecode for them.+            instr =+              case size_bytes of+                1  -> PUSH_UBX8 lit+                2  -> PUSH_UBX16 lit+                4  -> PUSH_UBX32 lit+                _  -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)       case lit of-        LitLabel _ _ _  -> code N-        LitFloat _      -> code F-        LitDouble _     -> code D-        LitChar _       -> code N-        LitNullAddr     -> code N-        LitString _     -> code N-        LitRubbish      -> code N+        LitLabel _ _ _  -> code AddrRep+        LitFloat _      -> code FloatRep+        LitDouble _     -> code DoubleRep+        LitChar _       -> code WordRep+        LitNullAddr     -> code AddrRep+        LitString _     -> code AddrRep+        LitRubbish      -> code WordRep         LitNumber nt _  -> case nt of-          LitNumInt     -> code N-          LitNumWord    -> code N-          LitNumInt64   -> code L-          LitNumWord64  -> code L+          LitNumInt     -> code IntRep+          LitNumWord    -> code WordRep+          LitNumInt8    -> code Int8Rep+          LitNumWord8   -> code Word8Rep+          LitNumInt16   -> code Int16Rep+          LitNumWord16  -> code Word16Rep+          LitNumInt32   -> code Int32Rep+          LitNumWord32  -> code Word32Rep+          LitNumInt64   -> code Int64Rep+          LitNumWord64  -> code Word64Rep           -- No LitInteger's or LitNatural's should be left by the time this is           -- called. CorePrep should have converted them all to a real core           -- representation.@@ -1827,13 +1861,13 @@ lookupBCEnv_maybe = Map.lookup  idSizeW :: Platform -> Id -> WordOff-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform  idSizeCon :: Platform -> Id -> ByteOff idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep -bcIdArgRep :: Id -> ArgRep-bcIdArgRep = toArgRep . bcIdPrimRep+bcIdArgRep :: Platform -> Id -> ArgRep+bcIdArgRep platform = toArgRep platform . bcIdPrimRep  bcIdPrimRep :: Id -> PrimRep bcIdPrimRep id@@ -1843,7 +1877,7 @@   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))  repSizeWords :: Platform -> PrimRep -> WordOff-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)  isFollowableArg :: ArgRep -> Bool isFollowableArg P = True@@ -1930,11 +1964,12 @@       Nothing -> e       Just e' -> bcViewLoop e' -isVAtom :: AnnExpr' Var ann -> Bool-isVAtom e | Just e' <- bcView e = isVAtom e'-isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)-isVAtom (AnnCoercion {})        = True-isVAtom _                     = False+isVAtom :: Platform -> AnnExpr' Var ann -> Bool+isVAtom platform expr = case expr of+   e | Just e' <- bcView e -> isVAtom platform e'+   (AnnVar v)              -> isVoidArg (bcIdArgRep platform v)+   (AnnCoercion {})        -> True+   _                       -> False  atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e'@@ -1949,8 +1984,8 @@ atomPrimRep (AnnCoercion {})        = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) -atomRep :: AnnExpr' Id ann -> ArgRep-atomRep e = toArgRep (atomPrimRep e)+atomRep :: Platform -> AnnExpr' Id ann -> ArgRep+atomRep platform e = toArgRep platform (atomPrimRep e)  -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth@.  Return the values which the stack@@ -1958,8 +1993,8 @@ mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgRep :: Type -> ArgRep-typeArgRep = toArgRep . typePrimRep1+typeArgRep :: Platform -> Type -> ArgRep+typeArgRep platform = toArgRep platform . typePrimRep1  -- ----------------------------------------------------------------------------- -- The bytecode generator's monad

@@ -46,7 +46,7 @@ import GHC.Platform.Ways import GHC.Driver.Ppr import GHC.Types.ForeignCall-import GHC.Types.Demand    ( isUsedOnce )+import GHC.Types.Demand    ( isUsedOnceDmd ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc    ( mkGeneralSrcSpan ) import GHC.Builtin.Names   ( unsafeEqualityProofName )@@ -714,8 +714,8 @@   where     unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs -    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry-             | otherwise                      = Updatable+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                         = Updatable      -- CAF cost centres generated for -fcaf-all     caf_cc = mkAutoCC bndr modl@@ -756,8 +756,8 @@   where     unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs -    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry-             | otherwise                      = Updatable+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                         = Updatable    {-     SDM: disabled.  Eval/Apply can't handle functions with arity zero very

@@ -1359,7 +1359,7 @@                    -- See Note [Pin demand info on floats]   where     is_hnf    = exprIsHNF rhs-    is_strict = isStrictDmd dmd+    is_strict = isStrUsedDmd dmd  emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL@@ -1446,7 +1446,7 @@ wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec dmd is_unlifted floats rhs   =  isEmptyFloats floats-  || isStrictDmd dmd+  || isStrUsedDmd dmd   || is_unlifted   || (allLazyNested is_rec floats && exprIsHNF rhs)         -- Why the test for allLazyNested?

@@ -62,7 +62,7 @@ import GHC.Unit.Module.ModSummary (showModMsg) import GHC.Unit.Home.ModInfo -import GHC.Runtime.Linker.Types+import GHC.Linker.Types  import qualified GHC.LanguageExtensions as LangExt @@ -204,8 +204,11 @@         hiDir       = Just (outdir hiDir),         stubDir     = Just (outdir stubDir),         -- Unset output-file for non exe builds-        outputFile  = if session_type == ExeSession-                        then outputFile dflags+        outputFile_  = if session_type == ExeSession+                        then outputFile_ dflags+                        else Nothing,+        dynOutputFile_ = if session_type == ExeSession+                        then dynOutputFile_ dflags                         else Nothing,         -- Clear the import path so we don't accidentally grab anything         importPaths = [],

@@ -138,7 +138,13 @@       hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")       hPutStr h "#include \"Stg.h\"\n"       let platform = targetPlatform dflags-          writeC = printForC dflags h . cmmToC platform+          writeC cmm = do+            let doc = cmmToC platform cmm+            dumpIfSet_dyn dflags Opt_D_dump_c_backend+                          "C backend output"+                          FormatC+                          doc+            printForC dflags h doc       Stream.consume cmm_stream writeC  {-

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP                      #-} {-# LANGUAGE BangPatterns             #-} {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE LambdaCase               #-} {-# OPTIONS_GHC -fprof-auto-top #-}  -------------------------------------------------------------------------------@@ -97,13 +98,14 @@ import GHC.Driver.Hooks  import GHC.Runtime.Context-import GHC.Runtime.Linker-import GHC.Runtime.Linker.Types import GHC.Runtime.Interpreter ( addSptEntry ) import GHC.Runtime.Loader      ( initializePlugins ) import GHCi.RemoteTypes        ( ForeignHValue ) import GHC.ByteCode.Types +import GHC.Linker.Loader+import GHC.Linker.Types+ import GHC.Hs import GHC.Hs.Dump import GHC.Hs.Stats         ( ppSourceStats )@@ -238,19 +240,21 @@     us      <- mkSplitUniqSupply 'r'     nc_var  <- newIORef (initNameCache us knownKeyNames)     fc_var  <- newIORef emptyInstalledModuleEnv-    emptyDynLinker <- uninitializedLinker-    return HscEnv {  hsc_dflags       = dflags-                  ,  hsc_targets      = []-                  ,  hsc_mod_graph    = emptyMG-                  ,  hsc_IC           = emptyInteractiveContext dflags-                  ,  hsc_HPT          = emptyHomePackageTable-                  ,  hsc_EPS          = eps_var-                  ,  hsc_NC           = nc_var-                  ,  hsc_FC           = fc_var-                  ,  hsc_type_env_var = Nothing-                  ,  hsc_interp       = Nothing-                  ,  hsc_dynLinker    = emptyDynLinker-                  ,  hsc_home_unit    = home_unit+    emptyLoader <- uninitializedLoader+    return HscEnv {  hsc_dflags         = dflags+                  ,  hsc_targets        = []+                  ,  hsc_mod_graph      = emptyMG+                  ,  hsc_IC             = emptyInteractiveContext dflags+                  ,  hsc_HPT            = emptyHomePackageTable+                  ,  hsc_EPS            = eps_var+                  ,  hsc_NC             = nc_var+                  ,  hsc_FC             = fc_var+                  ,  hsc_type_env_var   = Nothing+                  ,  hsc_interp         = Nothing+                  ,  hsc_loader         = emptyLoader+                  ,  hsc_home_unit      = home_unit+                  ,  hsc_plugins        = []+                  ,  hsc_static_plugins = []                   }  -- -----------------------------------------------------------------------------@@ -452,7 +456,8 @@             -- apply parse transformation of plugins             let applyPluginAction p opts                   = parsedResultAction p opts mod_summary-            withPlugins dflags applyPluginAction res+            hsc_env <- getHscEnv+            withPlugins hsc_env applyPluginAction res   -- -----------------------------------------------------------------------------@@ -762,12 +767,11 @@                       -> SourceModified                       -> Maybe ModIface                       -> (Int,Int)-                      -> IO (HscStatus, DynFlags)+                      -> IO (HscStatus, HscEnv) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result     mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index   = do-    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')-    let hsc_env'' = hsc_env' { hsc_dflags = dflags }+    hsc_env'' <- initializePlugins hsc_env'      -- One-shot mode needs a knot-tying mutable variable for interface     -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.@@ -802,14 +806,14 @@                 -- any further typechecking.  It's much more useful                 -- in make mode, since this HMI will go into the HPT.                 genModDetails hsc_env' iface-            return (HscUpToDate iface details, dflags)+            return (HscUpToDate iface details, hsc_env')         -- We finished type checking.  (mb_old_hash is the hash of         -- the interface that existed on disk; it's possible we had         -- to retypecheck but the resulting interface is exactly         -- the same.)         Right (FrontendTypecheck tc_result, mb_old_hash) -> do             status <- finish mod_summary tc_result mb_old_hash-            return (status, dflags)+            return (status, hsc_env)  -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date@@ -865,8 +869,8 @@                              hscs_mod_location = ms_location summary,                              hscs_mod_details = details,                              hscs_partial_iface = partial_iface,-                             hscs_old_iface_hash = mb_old_hash,-                             hscs_iface_dflags = dflags }+                             hscs_old_iface_hash = mb_old_hash+                           }        -- We are not generating code, so we can skip simplification       -- and generate a simple interface.@@ -874,7 +878,7 @@         (iface, mb_old_iface_hash, details) <- liftIO $           hscSimpleIface hsc_env tc_result mb_old_hash -        liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)+        liftIO $ hscMaybeWriteIface dflags True iface mb_old_iface_hash (ms_location summary)          return $ case bcknd of           NoBackend -> HscNotGeneratingCode iface details@@ -887,28 +891,111 @@ Note [Writing interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using-hscMaybeWriteIface, but only once per compilation (twice with dynamic-too).+We write one interface file per module and per compilation, except with+-dynamic-too where we write two interface files (non-dynamic and dynamic). -* If a compilation does NOT require (re)compilation of the hard code we call-  hscMaybeWriteIface inside GHC.Driver.Main:finish.-* If we run in One Shot mode and target bytecode we write it in compileOne'-* Otherwise we must be compiling to regular hard code and require recompilation.-  In this case we create the interface file inside RunPhase using the interface-  generator contained inside the HscRecomp status.+We can write two kinds of interfaces (see Note [Interface file stages] in+"GHC.Driver.Types"):++   * simple interface: interface generated after the core pipeline++   * full interface: simple interface completed with information from the+     backend++Depending on the situation, we write one or the other (using+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the+backend is run twice, so if we write a simple interface we need to write both+the non-dynamic and the dynamic interfaces at the same time (with the same+contents).++Cases for which we generate simple interfaces:++   * GHC.Driver.Main.finish: when a compilation does NOT require (re)compilation+   of the hard code++   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target+   bytecode (if interface writing is forced).++   * GHC.Driver.Backpack uses simple interfaces for indefinite units+   (units with module holes). It writes them indirectly by forcing the+   -fwrite-interface flag while setting backend to NoBackend.++Cases for which we generate full interfaces:++   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard+   code and/or require recompilation.++By default interface file names are derived from module file names by adding+suffixes. The interface file name can be overloaded with "-ohi", except when+`-dynamic-too` is used.+ -}-hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()-hscMaybeWriteIface dflags iface old_iface location = do++-- | Write interface files+hscMaybeWriteIface :: DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()+hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do     let force_write_interface = gopt Opt_WriteInterface dflags         write_interface = case backend dflags of                             NoBackend    -> False                             Interpreter  -> False                             _            -> True-        no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) -    when (write_interface || force_write_interface) $-          hscWriteIface dflags iface no_change location+      -- mod_location only contains the base name, so we rebuild the+      -- correct file extension from the dynflags.+        baseName = ml_hi_file mod_location+        buildIfName suffix+          | Just name <- outputHi dflags+          = name+          | otherwise+          = let with_hi = replaceExtension baseName suffix+            in  addBootSuffix_maybe (mi_boot iface) with_hi +        write_iface dflags' iface =+          {-# SCC "writeIface" #-}+          writeIface dflags' (buildIfName (hiSuf dflags')) iface++    when (write_interface || force_write_interface) $ do++      -- FIXME: with -dynamic-too, "no_change" is only meaningful for the+      -- non-dynamic interface, not for the dynamic one. We should have another+      -- flag for the dynamic interface. In the meantime:+      --+      --    * when we write a single full interface, we check if we are+      --    currently writing the dynamic interface due to -dynamic-too, in+      --    which case we ignore "no_change".+      --+      --    * when we write two simple interfaces at once because of+      --    dynamic-too, we use "no_change" both for the non-dynamic and the+      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic+      --    interfaces stay in sync...+      --+      let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))++      dt <- dynamicTooState dflags++      when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags $+        hang (text "Writing interface(s):") 2 $ vcat+         [ text "Kind:" <+> if is_simple then text "simple" else text "full"+         , text "Hash change:" <+> ppr (not no_change)+         , text "DynamicToo state:" <+> text (show dt)+         ]++      if is_simple+         then unless no_change $ do -- FIXME: see no_change' comment above+            write_iface dflags iface+            case dt of+               DT_Dont   -> return ()+               DT_Failed -> return ()+               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"+               DT_OK     -> write_iface (setDynamicNow dflags) iface+         else case dt of+               DT_Dont | not no_change             -> write_iface dflags iface+               DT_OK   | not no_change             -> write_iface dflags iface+               -- FIXME: see no_change' comment above+               DT_Dyn                              -> write_iface dflags iface+               DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface+               _                                   -> return ()+ -------------------------------------------------------------- -- NoRecomp handlers --------------------------------------------------------------@@ -1339,16 +1426,22 @@ -- Simplifiers -------------------------------------------------------------- +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin'). hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts hscSimplify hsc_env plugins modguts =     runHsc hsc_env $ hscSimplify' plugins modguts +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin'). hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts hscSimplify' plugins ds_result = do     hsc_env <- getHscEnv-    let hsc_env_with_plugins = hsc_env-          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins-          }+    hsc_env_with_plugins <- if null plugins -- fast path+        then return hsc_env+        else liftIO $ initializePlugins $ hsc_env+                { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins+                }     {-# SCC "Core2Core" #-}       liftIO $ core2core hsc_env_with_plugins ds_result @@ -1383,52 +1476,7 @@ -------------------------------------------------------------- -- BackEnd combinators ---------------------------------------------------------------{--Note [Interface filename extensions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -ModLocation only contains the base names, however when generating dynamic files-the actual extension might differ from the default.--So we only load the base name from ModLocation and replace the actual extension-according to the information in DynFlags.--If we generate a interface file right after running the core pipeline we will-have set -dynamic-too and potentially generate both interface files at the same-time.--If we generate a interface file after running the backend then dynamic-too won't-be set, however then the extension will be contained in the dynflags instead so-things still work out fine.--}--hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()-hscWriteIface dflags iface no_change mod_location = do-    -- mod_location only contains the base name, so we rebuild the-    -- correct file extension from the dynflags.-    let ifaceBaseFile = ml_hi_file mod_location-    unless no_change $-        let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)-        in  {-# SCC "writeIface" #-}-            writeIface dflags ifaceFile iface-    whenGeneratingDynamicToo dflags $ do-        -- TODO: We should do a no_change check for the dynamic-        --       interface file too-        -- When we generate iface files after core-        let dynDflags = dynamicTooMkDynamicDynFlags dflags-            -- dynDflags will have set hiSuf correctly.-            dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)--        writeIface dynDflags dynIfaceFile iface-  where-    buildIfName :: String -> String -> String-    buildIfName baseName suffix-      | Just name <- outputHi dflags-      = name-      | otherwise-      = let with_hi = replaceExtension baseName suffix-        in  addBootSuffix_maybe (mi_boot iface) with_hi- -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath                -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)@@ -1713,7 +1761,7 @@    -- Desugar it   ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)   handleWarnings    -- Then code-gen, and link it@@ -1799,7 +1847,7 @@                                 prepd_binds data_tycons mod_breaks      let src_span = srcLocSpan interactiveSrcLoc-    liftIO $ linkDecls hsc_env src_span cbc+    liftIO $ loadDecls hsc_env src_span cbc      {- Load static pointer table entries -}     liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)@@ -1831,7 +1879,7 @@ hscAddSptEntries hsc_env entries = do     let add_spt_entry :: SptEntry -> IO ()         add_spt_entry (SptEntry i fpr) = do-            val <- getHValue hsc_env (idName i)+            val <- loadName hsc_env (idName i)             addSptEntry hsc_env fpr val     mapM_ add_spt_entry entries @@ -1955,14 +2003,14 @@          ; prepd_expr <- corePrepExpr hsc_env tidy_expr             {- Lint if necessary -}-         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr+         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr             {- Convert to BCOs -}          ; bcos <- coreExprToBCOs hsc_env                      (icInteractiveModule (hsc_IC hsc_env)) prepd_expr -           {- link it -}-         ; linkExpr hsc_env srcspan bcos }+           {- load it -}+         ; loadExpr hsc_env srcspan bcos }   {- **********************************************************************

@@ -36,9 +36,11 @@ import GHC.Prelude  import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck ) -import qualified GHC.Runtime.Linker as Linker-import GHC.Runtime.Linker.Types+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types+ import GHC.Runtime.Context  import GHC.Driver.Config@@ -53,9 +55,7 @@ import GHC.Parser.Header import GHC.Parser.Errors.Ppr -import GHC.Utils.Error import GHC.IfaceToCore     ( typecheckIface )-import GHC.Tc.Utils.Monad  ( initIfaceCheck )  import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag ) import GHC.Data.Graph.Directed@@ -63,13 +63,14 @@ import GHC.Data.Maybe      ( expectJust ) import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt-import GHC.SysTools.FileCleanup  import GHC.Utils.Exception ( tryIO ) import GHC.Utils.Monad     ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.SysTools.FileCleanup  import GHC.Types.Basic import GHC.Types.Target@@ -711,9 +712,9 @@                  "must specify -o explicitly"             else Just name'     in-    case outputFile dflags of+    case outputFile_ dflags of         Just _ -> env-        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }+        Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }  -- ----------------------------------------------------------------------------- --@@ -2299,8 +2300,8 @@           -- are written into `-odir` and `-hidir` respectively.  #16670           if gopt Opt_WriteInterface dflags             then return (ml_hi_file ms_location, ml_obj_file ms_location)-            else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))-                     <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags))+            else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                     <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))         return $           ms           { ms_location =

@@ -67,11 +67,11 @@     -- We therefore do the initial dependency generation with an empty     -- way and .o/.hi extensions, regardless of any flags that might     -- be specified.-    let dflags = dflags0 {-                     ways = Set.empty,-                     hiSuf = "hi",-                     objectSuf = "o"-                 }+    let dflags = dflags0+            { targetWays_ = Set.empty+            , hiSuf_      = "hi"+            , objectSuf_  = "o"+            }     GHC.setSessionDynFlags dflags      when (null (depSuffixes dflags)) $ liftIO $

@@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -20,9 +21,6 @@         -- collection of source files.    oneShot, compileFile, -        -- Interfaces for the batch-mode driver-   linkBinary,-         -- Interfaces for the compilation manager (interpreted/batch-mode)    preprocess,    compileOne, compileOne',@@ -32,8 +30,7 @@    PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),    phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,    hscPostBackendPhase, getLocation, setModLocation, setDynFlags,-   runPhase, exeFileName,-   maybeCreateManifest,+   runPhase,    doCpp,    linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode   ) where@@ -64,10 +61,15 @@ import GHC.Parser.Errors.Ppr  import GHC.SysTools-import GHC.SysTools.ExtraObj import GHC.SysTools.FileCleanup-import GHC.SysTools.Ar +import GHC.Linker.ExtraObj+import GHC.Linker.Dynamic+import GHC.Linker.MacOS+import GHC.Linker.Unit+import GHC.Linker.Static+import GHC.Linker.Types+ import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Panic@@ -78,7 +80,6 @@ import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Settings-import GHC.Runtime.Linker.Types  import GHC.Data.Bag            ( unitBag ) import GHC.Data.FastString     ( mkFastString )@@ -196,10 +197,12 @@    debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)     -- Run the pipeline up to codeGen (so everything up to, but not including, STG)-   (status, plugin_dflags) <- hscIncrementalCompile+   (status, plugin_hsc_env) <- hscIncrementalCompile                         always_do_basic_recompilation_check                         m_tc_result mHscMessage                         hsc_env summary source_modified mb_old_iface (mod_index, nmods)+   -- Use an HscEnv updated with the plugin info+   let hsc_env' = plugin_hsc_env     let flags = hsc_dflags hsc_env0      in do unless (gopt Opt_KeepHiFiles flags) $@@ -209,10 +212,6 @@                addFilesToClean flags TFL_GhcSession $                    [ml_obj_file $ ms_location summary] -   -- Use an HscEnv with DynFlags updated with the plugin info (returned from-   -- hscIncrementalCompile)-   let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }-    case (status, bcknd) of         (HscUpToDate iface hmi_details, _) ->             -- TODO recomp014 triggers this assert. What's going on?!@@ -258,12 +257,12 @@                      hscs_mod_location = mod_location,                      hscs_mod_details = hmi_details,                      hscs_partial_iface = partial_iface,-                     hscs_old_iface_hash = mb_old_iface_hash,-                     hscs_iface_dflags = iface_dflags }, Interpreter) -> do+                     hscs_old_iface_hash = mb_old_iface_hash+                   }, Interpreter) -> do             -- In interpreted mode the regular codeGen backend is not run so we             -- generate a interface without codeGen info.-            final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing-            liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary)+            final_iface <- mkFullIface hsc_env' partial_iface Nothing+            liftIO $ hscMaybeWriteIface dflags True final_iface mb_old_iface_hash (ms_location summary)              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location @@ -549,8 +548,8 @@          let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)             obj_files = concatMap getOfiles linkables--            exe_file = exeFileName staticLink dflags+            platform  = targetPlatform dflags+            exe_file  = exeFileName platform staticLink (outputFile dflags)          linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps @@ -585,7 +584,8 @@         -- if the modification time on the executable is later than the         -- modification times on all of the objects and libraries, then omit         -- linking (unless the -fforce-recomp flag was given).-  let exe_file = exeFileName staticLink dflags+  let platform = targetPlatform dflags+      exe_file = exeFileName platform staticLink (outputFile dflags)   e_exe_time <- tryIO $ getModificationUTCTime exe_file   case e_exe_time of     Left _  -> return True@@ -606,7 +606,7 @@                           | Just c <- map (lookupUnitId unit_state) pkg_deps,                             lib <- packageHsLibs dflags c ] -        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs+        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs         if any isNothing pkg_libfiles then return True else do         e_lib_times <- mapM (tryIO . getModificationUTCTime)                           (catMaybes pkg_libfiles)@@ -615,11 +615,11 @@            then return True            else checkLinkInfo dflags pkg_deps exe_file -findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)-findHSLib dflags dirs lib = do-  let batch_lib_file = if WayDyn `notElem` ways dflags+findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)+findHSLib platform ws dirs lib = do+  let batch_lib_file = if WayDyn `notElem` ws                       then "lib" ++ lib <.> "a"-                      else platformSOName (targetPlatform dflags) lib+                      else platformSOName platform lib   found <- filterM doesFileExist (map (</> batch_lib_file) dirs)   case found of     [] -> return Nothing@@ -772,20 +772,41 @@          r <- runPipeline' start_phase hsc_env env input_fn'                            maybe_loc foreign_os -         -- If we are compiling a Haskell module, and doing-         -- -dynamic-too, but couldn't do the -dynamic-too fast-         -- path, then rerun the pipeline for the dyn way          let dflags = hsc_dflags hsc_env-         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)-         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $-           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do-               debugTraceMsg dflags 4-                   (text "Running the pipeline again for -dynamic-too")-               let dflags' = dynamicTooMkDynamicDynFlags dflags-               hsc_env' <- newHscEnv dflags'-               _ <- runPipeline' start_phase hsc_env' env input_fn'-                                 maybe_loc foreign_os-               return ()+         when isHaskellishFile $+           dynamicTooState dflags >>= \case+               DT_Dont   -> return ()+               DT_Dyn    -> return ()+               DT_OK     -> return ()+               -- If we are compiling a Haskell module with -dynamic-too, we+               -- first try the "fast path": that is we compile the non-dynamic+               -- version and at the same time we check that interfaces depended+               -- on exist both for the non-dynamic AND the dynamic way. We also+               -- check that they have the same hash.+               --    If they don't, dynamicTooState is set to DT_Failed.+               --       See GHC.Iface.Load.checkBuildDynamicToo+               --    If they do, in the end we produce both the non-dynamic and+               --    dynamic outputs.+               --+               -- If this "fast path" failed, we execute the whole pipeline+               -- again, this time for the dynamic way *only*. To do that we+               -- just set the dynamicNow bit from the start to ensure that the+               -- dynamic DynFlags fields are used and we disable -dynamic-too+               -- (its state is already set to DT_Failed so it wouldn't do much+               -- anyway).+               DT_Failed+                   -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)+                   | OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()+                   | otherwise -> do+                       debugTraceMsg dflags 4+                           (text "Running the full pipeline again for -dynamic-too")+                       let dflags' = flip gopt_unset Opt_BuildDynamicToo+                                      $ setDynamicNow+                                      $ dflags+                       hsc_env' <- newHscEnv dflags'+                       _ <- runPipeline' start_phase hsc_env' env input_fn'+                                         maybe_loc foreign_os+                       return ()          return r  runPipeline'@@ -849,23 +870,40 @@    _      -> do liftIO $ debugTraceMsg dflags 4                                   (text "Running phase" <+> ppr phase)-           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+            case phase of                HscOut {} -> do-                   -- We don't pass Opt_BuildDynamicToo to the backend-                   -- in DynFlags.-                   -- Instead it's run twice with flags accordingly set-                   -- per run.-                   let noDynToo = pipeLoop next_phase output_fn+                   let noDynToo = do+                        (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+                        pipeLoop next_phase output_fn                    let dynToo = do-                          setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo-                          r <- pipeLoop next_phase output_fn-                          setDynFlags $ dynamicTooMkDynamicDynFlags dflags-                          -- TODO shouldn't ignore result:-                          _ <- pipeLoop phase input_fn-                          return r-                   ifGeneratingDynamicToo dflags dynToo noDynToo-               _ -> pipeLoop next_phase output_fn+                          -- if Opt_BuildDynamicToo is set and if the platform+                          -- supports it, we first run the backend to generate+                          -- the dynamic objects and then re-run it to generate+                          -- the non-dynamic ones.+                          let dflags' = setDynamicNow dflags -- set "dynamicNow"+                          setDynFlags dflags'+                          (next_phase, output_fn) <- runHookedPhase phase input_fn dflags'+                          _ <- pipeLoop next_phase output_fn+                          -- TODO: we probably shouldn't ignore the result of+                          -- the dynamic compilation+                          setDynFlags dflags -- restore flags without "dynamicNow" set+                          noDynToo+                   dynamicTooState dflags >>= \case+                     DT_Dont   -> noDynToo+                     DT_Failed -> noDynToo+                     DT_OK     -> dynToo+                     DT_Dyn    -> noDynToo+                        -- it shouldn't be possible to be in this last case+                        -- here. It would mean that we executed the whole+                        -- pipeline with DynamicNow and Opt_BuildDynamicToo set.+                        --+                        -- When we restart the whole pipeline for -dynamic-too+                        -- we set DynamicNow but we unset Opt_BuildDynamicToo so+                        -- it's weird.+               _ -> do+                  (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+                  pipeLoop next_phase output_fn  runHookedPhase :: PhasePlus -> FilePath -> DynFlags                -> CompPipeline (PhasePlus, FilePath)@@ -1219,12 +1257,15 @@    -- run the compiler!         let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, plugin_dflags) <-+        (result, plugin_hsc_env) <-           liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'                             mod_summary source_unchanged Nothing (1,1) -        -- In the rest of the pipeline use the dflags with plugin info-        setDynFlags plugin_dflags+        -- In the rest of the pipeline use the loaded plugins+        setPlugins (hsc_plugins        plugin_hsc_env)+                   (hsc_static_plugins plugin_hsc_env)+        -- "driver" plugins may have modified the DynFlags so we update them+        setDynFlags (hsc_dflags plugin_hsc_env)          return (HscOut src_flavour mod_name result,                 panic "HscOut doesn't have an input filename")@@ -1263,8 +1304,8 @@                         hscs_mod_location = mod_location,                         hscs_mod_details = mod_details,                         hscs_partial_iface = partial_iface,-                        hscs_old_iface_hash = mb_old_iface_hash,-                        hscs_iface_dflags = iface_dflags }+                        hscs_old_iface_hash = mb_old_iface_hash+                      }               -> do output_fn <- phaseOutputFilename next_phase                      PipeState{hsc_env=hsc_env'} <- getPipeState@@ -1272,17 +1313,17 @@                     (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $                       hscGenHardCode hsc_env' cgguts mod_location output_fn -                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))+                    let dflags = hsc_dflags hsc_env'+                    final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))                     let final_mod_details-                           | gopt Opt_OmitInterfacePragmas iface_dflags+                           | gopt Opt_OmitInterfacePragmas dflags                            = mod_details                            | otherwise = {-# SCC updateModDetailsIdInfos #-}                                          updateModDetailsIdInfos cg_infos mod_details                     setIface final_iface final_mod_details                      -- See Note [Writing interface files]-                    let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo-                    liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location+                    liftIO $ hscMaybeWriteIface dflags False final_iface mb_old_iface_hash mod_location                      stub_o <- liftIO (mapM (compileStub hsc_env') mStub)                     foreign_os <- liftIO $@@ -1727,308 +1768,7 @@       _other ->           return [] --------------------------------------------------------------------------------- Static linking, of .o files --- The list of packages passed to link is the list of packages on--- which this program depends, as discovered by the compilation--- manager.  It is combined with the list of packages that the user--- specifies on the command line with -package flags.------ In one-shot linking mode, we can't discover the package--- dependencies (because we haven't actually done any compilation or--- read any interface files), so the user must explicitly specify all--- the packages.--{--Note [-Xlinker -rpath vs -Wl,-rpath]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---Wl takes a comma-separated list of options which in the case of--Wl,-rpath -Wl,some,path,with,commas parses the path with commas-as separate options.-Buck, the build system, produces paths with commas in them.---Xlinker doesn't have this disadvantage and as far as I can tell-it is supported by both gcc and clang. Anecdotally nvcc supports--Xlinker, but not -Wl.--}--linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()-linkBinary = linkBinary' False--linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()-linkBinary' staticLink dflags o_files dep_units = do-    let platform = targetPlatform dflags-        toolSettings' = toolSettings dflags-        verbFlags = getVerbFlags dflags-        output_fn = exeFileName staticLink dflags-        home_unit = mkHomeUnitFromFlags dflags--    -- get the full list of packages to link with, by combining the-    -- explicit packages with the auto packages and all of their-    -- dependencies, and eliminating duplicates.--    full_output_fn <- if isAbsolute output_fn-                      then return output_fn-                      else do d <- getCurrentDirectory-                              return $ normalise (d </> output_fn)-    pkg_lib_paths <- getUnitLibraryPath-                        (initSDocContext dflags defaultUserStyle)-                        (unitState dflags)-                        home_unit-                        (ways dflags)-                        dep_units-    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths-        get_pkg_lib_path_opts l-         | osElfTarget (platformOS platform) &&-           dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags-                            then "$ORIGIN" </>-                                 (l `makeRelativeTo` full_output_fn)-                            else l-                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]-                  rpath = if gopt Opt_RPath dflags-                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]-                          else []-                  -- Solaris 11's linker does not support -rpath-link option. It silently-                  -- ignores it and then complains about next option which is -l<some-                  -- dir> as being a directory and not expected object file, E.g-                  -- ld: elf error: file-                  -- /tmp/ghc-src/libraries/base/dist-install/build:-                  -- elf_begin: I/O error: region read: Is a directory-                  rpathlink = if (platformOS platform) == OSSolaris2-                              then []-                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]-              in ["-L" ++ l] ++ rpathlink ++ rpath-         | osMachOTarget (platformOS platform) &&-           dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags &&-           gopt Opt_RPath dflags-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags-                            then "@loader_path" </>-                                 (l `makeRelativeTo` full_output_fn)-                            else l-              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]-         | otherwise = ["-L" ++ l]--    pkg_lib_path_opts <--      if gopt Opt_SingleLibFolder dflags-      then do-        libs <- getLibs dflags dep_units-        tmpDir <- newTempDir dflags-        sequence_ [ copyFile lib (tmpDir </> basename)-                  | (lib, basename) <- libs]-        return [ "-L" ++ tmpDir ]-      else pure pkg_lib_path_opts--    let-      dead_strip-        | gopt Opt_WholeArchiveHsLibs dflags = []-        | otherwise = if osSubsectionsViaSymbols (platformOS platform)-                        then ["-Wl,-dead_strip"]-                        else []-    let lib_paths = libraryPaths dflags-    let lib_path_opts = map ("-L"++) lib_paths--    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags-    noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units--    let-      (pre_hs_libs, post_hs_libs)-        | gopt Opt_WholeArchiveHsLibs dflags-        = if platformOS platform == OSDarwin-            then (["-Wl,-all_load"], [])-              -- OS X does not have a flag to turn off -all_load-            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])-        | otherwise-        = ([],[])--    pkg_link_opts <- do-        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units-        return $ if staticLink-            then package_hs_libs -- If building an executable really means making a static-                                 -- library (e.g. iOS), then we only keep the -l options for-                                 -- HS packages, because libtool doesn't accept other options.-                                 -- In the case of iOS these need to be added by hand to the-                                 -- final link in Xcode.-            else other_flags ++ dead_strip-                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs-                  ++ extra_libs-                 -- -Wl,-u,<sym> contained in other_flags-                 -- needs to be put before -l<package>,-                 -- otherwise Solaris linker fails linking-                 -- a binary with unresolved symbols in RTS-                 -- which are defined in base package-                 -- the reason for this is a note in ld(1) about-                 -- '-u' option: "The placement of this option-                 -- on the command line is significant.-                 -- This option must be placed before the library-                 -- that defines the symbol."--    -- frameworks-    pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units-    let framework_opts = getFrameworkOpts dflags platform--        -- probably _stub.o files-    let extra_ld_inputs = ldInputs dflags--    rc_objs <- maybeCreateManifest dflags output_fn--    let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args-                         | platformOS platform == OSDarwin-                            = GHC.SysTools.runLink dflags args >> GHC.SysTools.runInjectRPaths dflags pkg_lib_paths output_fn-                         | otherwise-                            = GHC.SysTools.runLink dflags args--    link dflags (-                       map GHC.SysTools.Option verbFlags-                      ++ [ GHC.SysTools.Option "-o"-                         , GHC.SysTools.FileOption "" output_fn-                         ]-                      ++ libmLinkOpts-                      ++ map GHC.SysTools.Option (-                         []--                      -- See Note [No PIE when linking]-                      ++ picCCOpts dflags--                      -- Permit the linker to auto link _symbol to _imp_symbol.-                      -- This lets us link against DLLs without needing an "import library".-                      ++ (if platformOS platform == OSMinGW32-                          then ["-Wl,--enable-auto-import"]-                          else [])--                      -- '-no_compact_unwind'-                      -- C++/Objective-C exceptions cannot use optimised-                      -- stack unwinding code. The optimised form is the-                      -- default in Xcode 4 on at least x86_64, and-                      -- without this flag we're also seeing warnings-                      -- like-                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog-                      -- on x86.-                      ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&-                             not staticLink &&-                             (platformOS platform == OSDarwin) &&-                             case platformArch platform of-                               ArchX86 -> True-                               ArchX86_64 -> True-                               ArchARM {} -> True-                               ArchARM64  -> True-                               _ -> False-                          then ["-Wl,-no_compact_unwind"]-                          else [])--                      -- '-Wl,-read_only_relocs,suppress'-                      -- ld gives loads of warnings like:-                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure-                      -- when linking any program. We're not sure-                      -- whether this is something we ought to fix, but-                      -- for now this flags silences them.-                      ++ (if platformOS   platform == OSDarwin &&-                             platformArch platform == ArchX86 &&-                             not staticLink-                          then ["-Wl,-read_only_relocs,suppress"]-                          else [])--                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&-                             not (gopt Opt_WholeArchiveHsLibs dflags)-                          then ["-Wl,--gc-sections"]-                          else [])--                      ++ o_files-                      ++ lib_path_opts)-                      ++ extra_ld_inputs-                      ++ map GHC.SysTools.Option (-                         rc_objs-                      ++ framework_opts-                      ++ pkg_lib_path_opts-                      ++ extraLinkObj:noteLinkObjs-                      ++ pkg_link_opts-                      ++ pkg_framework_opts-                      ++ (if platformOS platform == OSDarwin-                          --  dead_strip_dylibs, will remove unused dylibs, and thus save-                          --  space in the load commands. The -headerpad is necessary so-                          --  that we can inject more @rpath's later for the left over-                          --  libraries during runInjectRpaths phase.-                          ---                          --  See Note [Dynamic linking on macOS].-                          then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ]-                          else [])-                    ))--exeFileName :: Bool -> DynFlags -> FilePath-exeFileName staticLink dflags-  | Just s <- outputFile dflags =-      case platformOS (targetPlatform dflags) of-          OSMinGW32 -> s <?.> "exe"-          _         -> if staticLink-                         then s <?.> "a"-                         else s-  | otherwise =-      if platformOS (targetPlatform dflags) == OSMinGW32-      then "main.exe"-      else if staticLink-           then "liba.a"-           else "a.out"- where s <?.> ext | null (takeExtension s) = s <.> ext-                  | otherwise              = s--maybeCreateManifest-   :: DynFlags-   -> FilePath                          -- filename of executable-   -> IO [FilePath]                     -- extra objects to embed, maybe-maybeCreateManifest dflags exe_filename- | platformOS (targetPlatform dflags) == OSMinGW32 &&-   gopt Opt_GenManifest dflags-    = do let manifest_filename = exe_filename <.> "manifest"--         writeFile manifest_filename $-             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++-             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++-             "  <assemblyIdentity version=\"1.0.0.0\"\n"++-             "     processorArchitecture=\"X86\"\n"++-             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++-             "     type=\"win32\"/>\n\n"++-             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++-             "    <security>\n"++-             "      <requestedPrivileges>\n"++-             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++-             "        </requestedPrivileges>\n"++-             "       </security>\n"++-             "  </trustInfo>\n"++-             "</assembly>\n"--         -- Windows will find the manifest file if it is named-         -- foo.exe.manifest. However, for extra robustness, and so that-         -- we can move the binary around, we can embed the manifest in-         -- the binary itself using windres:-         if not (gopt Opt_EmbedManifest dflags) then return [] else do--         rc_filename <- newTempName dflags TFL_CurrentModule "rc"-         rc_obj_filename <--           newTempName dflags TFL_GhcSession (objectSuf dflags)--         writeFile rc_filename $-             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"-               -- magic numbers :-)-               -- show is a bit hackish above, but we need to escape the-               -- backslashes in the path.--         runWindres dflags $ map GHC.SysTools.Option $-               ["--input="++rc_filename,-                "--output="++rc_obj_filename,-                "--output-format=coff"]-               -- no FileOptions here: windres doesn't like seeing-               -- backslashes, apparently--         removeFile manifest_filename--         return [rc_obj_filename]- | otherwise = return []-- linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_units = do   when (haveRtsOptsFlags dflags) $@@ -2038,47 +1778,6 @@       text "    Call hs_init_ghc() from your main() function to set these options.")   linkDynLib dflags o_files dep_units --- | Linking a static lib will not really link anything. It will merely produce--- a static archive of all dependent static libraries. The resulting library--- will still need to be linked with any remaining link flags.-linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()-linkStaticLib dflags o_files dep_units = do-  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]-      modules = o_files ++ extra_ld_inputs-      output_fn = exeFileName True dflags-      home_unit = mkHomeUnitFromFlags dflags--  full_output_fn <- if isAbsolute output_fn-                    then return output_fn-                    else do d <- getCurrentDirectory-                            return $ normalise (d </> output_fn)-  output_exists <- doesFileExist full_output_fn-  (when output_exists) $ removeFile full_output_fn--  pkg_cfgs_init <- getPreloadUnitsAnd-                     (initSDocContext dflags defaultUserStyle)-                     (unitState dflags)-                     home_unit-                     dep_units--  let pkg_cfgs-        | gopt Opt_LinkRts dflags-        = pkg_cfgs_init-        | otherwise-        = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init--  archives <- concatMapM (collectArchives dflags) pkg_cfgs--  ar <- foldl mappend-        <$> (Archive <$> mapM loadObj modules)-        <*> mapM loadAr archives--  if toolSettings_ldIsGnuLd (toolSettings dflags)-    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar-    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar--  -- run ranlib over the archive. write*Ar does *not* create the symbol index.-  runRanlib dflags [GHC.SysTools.FileOption "" output_fn]  -- ----------------------------------------------------------------------------- -- Running CPP

@@ -198,7 +198,7 @@         ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps          ; let used_names = mkUsedNames tcg_env-              pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))+              pluginModules = map lpModule (hsc_plugins hsc_env)               home_unit = hsc_home_unit hsc_env         ; deps <- mkDependencies (homeUnitId home_unit)                                  (map mi_module pluginModules) tcg_env

@@ -141,7 +141,7 @@ -- instanceMap. getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case-  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc ty   -- The Names of data and type family instances have their SrcSpan's attached   -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have   -- its SrcSpan attached here:@@ -149,12 +149,12 @@   --   type instance Foo Int = Bool   --                 ^^^   DataFamInstD _ (DataFamInstDecl-    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l+    { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l   -- Since CoAxioms' Names refer to the whole line for type family instances   -- in particular, we need to dig a bit deeper to pull out the entire   -- equation. This does not happen for data family instances, for some reason.   TyFamInstD _ (TyFamInstDecl-    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l+    { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l  -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data@@ -164,12 +164,12 @@              -> [(Name, [(HsDocString)], Map Int (HsDocString))] subordinates instMap decl = case decl of   InstD _ (ClsInstD _ d) -> do-    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+    DataFamInstDecl { dfid_eqn =       FamEqn { feqn_tycon = L l _-             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d+             , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d     [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn -  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))+  InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)   TyClD _ d | isClassDecl d -> classSubs d             | isDataDecl  d -> dataSubs (tcdDataDefn d)@@ -205,12 +205,8 @@             DctMulti _ tys -> mapMaybe extract_deriv_ty tys          extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)-        extract_deriv_ty (HsIB{hsib_body =  L l ty}) =+        extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =           case ty of-            -- deriving (forall a. C a {- ^ Doc comment -})-            HsForAllTy{ hst_tele = HsForAllInvis{}-                      , hst_body = L _ (HsDocTy _ _ doc) }-                            -> Just (l, doc)             -- deriving (C a {- ^ Doc comment -})             HsDocTy _ _ doc -> Just (l, doc)             _               -> Nothing@@ -259,10 +255,10 @@ -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) declTypeDocs = \case-  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))-  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))-  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))-  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))+  SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))+  SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)+  SigD  _ (PatSynSig _ _ ty)        -> sigTypeDocs (unLoc ty)+  ForD  _ (ForeignImport _ _ ty _)  -> sigTypeDocs (unLoc ty)   TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)   _                                 -> M.empty @@ -288,6 +284,10 @@       HsFunTy _ _ _ ty                      -> go (n+1) (unLoc ty)       HsDocTy _ _ doc                       -> M.singleton n (unLoc doc)       _                                     -> M.empty++-- | Extract function argument docs from inside types.+sigTypeDocs :: HsSigType GhcRn -> Map Int HsDocString+sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)  -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.

@@ -21,9 +21,7 @@  #include "GhclibHsVersions.h" - import GHC.Prelude-import GHC.Platform  import GHC.Core @@ -41,7 +39,6 @@ import GHC.Core.Multiplicity import GHC.Types.Id   ( Id ) import GHC.Core.Coercion-import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim import GHC.Core.TyCon import GHC.Builtin.Types@@ -346,7 +343,7 @@    -- The type might contain foralls (eg. for dummy type arguments,   -- referring to 'Ptr a' is legal).-  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty+  | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty   = do { (maybe_ty, wrapper) <- resultWrapper rest        ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } @@ -355,36 +352,13 @@   | Just (tycon, tycon_arg_tys) <- maybe_tc_app   , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument-  = do { dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty-       ; let narrow_wrapper = maybeNarrow platform tycon-             marshal_con e  = Var (dataConWrapId data_con)+  = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty+       ; let marshal_con e  = Var (dataConWrapId data_con)                               `mkTyApps` tycon_arg_tys-                              `App` wrapper (narrow_wrapper e)+                              `App` wrapper e        ; return (maybe_ty, marshal_con) }    | otherwise   = pprPanic "resultWrapper" (ppr result_ty)   where     maybe_tc_app = splitTyConApp_maybe result_ty---- When the result of a foreign call is smaller than the word size, we--- need to sign- or zero-extend the result up to the word size.  The C--- standard appears to say that this is the responsibility of the--- caller, not the callee.--maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)-maybeNarrow platform tycon-  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e-  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e-  | tycon `hasKey` int32TyConKey-  , platformWordSizeInBytes platform > 4-  = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e--  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e-  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e-  | tycon `hasKey` word32TyConKey-  , platformWordSizeInBytes platform > 4-  = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e-  | otherwise                     = id

@@ -212,7 +212,7 @@ dsFCall fn_id co fcall mDeclHeader = do     let         ty                   = coercionLKind co-        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty+        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty         (arg_tys, io_res_ty) = tcSplitFunTys rho      args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism@@ -316,7 +316,7 @@ dsPrimCall fn_id co fcall = do     let         ty                   = coercionLKind co-        (tvs, fun_ty)        = tcSplitForAllTys ty+        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty      args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism@@ -453,7 +453,7 @@           to be entered using an external calling convention           (stdcall, ccall).          -}-        adj_args      = [ mkIntLitInt platform (ccallConvToInt cconv)+        adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))                         , Var stbl_value                         , Lit (LitLabel fe_nm mb_sz_args IsFunction)                         , Lit (mkLitString typestring)@@ -489,7 +489,7 @@   where   ty                       = coercionLKind co0-  (tvs,sans_foralls)       = tcSplitForAllTys ty+  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty   ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty         -- Must have an IO type; hence Just@@ -849,6 +849,12 @@  = case typePrimRep1 (getPrimTyOf ty) of      IntRep      -> signed_word      WordRep     -> unsigned_word+     Int8Rep     -> 'B'+     Word8Rep    -> 'b'+     Int16Rep    -> 'S'+     Word16Rep   -> 's'+     Int32Rep    -> 'W'+     Word32Rep   -> 'w'      Int64Rep    -> 'L'      Word64Rep   -> 'l'      AddrRep     -> 'p'

@@ -381,7 +381,10 @@       case vars of -- See #11245            [] -> text "Guards do not cover entire pattern space"            _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas-                 in  hang (text "Patterns not matched:") 4+                     pp_tys = pprQuotedList $ map idType vars+                 in  hang+                       (text "Patterns of type" <+> pp_tys <+> text "not matched:")+                       4                        (vcat (take maxPatterns us) $$ dots maxPatterns us)      approx_msg = vcat

@@ -136,26 +136,13 @@  -- | Pretty print a variable, but remember to prettify the names of the variables -- that refer to neg-literals. The ones that cannot be shown are printed as--- underscores. Even with a type signature, if it's not too noisy.+-- underscores. pprPmVar :: PprPrec -> Id -> PmPprM SDoc--- Type signature is "too noisy" by my definition if it needs to parenthesize.--- I like           "not matched: _ :: Proxy (DIdEnv (Id, SDoc))",--- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv (Id, SDoc)))"--- The useful information in the latter case is the constructor that we missed,--- not the types of the wildcards in the places that aren't matched as a result. pprPmVar prec x = do   nabla <- ask   case lookupSolution nabla x of     Just (PACA alt _tvs args) -> pprPmAltCon prec alt args-    Nothing                   -> fromMaybe typed_wildcard <$> checkRefuts x-      where-        -- if we have no info about the parameter and would just print a-        -- wildcard, also show its type.-        typed_wildcard-          | prec <= sigPrec-          = underscore <+> text "::" <+> ppr (idType x)-          | otherwise-          = underscore+    Nothing                   -> fromMaybe underscore <$> checkRefuts x  pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc pprPmAltCon _prec (PmAltLit l)      _    = pure (ppr l)

@@ -360,7 +360,6 @@   = []  get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]-get_scoped_tvs_from_sig sig   -- Collect both implicit and explicit quantified variables, since   -- the types in instance heads, as well as `via` types in DerivingVia, can   -- bring implicitly quantified type variables into scope, e.g.,@@ -369,10 +368,8 @@   --     m = n @a   --   -- See also Note [Scoped type variables in quotes]-  | HsIB { hsib_ext = implicit_vars-         , hsib_body = hs_ty } <- sig-  , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty-  = implicit_vars ++ hsLTyVarNames explicit_vars+get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =+  hsOuterTyVarNames outer_bndrs  {- Notes @@ -508,7 +505,11 @@ repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repKiSigD (L loc kisig) =   case kisig of-    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v+    StandaloneKindSig _ v ki -> do+      MkC th_v  <- lookupLOcc v+      MkC th_ki <- repHsSigType ki+      dec       <- rep2 kiSigDName [th_v, th_ki]+      pure (loc, dec)  ------------------------- repDataDefn :: Core TH.Name@@ -689,27 +690,21 @@        ; repTySynInst eqn1 }  repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))-repTyFamEqn (HsIB { hsib_ext = var_names-                  , hsib_body = FamEqn { feqn_tycon = tc_name-                                       , feqn_bndrs = mb_bndrs-                                       , feqn_pats = tys-                                       , feqn_fixity = fixity-                                       , feqn_rhs  = rhs }})+repTyFamEqn (FamEqn { feqn_tycon = tc_name+                    , feqn_bndrs = outer_bndrs+                    , feqn_pats = tys+                    , feqn_fixity = fixity+                    , feqn_rhs  = rhs })   = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of+       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->+         do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys                                      ; t1' <- repLTy t1                                      ; t2'  <- repLTy t2                                      ; repTyArgs (repTInfix t1' tc t2') args }             ; rhs1 <- repLTy rhs-            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }+            ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]            checkTys tys@(HsValArg _:HsValArg _:_) = return tys            checkTys _ = panic "repTyFamEqn:checkTys"@@ -726,26 +721,20 @@  repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repDataFamInstD (DataFamInstDecl { dfid_eqn =-                  (HsIB { hsib_ext = var_names-                        , hsib_body = FamEqn { feqn_tycon = tc_name-                                             , feqn_bndrs = mb_bndrs+                                      FamEqn { feqn_tycon = tc_name+                                             , feqn_bndrs = outer_bndrs                                              , feqn_pats  = tys                                              , feqn_fixity = fixity-                                             , feqn_rhs   = defn }})})+                                             , feqn_rhs   = defn }})   = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of+       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->+         do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys                                      ; t1' <- repLTy t1                                      ; t2'  <- repLTy t2                                      ; repTyArgs (repTInfix t1' tc t2') args }-            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }+            ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }        where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]             checkTys tys@(HsValArg _: HsValArg _: _) = return tys@@ -892,26 +881,28 @@               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])             } -repC (L _ (ConDeclGADT { con_g_ext  = imp_tvs-                       , con_names  = cons-                       , con_qvars  = exp_tvs+repC (L _ (ConDeclGADT { con_names  = cons+                       , con_bndrs  = L _ outer_bndrs                        , con_mb_cxt = mcxt                        , con_g_args = args                        , con_res_ty = res_ty }))-  | null imp_tvs && null exp_tvs -- No implicit or explicit variables+  | null_outer_imp_tvs && null_outer_exp_tvs+                                 -- No implicit or explicit variables   , Nothing <- mcxt              -- No context                                  -- ==> no need for a forall   = repGadtDataCons cons args res_ty    | otherwise-  = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs ->+  = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->              -- See Note [Don't quantify implicit type variables in quotes]     do { c'    <- repGadtDataCons cons args res_ty        ; ctxt' <- repMbContext mcxt-       ; if null exp_tvs && isNothing mcxt+       ; if null_outer_exp_tvs && isNothing mcxt          then return c'-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }-+         else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }+  where+    null_outer_imp_tvs = nullOuterImplicit outer_bndrs+    null_outer_exp_tvs = nullOuterExplicit outer_bndrs  repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing          = repContext []@@ -962,7 +953,7 @@       DctMulti _ tys -> rep_deriv_tys tys      rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])-    rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)+    rep_deriv_tys = repListM typeTyConName repHsSigType  rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn                     -> MetaM ([GenSymBind], [Core (M TH.Dec)])@@ -1014,13 +1005,20 @@ rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]                -> MetaM (Core [M TH.TyVarBndrSpec]) rep_ty_sig_tvs explicit_tvs-  = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                ; repTyVarBndrWithKind tv name } in-    repListM tyVarBndrSpecTyConName rep_in_scope_tv+  = repListM tyVarBndrSpecTyConName repTyVarBndr              explicit_tvs-         -- NB: Don't pass any implicit type variables to repList above-         -- See Note [Don't quantify implicit type variables in quotes] +-- Desugar the outer type variable binders in an 'LHsSigType', making+-- sure not to gensym them.+-- See Note [Scoped type variables in quotes]+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn+                     -> MetaM (Core [M TH.TyVarBndrSpec])+rep_ty_sig_outer_tvs (HsOuterImplicit{}) =+  coreListM tyVarBndrSpecTyConName []+rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =+  rep_ty_sig_tvs explicit_tvs+ -- Desugar a top-level type signature. Unlike 'repHsSigType', this -- deliberately avoids gensymming the type variables. -- See Note [Scoped type variables in quotes]@@ -1039,15 +1037,14 @@ -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig' :: LHsSigType GhcRn             -> MetaM (Core (M TH.Type))-rep_ty_sig' sig_ty-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty-  = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs+rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))+  | (ctxt, tau) <- splitLHsQualTy body+  = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs        ; th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-            then return th_ty-            else repTForall th_explicit_tvs th_ctxt th_ty }+       ; th_tau  <- repLTy tau+       ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)+            then return th_tau+            else repTForall th_explicit_tvs th_ctxt th_tau }  rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name                   -> MetaM (SrcSpan, Core (M TH.Dec))@@ -1058,8 +1055,7 @@ -- see Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_patsyn_ty_sig loc sig_ty nm-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty+  | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty   = do { nm1 <- lookupLOcc nm        ; th_univs <- rep_ty_sig_tvs univs        ; th_exis  <- rep_ty_sig_tvs exis@@ -1167,6 +1163,56 @@ rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] rep_flag InferredSpec  = rep2_nw inferredSpecName [] +addHsOuterFamEqnTyVarBinds ::+     HsOuterFamEqnTyVarBndrs GhcRn+  -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))+  -> MetaM (Core (M a))+addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do+  elt_ty <- wrapName tyVarBndrUnitTyConName+  case outer_bndrs of+    HsOuterImplicit{hso_ximplicit = imp_tvs} ->+      addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->+      thing_inside $ coreNothingList elt_ty+    HsOuterExplicit{hso_bndrs = exp_bndrs} ->+      addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->+      thing_inside $ coreJustList elt_ty th_exp_bndrs+  where+    mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs+                                     , hsq_explicit = exp_tvs }++addHsOuterSigTyVarBinds ::+     HsOuterSigTyVarBndrs GhcRn+  -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))+  -> MetaM (Core (M a))+addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of+  HsOuterImplicit{hso_ximplicit = imp_tvs} ->+    do th_nil <- coreListM tyVarBndrSpecTyConName []+       addSimpleTyVarBinds imp_tvs $ thing_inside th_nil+  HsOuterExplicit{hso_bndrs = exp_bndrs} ->+    addHsTyVarBinds exp_bndrs thing_inside++-- | If a type implicitly quantifies its outermost type variables, return+-- 'True' if the list of implicitly bound type variables is empty. If a type+-- explicitly quantifies its outermost type variables, always return 'True'.+--+-- This is used in various places to determine if a Template Haskell 'Type'+-- should be headed by a 'ForallT' or not.+nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool+nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs+nullOuterImplicit (HsOuterExplicit{})                        = True+  -- Vacuously true, as there is no implicit quantification++-- | If a type explicitly quantifies its outermost type variables, return+-- 'True' if the list of explicitly bound type variables is empty. If a type+-- implicitly quantifies its outermost type variables, always return 'True'.+--+-- This is used in various places to determine if a Template Haskell 'Type'+-- should be headed by a 'ForallT' or not.+nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool+nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs+nullOuterExplicit (HsOuterImplicit{})                      = True+  -- Vacuously true, as there is no outermost explicit quantification+ addSimpleTyVarBinds :: [Name]             -- the binders to be added                     -> MetaM (Core (M a)) -- action in the ext env                     -> MetaM (Core (M a))@@ -1182,12 +1228,10 @@ addHsTyVarBinds exp_tvs thing_inside   = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)        ; term <- addBinds fresh_exp_names $-                 do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr-                                     (exp_tvs `zip` fresh_exp_names)+                 do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr+                                      exp_tvs                     ; thing_inside kbs }        ; wrapGenSyms fresh_exp_names term }-  where-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)  addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added                -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env@@ -1226,26 +1270,12 @@             -- This makes things work for family declarations         ; term <- addBinds freshNames $-                 do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr+                 do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr                                      (hsQTvExplicit tvs)                     ; m kbs }         ; wrapGenSyms freshNames term }-  where-    mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ())))-    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)-                       ; repTyVarBndrWithKind tv v } --- Produce kinded binder constructors from the Haskell tyvar binders----repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn-                     -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag')))-repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm-  = repPlainTV nm fl-repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm-  = do { ki' <- repLTy ki-       ; repKindedTV nm fl ki' }- -- | Represent a type variable binder repTyVarBndr :: RepTV flag flag'              => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))@@ -1267,17 +1297,14 @@                      repCtxt preds  repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))-repHsSigType (HsIB { hsib_ext = implicit_tvs-                   , hsib_body = body })-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body-  = addSimpleTyVarBinds implicit_tvs $-      -- See Note [Don't quantify implicit type variables in quotes]-    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->+repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body }))+  | (ctxt, tau) <- splitLHsQualTy body+  = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->     do { th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-         then return th_ty-         else repTForall th_explicit_tvs th_ctxt th_ty }+       ; th_tau  <- repLTy tau+       ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)+         then pure th_tau+         else repTForall th_outer_bndrs th_ctxt th_tau }  -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]@@ -2757,11 +2784,10 @@  repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs)-  = do platform <- getPlatform-       word8_ty <- lookupType word8TyConName+  = do word8_ty <- lookupType word8TyConName        let w8s = unpack bs            w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit platform (toInteger w8)]) w8s+                                  [mkWord8Lit (toInteger w8)]) w8s        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit   = do lit' <- case lit of@@ -2923,23 +2949,11 @@  ------------------- Maybe Lists ------------------ --- Lookup the name and wrap it with the m variable-repMaybeListM :: Name -> (a -> MetaM (Core b))-                        -> Maybe [a] -> MetaM (Core (Maybe [b]))-repMaybeListM tc_name f xs = do-  elt_ty <- wrapName tc_name-  repMaybeListT elt_ty f xs---repMaybeListT :: Type -> (a -> MetaM (Core b))-                        -> Maybe [a] -> MetaM (Core (Maybe [b]))-repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty-repMaybeListT elt_ty f (Just args)-  = do { args1 <- mapM f args-       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }+coreJustList :: Type -> Core [a] -> Core (Maybe [a])+coreJustList elt_ty = coreJust' (mkListTy elt_ty) -coreNothingList :: Type -> MetaM (Core (Maybe [a]))-coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)+coreNothingList :: Type -> Core (Maybe [a])+coreNothingList elt_ty = coreNothing' (mkListTy elt_ty)  ------------ Literals & Variables ------------------- 

@@ -37,6 +37,8 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps +import GHC.Linker.Unit+ import GHC.Data.Maybe  import Control.Monad (filterM)@@ -197,7 +199,7 @@             if useDyn               then libLocs               else-                let dflags'  = addWay' WayDyn dflags+                let dflags'  = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }                     dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc                                | searchPath <- searchPaths                                , dlibLoc    <- packageHsLibs dflags' pkg

@@ -512,27 +512,12 @@ -}  class HasLoc a where-  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can-  -- know what their implicit bindings are scoping over+  -- ^ conveniently calculate locations for things without locations attached   loc :: a -> SrcSpan -instance HasLoc thing => HasLoc (TScoped thing) where-  loc (TS _ a) = loc a- instance HasLoc thing => HasLoc (PScoped thing) where   loc (PS _ _ _ a) = loc a -instance HasLoc (LHsQTyVars GhcRn) where-  loc (HsQTvs _ vs) = loc vs--instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where-  loc (HsIB _ a) = loc a-  loc _ = noSrcSpan--instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where-  loc (HsWC _ a) = loc a-  loc _ = noSrcSpan- instance HasLoc (Located a) where   loc (L l _) = l @@ -541,9 +526,11 @@   loc xs = foldl1' combineSrcSpans $ map loc xs  instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where-  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]-  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans-                                              [loc a, loc tvs, loc b, loc c]+  loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of+    HsOuterImplicit{} ->+      foldl1' combineSrcSpans [loc a, loc b, loc c]+    HsOuterExplicit{hso_bndrs = tvs} ->+      foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]  instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where   loc (HsValArg tm) = loc tm@@ -1477,9 +1464,9 @@  instance (ToHie rhs, HasLoc rhs)     => ToHie (FamEqn GhcRn rhs) where-  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $+  toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $     [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var-    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie $ TVS (ResolvedScopes []) scope outer_bndrs     , toHie pats     , toHie rhs     ]@@ -1517,7 +1504,7 @@  instance ToHie (Located (DerivClauseTys GhcRn)) where   toHie (L span dct) = concatM $ makeNode dct span : case dct of-      DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]+      DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]       DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]  instance ToHie (Located (DerivStrategy GhcRn)) where@@ -1525,7 +1512,7 @@       StockStrategy -> []       AnyclassStrategy -> []       NewtypeStrategy -> []-      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]+      ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]  instance ToHie (Located OverlapMode) where   toHie (L span _) = locOnly span@@ -1535,11 +1522,15 @@  instance ToHie (Located (ConDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars+      ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs                   , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->         [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names-        , concatM $ [ bindingsOnly bindings-                    , toHie $ tvScopes resScope NoScope exp_vars ]+        , case outer_bndrs of+            HsOuterImplicit{hso_ximplicit = imp_vars} ->+              bindingsOnly $ map (C $ TyVarBind (mkScope outer_bndrs_loc) resScope)+                             imp_vars+            HsOuterExplicit{hso_bndrs = exp_bndrs} ->+              toHie $ tvScopes resScope NoScope exp_bndrs         , toHie ctx         , toHie args         , toHie typ@@ -1552,7 +1543,6 @@             RecConGADT x     -> mkLScope x           tyScope = mkLScope typ           resScope = ResolvedScopes [ctxScope, rhsScope]-          bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars       ConDeclH98 { con_name = name, con_ex_tvs = qvars                  , con_mb_cxt = ctx, con_args = dets } ->         [ toHie $ C (Decl ConDec $ getRealSpan span) name@@ -1576,21 +1566,17 @@     , toHie decls     ] -instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where-  toHie (TS sc (HsIB ibrn a)) = concatM $-      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsSigType GhcRn)))) where+  toHie (TS sc (HsWC names a)) = concatM $+      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names       , toHie $ TS sc a       ]     where span = loc a -instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsType GhcRn)))) where   toHie (TS sc (HsWC names a)) = concatM $       [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names-      , toHie $ TS sc a+      , toHie a       ]     where span = loc a @@ -1650,18 +1636,26 @@           , toHie $ fmap (C Use) typ           ] -instance ToHie (Located (HsType GhcRn)) where-  toHie x = toHie $ TS (ResolvedScopes []) x+instance ToHie (TScoped (Located (HsSigType GhcRn))) where+  toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNode t span :+      [ toHie (TVS tsc (mkScope span) bndrs)+      , toHie body+      ] -instance ToHie (TScoped (Located (HsType GhcRn))) where-  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of+instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where+  toHie (TVS tsc sc bndrs) = case bndrs of+    HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs+    HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs++instance ToHie (Located (HsType GhcRn)) where+  toHie (L span t) = concatM $ makeNode t span : case t of       HsForAllTy _ tele body ->         let scope = mkScope $ getLoc body in         [ case tele of             HsForAllVis { hsf_vis_bndrs = bndrs } ->-              toHie $ tvScopes tsc scope bndrs+              toHie $ tvScopes (ResolvedScopes []) scope bndrs             HsForAllInvis { hsf_invis_bndrs = bndrs } ->-              toHie $ tvScopes tsc scope bndrs+              toHie $ tvScopes (ResolvedScopes []) scope bndrs         , toHie body         ]       HsQualTy _ ctx body ->@@ -1677,7 +1671,7 @@         ]       HsAppKindTy _ ty ki ->         [ toHie ty-        , toHie $ TS (ResolvedScopes []) ki+        , toHie ki         ]       HsFunTy _ w a b ->         [ toHie (arrowToHsType w)

@@ -6,6 +6,8 @@  {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Loading interface files@@ -103,7 +105,6 @@  import Control.Monad import Control.Exception-import Data.IORef import Data.Map ( toList ) import System.FilePath import System.Directory@@ -432,7 +433,6 @@         ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)                  -- Check whether we have the interface already-        ; dflags <- getDynFlags         ; hsc_env <- getTopEnv         ; let home_unit = hsc_home_unit hsc_env         ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {@@ -550,7 +550,7 @@          ; -- invoke plugins with *full* interface, not final_iface, to ensure           -- that plugins have access to declarations, etc.-          res <- withPlugins dflags (\p -> interfaceLoadAction p) iface+          res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface         ; return (Succeeded res)     }}}} @@ -875,27 +875,35 @@                 Failed err -> return (Failed (badIfaceFile file_path err))                 Succeeded iface -> return (Succeeded (iface, file_path))                             -- Don't forget to fill in the package name...++          -- Indefinite interfaces are ALWAYS non-dynamic.+          checkBuildDynamicToo (Succeeded (iface, _filePath))+            | not (moduleIsDefinite (mi_module iface)) = return ()+           checkBuildDynamicToo (Succeeded (iface, filePath)) = do+              let load_dynamic = do+                     dflags <- getDynFlags+                     let dynFilePath = addBootSuffix_maybe hi_boot_file+                                     $ replaceExtension filePath (hiSuf dflags)+                     r <- read_file dynFilePath+                     case r of+                         Succeeded (dynIface, _)+                          | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->+                             return ()+                          | otherwise ->+                             do traceIf (text "Dynamic hash doesn't match")+                                setDynamicTooFailed dflags+                         Failed err ->+                             do traceIf (text "Failed to load dynamic interface file:" $$ err)+                                setDynamicTooFailed dflags+               dflags <- getDynFlags-              -- Indefinite interfaces are ALWAYS non-dynamic, and-              -- that's OK.-              let is_definite_iface = moduleIsDefinite (mi_module iface)-              when is_definite_iface $-                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do-                  let ref = canGenerateDynamicToo dflags-                      dynFilePath = addBootSuffix_maybe hi_boot_file-                                  $ replaceExtension filePath (dynHiSuf dflags)-                  r <- read_file dynFilePath-                  case r of-                      Succeeded (dynIface, _)-                       | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->-                          return ()-                       | otherwise ->-                          do traceIf (text "Dynamic hash doesn't match")-                             liftIO $ writeIORef ref False-                      Failed err ->-                          do traceIf (text "Failed to load dynamic interface file:" $$ err)-                             liftIO $ writeIORef ref False+              dynamicTooState dflags >>= \case+                DT_Dont   -> return ()+                DT_Failed -> return ()+                DT_Dyn    -> load_dynamic+                DT_OK     -> withDynamicNow load_dynamic+           checkBuildDynamicToo _ = return ()  -- | Write interface file

@@ -193,7 +193,7 @@                     }   = do           let used_names = mkUsedNames tc_result-          let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))+          let pluginModules = map lpModule (hsc_plugins hsc_env)           let home_unit = hsc_home_unit hsc_env           deps <- mkDependencies (homeUnitId home_unit)                     (map mi_module pluginModules) tc_result@@ -656,7 +656,7 @@                 --                op :: (?x :: String) => a -> a                 -- and          class Baz a where                 --                op :: (Ord a) => a -> a-          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id)           op_ty                = funResultTy rho_ty      toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType

@@ -65,6 +65,7 @@ import Data.List (find, sortBy, sort) import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Word (Word64)  --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<>@@ -275,16 +276,16 @@  -- | Check if any plugins are requesting recompilation checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc+checkPlugins hsc_env iface = liftIO $ do+  new_fingerprint <- fingerprintPlugins hsc_env   let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))+  pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)   return $     pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr  fingerprintPlugins :: HscEnv -> IO Fingerprint fingerprintPlugins hsc_env =-  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)+  fingerprintPlugins' $ plugins hsc_env  fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint fingerprintPlugins' plugins = do@@ -729,6 +730,77 @@ field of a IfaceClsInst): only in the non-binding case should we include the fingerprint; in the binding case we shouldn't since it is merely the name of the thing that we are currently fingerprinting.+++Note [Fingerprinting recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The fingerprinting of a single recursive group is a rather subtle affair, as+seen in #18733.++How not to fingerprint+----------------------++Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a+group in hash environment `hash_env0`:++ 1. extend hash_env0, giving each declaration in the group the fingerprint 0+ 2. use this environment to hash the declarations' ABIs, resulting in+    group_fingerprint+ 3. produce the final hash environment by extending hash_env0, mapping each+    declaration of the group to group_fingerprint++However, this is wrong. Consider, for instance, a program like:++    data A = ARecu B | ABase String deriving (Show)+    data B = BRecu A | BBase Int deriving (Show)++    info :: B+    info = BBase 1++A consequence of (3) is that A and B will have the same fingerprint. This means+that if the user changes `info` to:++    info :: A+    info = ABase "hello"++The program's ABI fingerprint will not change despite `info`'s type, and+therefore ABI, being clearly different.++However, the incorrectness doesn't end there: (1) means that all recursive+occurrences of names within the group will be given the same fingerprint. This+means that the group's fingerprint won't change if we change an occurrence of A+to B.++Surprisingly, this bug (#18733) lurked for many years before being uncovered.++How we now fingerprint+----------------------++As seen above, the fingerprinting function must ensure that a groups+fingerprint captures the structure of within-group occurrences. The scheme that+we use is:++ 0. To ensure determinism, sort the declarations into a stable order by+    declaration name++ 1. Extend hash_env0, giving each declaration in the group a sequential+    fingerprint (e.g. 0, 1, 2, ...).++ 2. Use this environment to hash the declarations' ABIs, resulting in+    group_fingerprint.++    Since we included the sequence number in step (1) programs identical up to+    transposition of recursive occurrences are distinguisable, avoiding the+    second issue mentioned above.++ 3. Produce the final environment by extending hash_env, mapping each+    declaration of the group to the hash of (group_fingerprint, i), where+    i is the position of the declaration in the stable ordering.++    Including i in the hash ensures that the first issue noted above is+    avoided.+ -}  -- | Add fingerprints for top-level declarations to a 'ModIface'.@@ -854,18 +926,27 @@                return (env', (hash,decl) : decls_w_hashes)         fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)-          = do let decls = map abiDecl abis+          = do let stable_abis = sortBy cmp_abiNames abis+                   stable_decls = map abiDecl stable_abis                local_env1 <- foldM extend_hash_env local_env-                                   (zip (repeat fingerprint0) decls)+                                   (zip (map mkRecFingerprint [0..]) stable_decls)+                -- See Note [Fingerprinting recursive groups]                let hash_fn = mk_put_name local_env1                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do-               let stable_abis = sortBy cmp_abiNames abis                 -- put the cycle in a canonical order                hash <- computeFingerprint hash_fn stable_abis-               let pairs = zip (repeat hash) decls+               let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls+                -- See Note [Fingerprinting recursive groups]                local_env2 <- foldM extend_hash_env local_env pairs                return (local_env2, pairs ++ decls_w_hashes) +       -- Make a fingerprint from the ordinal position of a binding in its group.+       mkRecFingerprint :: Word64 -> Fingerprint+       mkRecFingerprint i = Fingerprint 0 i++       bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint+       bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]+        -- we have fingerprinted the whole declaration, but we now need        -- to assign fingerprints to all the OccNames that it binds, to        -- use when referencing those OccNames in later declarations.@@ -884,7 +965,8 @@    -- when calculating fingerprints, we always need to use canonical    -- ordering for lists of things.  In particular, the mi_deps has various    -- lists of modules and suchlike, so put these all in canonical order:-   let sorted_deps = sortDependencies (mi_deps iface0)+   let sorted_deps :: Dependencies+       sorted_deps = sortDependencies (mi_deps iface0)     -- The export hash of a module depends on the orphan hashes of the    -- orphan modules below us in the dependency tree.  This is the way@@ -971,7 +1053,8 @@    --     -- put the declarations in a canonical order, sorted by OccName-   let sorted_decls = Map.elems $ Map.fromList $+   let sorted_decls :: [(Fingerprint, IfaceDecl)]+       sorted_decls = Map.elems $ Map.fromList $                           [(getOccName d, e) | e@(_, d) <- decls_w_hashes]     -- the flag hash depends on:@@ -1384,7 +1467,12 @@                       -- so there's no guarantee everything is loaded.                       -- Kind of a heinous hack.                       initIfaceLoad hsc_env . withException-                        $ loadInterface (text "lookupVers2") mod ImportBySystem+                          $ withoutDynamicNow+                            -- For some unknown reason, we need to reset the+                            -- dynamicNow bit, otherwise only dynamic+                            -- interfaces are looked up and some tests fail+                            -- (e.g. T16219).+                          $ loadInterface (text "lookupVers2") mod ImportBySystem         return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`                   pprPanic "lookupVers1" (ppr mod <+> ppr occ)) 

@@ -17,7 +17,7 @@ import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary--- import GHC.Utils.Outputable+import GHC.Core.Opt.CallerCC () -- for Binary instances  import GHC.Data.EnumSet as EnumSet import System.FilePath (normalise)@@ -61,7 +61,7 @@         ticky =           map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] -        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel))+        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))      in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags

@@ -142,7 +142,8 @@ import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Tc.Utils.Env (lookupGlobal)-import GHC.Runtime.Linker.Types++import GHC.Linker.Types  import GHC.Types.Name import GHC.Types.Id

@@ -62,6 +62,7 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.Ppr  import GHC.Unit.External import GHC.Unit.Module@@ -73,6 +74,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Data.Bag import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.List.SetOps@@ -1199,13 +1201,11 @@                                         bndrs' ++                                         exprsFreeIdsList args')                       ; case lintExpr dflags in_scope rhs' of-                          Nothing       -> return ()-                          Just fail_msg -> do { mod <- getIfModule-                                              ; pprPanic "Iface Lint failure"-                                                  (vcat [ text "In interface for" <+> ppr mod-                                                        , hang doc 2 fail_msg-                                                        , ppr name <+> equals <+> ppr rhs'-                                                        , text "Iface expr =" <+> ppr rhs ]) } }+                          Nothing   -> return ()+                          Just errs -> liftIO $+                            displayLintResults dflags False doc+                                               (pprCoreExpr rhs')+                                               (emptyBag, errs) }                    ; return (bndrs', args', rhs') }         ; let mb_tcs = map ifTopFreeName args         ; this_mod <- getIfModule@@ -1724,13 +1724,10 @@         in_scope <- get_in_scope         dflags   <- getDynFlags         case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of-          Nothing       -> return ()-          Just fail_msg -> do { mod <- getIfModule-                              ; pprPanic "Iface Lint failure"-                                  (vcat [ text "In interface for" <+> ppr mod-                                        , hang doc 2 fail_msg-                                        , ppr name <+> equals <+> ppr core_expr'-                                        , text "Iface expr =" <+> ppr expr ]) }+          Nothing   -> return ()+          Just errs -> liftIO $+            displayLintResults dflags False doc+                               (pprCoreExpr core_expr') (emptyBag, errs)     return core_expr'   where     doc = ppWhen is_compulsory (text "Compulsory") <+>

@@ -0,0 +1,36 @@+module GHC.Linker+   (+   )+where++import GHC.Prelude ()+   -- We need this dummy dependency for the make build system. Otherwise it+   -- tries to load GHC.Types which may not be built yet.++-- Note [Linkers and loaders]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Linkers are used to produce linked objects (.so, executables); loaders are+-- used to link in memory (e.g., in GHCi) with the already loaded libraries+-- (ghc-lib, rts, etc.).+--+-- Linking can usually be done with an external linker program ("ld"), but+-- loading is more tricky:+--+--    * Fully dynamic:+--       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)+--       and the modules to load are also compiled for dynamic linking, a+--       solution is to fully rely on external tools:+--+--       1) link a .so with the external linker+--       2) load the .so with POSIX's "dlopen"+--+--    * When GHC is built as a static program or when libraries we want to load+--    aren't compiled for dynamic linking, GHC uses its own loader ("runtime+--    linker"). The runtime linker is part of the rts (rts/Linker.c).+--+-- Note that within GHC's codebase we often use the word "linker" to refer to+-- the static object loader in the runtime system.+--+-- Loading can be delegated to an external interpreter ("iserv") when+-- -fexternal-interpreter is used.

@@ -0,0 +1,264 @@+{-# LANGUAGE CPP #-}++-- | Dynamic linker+module GHC.Linker.Dynamic+   ( linkDynLib+   -- * Platform-specifics+   , libmLinkOpts+   )+where++#include "GhclibHsVersions.h"++import GHC.Prelude+import GHC.Platform+import GHC.Platform.Ways++import GHC.Driver.Session++import GHC.Unit.Types+import GHC.Unit.State+import GHC.Utils.Outputable+import GHC.Linker.MacOS+import GHC.Linker.Unit+import GHC.SysTools.Tasks++import qualified Data.Set as Set+import System.FilePath++linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()+linkDynLib dflags0 o_files dep_packages+ = do+    let platform = targetPlatform dflags0+        os = platformOS platform++        -- This is a rather ugly hack to fix dynamically linked+        -- GHC on Windows. If GHC is linked with -threaded, then+        -- it links against libHSrts_thr. But if base is linked+        -- against libHSrts, then both end up getting loaded,+        -- and things go wrong. We therefore link the libraries+        -- with the same RTS flags that we link GHC with.+        dflags | OSMinGW32 <- os+               , hostWays `hasWay` WayDyn+               = dflags0 { targetWays_ = hostWays }+               | otherwise+               = dflags0++        verbFlags = getVerbFlags dflags+        o_file = outputFile dflags++    pkgs_with_rts <- getPreloadUnitsAnd+               (initSDocContext dflags defaultUserStyle)+               (unitState dflags)+               (mkHomeUnitFromFlags dflags)+               dep_packages++    let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | ( osElfTarget (platformOS (targetPlatform dflags)) ||+             osMachOTarget (platformOS (targetPlatform dflags)) ) &&+           dynLibLoader dflags == SystemDependent &&+           -- Only if we want dynamic libraries+           WayDyn `Set.member` ways dflags &&+           -- Only use RPath if we explicitly asked for it+           gopt Opt_RPath dflags+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]+         | otherwise = ["-L" ++ l]++    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    -- In general we don't want to link our dynamic libs against the RTS+    -- package, because the RTS lib comes in several flavours and we want to be+    -- able to pick the flavour when a binary is linked.+    --+    -- But:+    --   * on Windows we need to link the RTS import lib as Windows does not+    --   allow undefined symbols.+    --+    --   * the RTS library path is still added to the library search path above+    --   in case the RTS is being explicitly linked in (see #3807).+    --+    --   * if -flink-rts is used, we link with the rts.+    --+    let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts+        pkgs+         | OSMinGW32 <- os         = pkgs_with_rts+         | gopt Opt_LinkRts dflags = pkgs_with_rts+         | otherwise               = pkgs_without_rts+        pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags+          where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs++        -- probably _stub.o files+        -- and last temporary shared object file+    let extra_ld_inputs = ldInputs dflags++    -- frameworks+    pkg_framework_opts <- getUnitFrameworkOpts dflags platform+                                              (map unitId pkgs)+    let framework_opts = getFrameworkOpts dflags platform++    case os of+        OSMinGW32 -> do+            -------------------------------------------------------------+            -- Making a DLL+            -------------------------------------------------------------+            let output_fn = case o_file of+                            Just s -> s+                            Nothing -> "HSdll.dll"++            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    , Option "-shared"+                    ] +++                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")+                    | gopt Opt_SharedImplib dflags+                    ]+                 ++ map (FileOption "") o_files++                 -- Permit the linker to auto link _symbol to _imp_symbol+                 -- This lets us link against DLLs without needing an "import library"+                 ++ [Option "-Wl,--enable-auto-import"]++                 ++ extra_ld_inputs+                 ++ map Option (+                    lib_path_opts+                 ++ pkg_lib_path_opts+                 ++ pkg_link_opts+                ))+        _ | os == OSDarwin -> do+            -------------------------------------------------------------------+            -- Making a darwin dylib+            -------------------------------------------------------------------+            -- About the options used for Darwin:+            -- -dynamiclib+            --   Apple's way of saying -shared+            -- -undefined dynamic_lookup:+            --   Without these options, we'd have to specify the correct+            --   dependencies for each of the dylibs. Note that we could+            --   (and should) do without this for all libraries except+            --   the RTS; all we need to do is to pass the correct+            --   HSfoo_dyn.dylib files to the link command.+            --   This feature requires Mac OS X 10.3 or later; there is+            --   a similar feature, -flat_namespace -undefined suppress,+            --   which works on earlier versions, but it has other+            --   disadvantages.+            -- -single_module+            --   Build the dynamic library as a single "module", i.e. no+            --   dynamic binding nonsense when referring to symbols from+            --   within the library. The NCG assumes that this option is+            --   specified (on i386, at least).+            -- -install_name+            --   Mac OS/X stores the path where a dynamic library is (to+            --   be) installed in the library itself.  It's called the+            --   "install name" of the library. Then any library or+            --   executable that links against it before it's installed+            --   will search for it in its ultimate install location.+            --   By default we set the install name to the absolute path+            --   at build time, but it can be overridden by the+            --   -dylib-install-name option passed to ghc. Cabal does+            --   this.+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }++            instName <- case dylibInstallName dflags of+                Just n -> return n+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)+            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-dynamiclib"+                    , Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-undefined",+                      Option "dynamic_lookup",+                      Option "-single_module" ]+                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]+                     then [ ]+                     else [ Option "-Wl,-read_only_relocs,suppress" ])+                 ++ [ Option "-install_name", Option instName ]+                 ++ map Option lib_path_opts+                 ++ extra_ld_inputs+                 ++ map Option framework_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+                 ++ map Option pkg_framework_opts+                 -- dead_strip_dylibs, will remove unused dylibs, and thus save+                 -- space in the load commands. The -headerpad is necessary so+                 -- that we can inject more @rpath's later for the leftover+                 -- libraries in the runInjectRpaths phase below.+                 --+                 -- See Note [Dynamic linking on macOS]+                 ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]+              )+            runInjectRPaths dflags pkg_lib_paths output_fn+        _ -> do+            -------------------------------------------------------------------+            -- Making a DSO+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }+                unregisterised = platformUnregisterised (targetPlatform dflags)+            let bsymbolicFlag = -- we need symbolic linking to resolve+                                -- non-PIC intra-package-relocations for+                                -- performance (where symbolic linking works)+                                -- See Note [-Bsymbolic assumptions by GHC]+                                ["-Wl,-Bsymbolic" | not unregisterised]++            runLink dflags (+                    map Option verbFlags+                 ++ libmLinkOpts+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-shared" ]+                 ++ map Option bsymbolicFlag+                    -- Set the library soname. We use -h rather than -soname as+                    -- Solaris 10 doesn't support the latter:+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]+                 ++ extra_ld_inputs+                 ++ map Option lib_path_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+              )++-- | Some platforms require that we explicitly link against @libm@ if any+-- math-y things are used (which we assume to include all programs). See #14022.+libmLinkOpts :: [Option]+libmLinkOpts =+#if defined(HAVE_LIBM)+  [Option "-lm"]+#else+  []+#endif++{-+Note [-Bsymbolic assumptions by GHC]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC has a few assumptions about interaction of relocations in NCG and linker:++1. -Bsymbolic resolves internal references when the shared library is linked,+   which is important for performance.+2. When there is a reference to data in a shared library from the main program,+   the runtime linker relocates the data object into the main program using an+   R_*_COPY relocation.+3. If we used -Bsymbolic, then this results in multiple copies of the data+   object, because some references have already been resolved to point to the+   original instance. This is bad!++We work around [3.] for native compiled code by avoiding the generation of+R_*_COPY relocations.++Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable+-Bsymbolic linking there.++See related tickets: #4210, #15338+-}

@@ -0,0 +1,260 @@+-----------------------------------------------------------------------------+--+-- GHC Extra object linking code+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------++module GHC.Linker.ExtraObj+   ( mkExtraObj+   , mkExtraObjToLinkIntoBinary+   , mkNoteObjsToLinkIntoBinary+   , checkLinkInfo+   , getLinkInfo+   , getCompilerInfo+   , ghcLinkInfoSectionName+   , ghcLinkInfoNoteName+   , platformSupportsSavingLinkOpts+   , haveRtsOptsFlags+   )+where++import GHC.Utils.Asm+import GHC.Utils.Error+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Unit.State+import GHC.Platform+import GHC.Utils.Outputable as Outputable+import GHC.Types.SrcLoc ( noSrcSpan )+import GHC.Unit+import GHC.SysTools.Elf+import GHC.Utils.Misc+import GHC.Prelude+import qualified GHC.Data.ShortText as ST++import Control.Monad+import Data.Maybe++import Control.Monad.IO.Class++import GHC.SysTools.FileCleanup+import GHC.SysTools.Tasks+import GHC.SysTools.Info+import GHC.Linker.Unit+import GHC.Linker.MacOS++mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath+mkExtraObj dflags extn xs+ = do cFile <- newTempName dflags TFL_CurrentModule extn+      oFile <- newTempName dflags TFL_GhcSession "o"+      writeFile cFile xs+      ccInfo <- liftIO $ getCompilerInfo dflags+      runCc Nothing dflags+            ([Option        "-c",+              FileOption "" cFile,+              Option        "-o",+              FileOption "" oFile]+              ++ if extn /= "s"+                    then cOpts+                    else asmOpts ccInfo)+      return oFile+    where+      pkgs = unitState dflags++      -- Pass a different set of options to the C compiler depending one whether+      -- we're compiling C or assembler. When compiling C, we pass the usual+      -- set of include directories and PIC flags.+      cOpts = map Option (picCCOpts dflags)+                    ++ map (FileOption "-I" . ST.unpack)+                            (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit)++      -- When compiling assembler code, we drop the usual C options, and if the+      -- compiler is Clang, we add an extra argument to tell Clang to ignore+      -- unused command line options. See trac #11684.+      asmOpts ccInfo =+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                then [Option "-Qunused-arguments"]+                else []++-- When linking a binary, we need to create a C main() function that+-- starts everything off.  This used to be compiled statically as part+-- of the RTS, but that made it hard to change the -rtsopts setting,+-- so now we generate and compile a main() stub as part of every+-- binary and pass the -rtsopts setting directly to the RTS (#5373)+--+-- On Windows, when making a shared library we also may need a DllMain.+--+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath+mkExtraObjToLinkIntoBinary dflags = do+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $+     putLogMsg dflags NoReason SevInfo noSrcSpan+         $ withPprStyle defaultUserStyle+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$+          text "    Call hs_init_ghc() from your main() function to set these options.")++  mkExtraObj dflags "c" (showSDoc dflags main)+  where+    main+      | gopt Opt_NoHsMain dflags = Outputable.empty+      | otherwise+          = case ghcLink dflags of+                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32+                                    then dllMain+                                    else Outputable.empty+                  _                      -> exeMain++    exeMain = vcat [+        text "#include <Rts.h>",+        text "extern StgClosure ZCMain_main_closure;",+        text "int main(int argc, char *argv[])",+        char '{',+        text " RtsConfig __conf = defaultRtsConfig;",+        text " __conf.rts_opts_enabled = "+            <> text (show (rtsOptsEnabled dflags)) <> semi,+        text " __conf.rts_opts_suggestions = "+            <> text (if rtsOptsSuggestions dflags+                        then "true"+                        else "false") <> semi,+        text "__conf.keep_cafs = "+            <> text (if gopt Opt_KeepCAFs dflags+                       then "true"+                       else "false") <> semi,+        case rtsOpts dflags of+            Nothing   -> Outputable.empty+            Just opts -> text "    __conf.rts_opts= " <>+                          text (show opts) <> semi,+        text " __conf.rts_hs_main = true;",+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",+        char '}',+        char '\n' -- final newline, to keep gcc happy+        ]++    dllMain = vcat [+        text "#include <Rts.h>",+        text "#include <windows.h>",+        text "#include <stdbool.h>",+        char '\n',+        text "bool",+        text "WINAPI",+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",+        text "        , DWORD reason STG_UNUSED",+        text "        , LPVOID reserved STG_UNUSED",+        text "        )",+        text "{",+        text "  return true;",+        text "}",+        char '\n' -- final newline, to keep gcc happy+        ]++-- Write out the link info section into a new assembly file. Previously+-- this was included as inline assembly in the main.c file but this+-- is pretty fragile. gas gets upset trying to calculate relative offsets+-- that span the .note section (notably .text) when debug info is present+mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]+mkNoteObjsToLinkIntoBinary dflags dep_packages = do+   link_info <- getLinkInfo dflags dep_packages++   if (platformSupportsSavingLinkOpts (platformOS platform ))+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))+     else return []++  where+    platform = targetPlatform dflags+    link_opts info = hcat [+      -- "link info" section (see Note [LinkInfo section])+      makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,++      -- ALL generated assembly must have this section to disable+      -- executable stacks.  See also+      -- "GHC.CmmToAsm" for another instance+      -- where we need to do this.+      if platformHasGnuNonexecStack platform+        then text ".section .note.GNU-stack,\"\","+             <> sectionType platform "progbits" <> char '\n'+        else Outputable.empty+      ]++-- | Return the "link info" string+--+-- See Note [LinkInfo section]+getLinkInfo :: DynFlags -> [UnitId] -> IO String+getLinkInfo dflags dep_packages = do+   package_link_opts <- getUnitLinkOpts dflags dep_packages+   let unit_state = unitState dflags+       home_unit  = mkHomeUnitFromFlags dflags+       ctx        = initSDocContext dflags defaultUserStyle+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)+                     then getUnitFrameworks ctx unit_state home_unit dep_packages+                     else return []+   let extra_ld_inputs = ldInputs dflags+   let+      link_info = (package_link_opts,+                   pkg_frameworks,+                   rtsOpts dflags,+                   rtsOptsEnabled dflags,+                   gopt Opt_NoHsMain dflags,+                   map showOpt extra_ld_inputs,+                   getOpts dflags opt_l)+   --+   return (show link_info)++platformSupportsSavingLinkOpts :: OS -> Bool+platformSupportsSavingLinkOpts os+ | os == OSSolaris2 = False -- see #5382+ | otherwise        = osElfTarget os++-- See Note [LinkInfo section]+ghcLinkInfoSectionName :: String+ghcLinkInfoSectionName = ".debug-ghc-link-info"+  -- if we use the ".debug" prefix, then strip will strip it by default++-- Identifier for the note (see Note [LinkInfo section])+ghcLinkInfoNoteName :: String+ghcLinkInfoNoteName = "GHC link info"++-- Returns 'False' if it was, and we can avoid linking, because the+-- previous binary was linked with "the same options".+checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool+checkLinkInfo dflags pkg_deps exe_file+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+ -- ToDo: Windows and OS X do not use the ELF binary format, so+ -- readelf does not work there.  We need to find another way to do+ -- this.+ = return False -- conservatively we should return True, but not+                -- linking in this case was the behaviour for a long+                -- time so we leave it as-is.+ | otherwise+ = do+   link_info <- getLinkInfo dflags pkg_deps+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString dflags exe_file+                          ghcLinkInfoSectionName ghcLinkInfoNoteName+   let sameLinkInfo = (Just link_info == m_exe_link_info)+   debugTraceMsg dflags 3 $ case m_exe_link_info of+     Nothing -> text "Exe link info: Not found"+     Just s+       | sameLinkInfo -> text ("Exe link info is the same")+       | otherwise    -> text ("Exe link info is different: " ++ s)+   return (not sameLinkInfo)++{- Note [LinkInfo section]+   ~~~~~~~~~~~~~~~~~~~~~~~++The "link info" is a string representing the parameters of the link. We save+this information in the binary, and the next time we link, if nothing else has+changed, we use the link info stored in the existing binary to decide whether+to re-link or not.++The "link info" string is stored in a ELF section called ".debug-ghc-link-info"+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to+not follow the specified record-based format (see #11022).++-}++haveRtsOptsFlags :: DynFlags -> Bool+haveRtsOptsFlags dflags =+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of+                                       RtsOptsSafeOnly -> False+                                       _ -> True

@@ -0,0 +1,1720 @@+{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++--+--  (c) The University of Glasgow 2002-2006++-- | The loader+--+-- This module deals with the top-level issues of dynamic linking (loading),+-- calling the object-code linker and the byte-code linker where necessary.+module GHC.Linker.Loader+   ( Loader (..)+   , LoaderState (..)+   , initLoaderState+   , uninitializedLoader+   , showLoaderState+   -- * Load & Unload+   , loadExpr+   , loadDecls+   , loadPackages+   , loadModule+   , loadCmdLineLibs+   , loadName+   , unload+   -- * LoadedEnv+   , withExtendedLoadedEnv+   , extendLoadedEnv+   , deleteFromLoadedEnv+   -- * Misc+   , extendLoadedPkgs+   )+where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways++import GHC.Driver.Phases+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr++import GHC.Tc.Utils.Monad++import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.Types+import GHCi.RemoteTypes++import GHC.Iface.Load++import GHC.ByteCode.Linker+import GHC.ByteCode.Asm+import GHC.ByteCode.Types++import GHC.SysTools+import GHC.SysTools.FileCleanup++import GHC.Types.Basic+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Unique.DSet++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error++import GHC.Unit.Finder+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.State as Packages++import qualified GHC.Data.ShortText as ST+import qualified GHC.Data.Maybe as Maybes+import GHC.Data.FastString+import GHC.Data.List.SetOps++import GHC.Linker.MacOS+import GHC.Linker.Dynamic+import GHC.Linker.Types++-- Standard libraries+import Control.Monad++import qualified Data.Set as Set+import Data.Char (isSpace)+import Data.Function ((&))+import Data.IORef+import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)+import Data.Maybe+import Control.Concurrent.MVar+import qualified Control.Monad.Catch as MC++import System.FilePath+import System.Directory+import System.IO.Unsafe+import System.Environment (lookupEnv)++#if defined(mingw32_HOST_OS)+import System.Win32.Info (getSystemDirectory)+#endif++import GHC.Utils.Exception++uninitialised :: a+uninitialised = panic "Loader not initialised"++modifyLS_ :: Loader -> (LoaderState -> IO LoaderState) -> IO ()+modifyLS_ dl f =+  modifyMVar_ (loader_state dl) (fmap pure . f . fromMaybe uninitialised)++modifyLS :: Loader -> (LoaderState -> IO (LoaderState, a)) -> IO a+modifyLS dl f =+  modifyMVar (loader_state dl) (fmapFst pure . f . fromMaybe uninitialised)+  where fmapFst f = fmap (\(x, y) -> (f x, y))++readLS :: Loader -> IO LoaderState+readLS dl =+  (fmap (fromMaybe uninitialised) . readMVar) (loader_state dl)++modifyMbLS_+  :: Loader -> (Maybe LoaderState -> IO (Maybe LoaderState)) -> IO ()+modifyMbLS_ dl f = modifyMVar_ (loader_state dl) f++emptyLS :: LoaderState+emptyLS = LoaderState+   { closure_env = emptyNameEnv+   , itbl_env    = emptyNameEnv+   , pkgs_loaded = init_pkgs+   , bcos_loaded = []+   , objs_loaded = []+   , temp_sos = []+   }+  -- Packages that don't need loading, because the compiler+  -- shares them with the interpreted program.+  --+  -- The linker's symbol table is populated with RTS symbols using an+  -- explicit list.  See rts/Linker.c for details.+  where init_pkgs = [rtsUnitId]++extendLoadedPkgs :: Loader -> [UnitId] -> IO ()+extendLoadedPkgs dl pkgs =+  modifyLS_ dl $ \s ->+      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }++extendLoadedEnv :: Loader -> [(Name,ForeignHValue)] -> IO ()+extendLoadedEnv dl new_bindings =+  modifyLS_ dl $ \pls@LoaderState{..} -> do+    let new_ce = extendClosureEnv closure_env new_bindings+    return $! pls{ closure_env = new_ce }+    -- strictness is important for not retaining old copies of the pls++deleteFromLoadedEnv :: Loader -> [Name] -> IO ()+deleteFromLoadedEnv dl to_remove =+  modifyLS_ dl $ \pls -> do+    let ce = closure_env pls+    let new_ce = delListFromNameEnv ce to_remove+    return pls{ closure_env = new_ce }++-- | Load the module containing the given Name and get its associated 'HValue'.+--+-- Throws a 'ProgramError' if loading fails or the name cannot be found.+loadName :: HscEnv -> Name -> IO ForeignHValue+loadName hsc_env name = do+  let dl = hsc_loader hsc_env+  initLoaderState hsc_env+  modifyLS dl $ \pls0 -> do+    pls <- if not (isExternalName name)+       then return pls0+       else do+         (pls', ok) <- loadDependencies hsc_env pls0 noSrcSpan+                          [nameModule name]+         if failed ok+           then throwGhcExceptionIO (ProgramError "")+           else return pls'++    case lookupNameEnv (closure_env pls) name of+      Just (_,aa) -> return (pls,aa)+      Nothing     -> ASSERT2(isExternalName name, ppr name)+                     do let sym_to_find = nameToCLabel name "closure"+                        m <- lookupClosure hsc_env (unpackFS sym_to_find)+                        r <- case m of+                          Just hvref -> mkFinalizedHValue hsc_env hvref+                          Nothing -> linkFail "GHC.Linker.Loader.loadName"+                                       (unpackFS sym_to_find)+                        return (pls,r)++loadDependencies :: HscEnv -> LoaderState+                 -> SrcSpan -> [Module]+                 -> IO (LoaderState, SuccessFlag)+loadDependencies hsc_env pls span needed_mods = do+--   initLoaderState (hsc_dflags hsc_env) dl+   let hpt = hsc_HPT hsc_env+   -- The interpreter and dynamic linker can only handle object code built+   -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.+   -- So here we check the build tag: if we're building a non-standard way+   -- then we need to find & link object files built the "normal" way.+   maybe_normal_osuf <- checkNonStdWay hsc_env span++   -- Find what packages and linkables are required+   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls+                               maybe_normal_osuf span needed_mods++   -- Link the packages and modules required+   pls1 <- loadPackages' hsc_env pkgs pls+   loadModules hsc_env pls1 lnks+++-- | Temporarily extend the loaded env.++withExtendedLoadedEnv :: (ExceptionMonad m) =>+                       Loader -> [(Name,ForeignHValue)] -> m a -> m a+withExtendedLoadedEnv dl new_env action+    = MC.bracket (liftIO $ extendLoadedEnv dl new_env)+               (\_ -> reset_old_env)+               (\_ -> action)+    where+        -- Remember that the linker state might be side-effected+        -- during the execution of the IO action, and we don't want to+        -- lose those changes (we might have linked a new module or+        -- package), so the reset action only removes the names we+        -- added earlier.+          reset_old_env = liftIO $+            modifyLS_ dl $ \pls ->+                let cur = closure_env pls+                    new = delListFromNameEnv cur (map fst new_env)+                in return pls{ closure_env = new }+++-- | Display the persistent linker state.+showLoaderState :: Loader -> IO SDoc+showLoaderState dl+  = do pls <- readLS dl+       return $ withPprStyle defaultDumpStyle+                 (vcat [text "----- Loader state -----",+                        text "Pkgs:" <+> ppr (pkgs_loaded pls),+                        text "Objs:" <+> ppr (objs_loaded pls),+                        text "BCOs:" <+> ppr (bcos_loaded pls)])+++{- **********************************************************************++                        Initialisation++  ********************************************************************* -}++-- | Initialise the dynamic linker.  This entails+--+--  a) Calling the C initialisation procedure,+--+--  b) Loading any packages specified on the command line,+--+--  c) Loading any packages specified on the command line, now held in the+--     @-l@ options in @v_Opt_l@,+--+--  d) Loading any @.o\/.dll@ files specified on the command line, now held+--     in @ldInputs@,+--+--  e) Loading any MacOS frameworks.+--+-- NOTE: This function is idempotent; if called more than once, it does+-- nothing.  This is useful in Template Haskell, where we call it before+-- trying to link.+--+initLoaderState :: HscEnv -> IO ()+initLoaderState hsc_env = do+  let dl = hsc_loader hsc_env+  modifyMbLS_ dl $ \pls -> do+    case pls of+      Just  _ -> return pls+      Nothing -> Just <$> reallyInitLoaderState hsc_env++reallyInitLoaderState :: HscEnv -> IO LoaderState+reallyInitLoaderState hsc_env = do+  -- Initialise the linker state+  let dflags = hsc_dflags hsc_env+      pls0 = emptyLS++  -- (a) initialise the C dynamic linker+  initObjLinker hsc_env++  -- (b) Load packages from the command-line (Note [preload packages])+  pls <- loadPackages' hsc_env (preloadUnits (unitState dflags)) pls0++  -- steps (c), (d) and (e)+  loadCmdLineLibs' hsc_env pls+++loadCmdLineLibs :: HscEnv -> IO ()+loadCmdLineLibs hsc_env = do+  let dl = hsc_loader hsc_env+  initLoaderState hsc_env+  modifyLS_ dl $ \pls ->+    loadCmdLineLibs' hsc_env pls++loadCmdLineLibs' :: HscEnv -> LoaderState -> IO LoaderState+loadCmdLineLibs' hsc_env pls =+  do+      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs+                           , libraryPaths = lib_paths_base})+            = hsc_dflags hsc_env++      -- (c) Link libraries from the command-line+      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]++      -- On Windows we want to add libpthread by default just as GCC would.+      -- However because we don't know the actual name of pthread's dll we+      -- need to defer this to the locateLib call so we can't initialize it+      -- inside of the rts. Instead we do it here to be able to find the+      -- import library for pthreads. See #13210.+      let platform = targetPlatform dflags+          os       = platformOS platform+          minus_ls = case os of+                       OSMinGW32 -> "pthread" : minus_ls_1+                       _         -> minus_ls_1+      -- See Note [Fork/Exec Windows]+      gcc_paths <- getGCCPaths dflags os++      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base++      maybePutStrLn dflags "Search directories (user):"+      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)+      maybePutStrLn dflags "Search directories (gcc):"+      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)++      libspecs+        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls++      -- (d) Link .o files from the command-line+      classified_ld_inputs <- mapM (classifyLdInput dflags)+                                [ f | FileOption _ f <- cmdline_ld_inputs ]++      -- (e) Link any MacOS frameworks+      let platform = targetPlatform dflags+      let (framework_paths, frameworks) =+            if platformUsesFrameworks platform+             then (frameworkPaths dflags, cmdlineFrameworks dflags)+              else ([],[])++      -- Finally do (c),(d),(e)+      let cmdline_lib_specs = catMaybes classified_ld_inputs+                           ++ libspecs+                           ++ map Framework frameworks+      if null cmdline_lib_specs+         then return pls+         else do+           -- Add directories to library search paths, this only has an effect+           -- on Windows. On Unix OSes this function is a NOP.+           let all_paths = let paths = takeDirectory (pgm_c dflags)+                                     : framework_paths+                                    ++ lib_paths_base+                                    ++ [ takeDirectory dll | DLLPath dll <- libspecs ]+                           in nub $ map normalise paths+           let lib_paths = nub $ lib_paths_base ++ gcc_paths+           all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths+           pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env++           let merged_specs = mergeStaticObjects cmdline_lib_specs+           pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls+                         merged_specs++           maybePutStr dflags "final link ... "+           ok <- resolveObjs hsc_env++           -- DLLs are loaded, reset the search paths+           mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache++           if succeeded ok then maybePutStrLn dflags "done"+           else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")++           return pls1++-- | Merge runs of consecutive of 'Objects'. This allows for resolution of+-- cyclic symbol references when dynamically linking. Specifically, we link+-- together all of the static objects into a single shared object, avoiding+-- the issue we saw in #13786.+mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]+mergeStaticObjects specs = go [] specs+  where+    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]+    go accum (Objects objs : rest) = go (objs ++ accum) rest+    go accum@(_:_) rest = Objects (reverse accum) : go [] rest+    go [] (spec:rest) = spec : go [] rest+    go [] [] = []++{- Note [preload packages]++Why do we need to preload packages from the command line?  This is an+explanation copied from #2437:++I tried to implement the suggestion from #3560, thinking it would be+easy, but there are two reasons we link in packages eagerly when they+are mentioned on the command line:++  * So that you can link in extra object files or libraries that+    depend on the packages. e.g. ghc -package foo -lbar where bar is a+    C library that depends on something in foo. So we could link in+    foo eagerly if and only if there are extra C libs or objects to+    link in, but....++  * Haskell code can depend on a C function exported by a package, and+    the normal dependency tracking that TH uses can't know about these+    dependencies. The test ghcilink004 relies on this, for example.++I conclude that we need two -package flags: one that says "this is a+package I want to make available", and one that says "this is a+package I want to link in eagerly". Would that be too complicated for+users?+-}++classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)+classifyLdInput dflags f+  | isObjectFilename platform f = return (Just (Objects [f]))+  | isDynLibFilename platform f = return (Just (DLLPath f))+  | otherwise          = do+        putLogMsg dflags NoReason SevInfo noSrcSpan+            $ withPprStyle defaultUserStyle+            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))+        return Nothing+    where platform = targetPlatform dflags++preloadLib+  :: HscEnv -> [String] -> [String] -> LoaderState+  -> LibrarySpec -> IO LoaderState+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do+  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")+  case lib_spec of+    Objects static_ishs -> do+      (b, pls1) <- preload_statics lib_paths static_ishs+      maybePutStrLn dflags (if b  then "done" else "not found")+      return pls1++    Archive static_ish -> do+      b <- preload_static_archive lib_paths static_ish+      maybePutStrLn dflags (if b  then "done" else "not found")+      return pls++    DLL dll_unadorned -> do+      maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned)+      case maybe_errstr of+         Nothing -> maybePutStrLn dflags "done"+         Just mm | platformOS platform /= OSDarwin ->+           preloadFailed mm lib_paths lib_spec+         Just mm | otherwise -> do+           -- As a backup, on Darwin, try to also load a .so file+           -- since (apparently) some things install that way - see+           -- ticket #8770.+           let libfile = ("lib" ++ dll_unadorned) <.> "so"+           err2 <- loadDLL hsc_env libfile+           case err2 of+             Nothing -> maybePutStrLn dflags "done"+             Just _  -> preloadFailed mm lib_paths lib_spec+      return pls++    DLLPath dll_path -> do+      do maybe_errstr <- loadDLL hsc_env dll_path+         case maybe_errstr of+            Nothing -> maybePutStrLn dflags "done"+            Just mm -> preloadFailed mm lib_paths lib_spec+         return pls++    Framework framework ->+      if platformUsesFrameworks (targetPlatform dflags)+      then do maybe_errstr <- loadFramework hsc_env framework_paths framework+              case maybe_errstr of+                 Nothing -> maybePutStrLn dflags "done"+                 Just mm -> preloadFailed mm framework_paths lib_spec+              return pls+      else throwGhcExceptionIO (ProgramError "preloadLib Framework")++  where+    dflags = hsc_dflags hsc_env++    platform = targetPlatform dflags++    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()+    preloadFailed sys_errmsg paths spec+       = do maybePutStr dflags "failed.\n"+            throwGhcExceptionIO $+              CmdLineError (+                    "user specified .o/.so/.DLL could not be loaded ("+                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "+                    ++ showLS spec ++ "\nAdditional directories searched:"+                    ++ (if null paths then " (none)" else+                        intercalate "\n" (map ("   "++) paths)))++    -- Not interested in the paths in the static case.+    preload_statics _paths names+       = do b <- or <$> mapM doesFileExist names+            if not b then return (False, pls)+                     else if hostIsDynamic+                             then  do pls1 <- dynLoadObjs hsc_env pls names+                                      return (True, pls1)+                             else  do mapM_ (loadObj hsc_env) names+                                      return (True, pls)++    preload_static_archive _paths name+       = do b <- doesFileExist name+            if not b then return False+                     else do if hostIsDynamic+                                 then throwGhcExceptionIO $+                                      CmdLineError dynamic_msg+                                 else loadArchive hsc_env name+                             return True+      where+        dynamic_msg = unlines+          [ "User-specified static library could not be loaded ("+            ++ name ++ ")"+          , "Loading static libraries is not supported in this configuration."+          , "Try using a dynamic library instead."+          ]+++{- **********************************************************************++                        Link a byte-code expression++  ********************************************************************* -}++-- | Load a single expression, /including/ first loading packages and+-- modules that this expression depends on.+--+-- Raises an IO exception ('ProgramError') if it can't find a compiled+-- version of the dependents to load.+--+loadExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue+loadExpr hsc_env span root_ul_bco+  = do {+     -- Initialise the linker (if it's not been done already)+   ; initLoaderState hsc_env++     -- Extract the Loader value for passing into required places+   ; let dl = hsc_loader hsc_env++     -- Take lock for the actual work.+   ; modifyLS dl $ \pls0 -> do {++     -- Load the packages and modules required+   ; (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods+   ; if failed ok then+        throwGhcExceptionIO (ProgramError "")+     else do {++     -- Load the expression itself+     let ie = itbl_env pls+         ce = closure_env pls++     -- Load the necessary packages and linkables++   ; let nobreakarray = error "no break array"+         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]+   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco+   ; [root_hvref] <- createBCOs hsc_env [resolved]+   ; fhv <- mkFinalizedHValue hsc_env root_hvref+   ; return (pls, fhv)+   }}}+   where+     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)++     needed_mods :: [Module]+     needed_mods = [ nameModule n | n <- free_names,+                     isExternalName n,      -- Names from other modules+                     not (isWiredInName n)  -- Exclude wired-in names+                   ]                        -- (see note below)+        -- Exclude wired-in names because we may not have read+        -- their interface files, so getLinkDeps will fail+        -- All wired-in names are in the base package, which we link+        -- by default, so we can safely ignore them here.++dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))+++checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath)+checkNonStdWay hsc_env srcspan+  | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing+    -- with -fexternal-interpreter we load the .o files, whatever way+    -- they were built.  If they were built for a non-std way, then+    -- we will use the appropriate variant of the iserv binary to load them.++  | hostFullWays == targetFullWays = return Nothing+    -- Only if we are compiling with the same ways as GHC is built+    -- with, can we dynamically load those object files. (see #3604)++  | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays)+  = failNonStd (hsc_dflags hsc_env) srcspan++  | otherwise = return (Just (hostWayTag ++ "o"))+  where+    targetFullWays = fullWays (ways (hsc_dflags hsc_env))+    hostWayTag = case waysTag hostFullWays of+                  "" -> ""+                  tag -> tag ++ "_"++normalObjectSuffix :: String+normalObjectSuffix = phaseInputExt StopLn++failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)+failNonStd dflags srcspan = dieWith dflags srcspan $+  text "Cannot load" <+> compWay <+>+     text "objects when GHC is built" <+> ghciWay $$+  text "To fix this, either:" $$+  text "  (1) Use -fexternal-interpreter, or" $$+  text "  (2) Build the program twice: once" <+>+                       ghciWay <> text ", and then" $$+  text "      with" <+> compWay <+>+     text "using -osuf to set a different object file suffix."+    where compWay+            | WayDyn `elem` ways dflags = text "-dynamic"+            | WayProf `elem` ways dflags = text "-prof"+            | otherwise = text "normal"+          ghciWay+            | hostIsDynamic = text "with -dynamic"+            | hostIsProfiled = text "with -prof"+            | otherwise = text "the normal way"++getLinkDeps :: HscEnv -> HomePackageTable+            -> LoaderState+            -> Maybe FilePath                   -- replace object suffices?+            -> SrcSpan                          -- for error messages+            -> [Module]                         -- If you need these+            -> IO ([Linkable], [UnitId])     -- ... then link these first+-- Fails with an IO exception if it can't find enough files++getLinkDeps hsc_env hpt pls replace_osuf span mods+-- Find all the packages and linkables that a set of modules depends on+ = do {+        -- 1.  Find the dependent home-pkg-modules/packages from each iface+        -- (omitting modules from the interactive package, which is already linked)+      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)+                                        emptyUniqDSet emptyUniqDSet;++      ; let {+        -- 2.  Exclude ones already linked+        --      Main reason: avoid findModule calls in get_linkable+            mods_needed = mods_s `minusList` linked_mods     ;+            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;++            linked_mods = map (moduleName.linkableModule)+                                (objs_loaded pls ++ bcos_loaded pls)  }++        -- 3.  For each dependent module, find its linkable+        --     This will either be in the HPT or (in the case of one-shot+        --     compilation) we may need to use maybe_getFileLinkable+      ; let { osuf = objectSuf dflags }+      ; lnks_needed <- mapM (get_linkable osuf) mods_needed++      ; return (lnks_needed, pkgs_needed) }+  where+    dflags = hsc_dflags hsc_env++        -- The ModIface contains the transitive closure of the module dependencies+        -- within the current package, *except* for boot modules: if we encounter+        -- a boot module, we have to find its real interface and discover the+        -- dependencies of that.  Hence we need to traverse the dependency+        -- tree recursively.  See bug #936, testcase ghci/prog007.+    follow_deps :: [Module]             -- modules to follow+                -> UniqDSet ModuleName         -- accum. module dependencies+                -> UniqDSet UnitId          -- accum. package dependencies+                -> IO ([ModuleName], [UnitId]) -- result+    follow_deps []     acc_mods acc_pkgs+        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+    follow_deps (mod:mods) acc_mods acc_pkgs+        = do+          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $+                        loadInterface msg mod (ImportByUser NotBoot)+          iface <- case mb_iface of+                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))+                    Maybes.Succeeded iface -> return iface++          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod++          let+            pkg = moduleUnit mod+            deps  = mi_deps iface+            home_unit = hsc_home_unit hsc_env++            pkg_deps = dep_pkgs deps+            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $+              \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->+                m & case is_boot of+                  IsBoot -> Left+                  NotBoot -> Right++            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps+            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)+            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps+          --+          if not (isHomeUnit home_unit pkg)+             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))+             else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods)+                              acc_mods' acc_pkgs'+        where+            msg = text "need to link module" <+> ppr mod <+>+                  text "due to use of Template Haskell"+++    link_boot_mod_error mod =+        throwGhcExceptionIO (ProgramError (showSDoc dflags (+            text "module" <+> ppr mod <+>+            text "cannot be linked; it is only available as a boot module")))++    no_obj :: Outputable a => a -> IO b+    no_obj mod = dieWith dflags span $+                     text "cannot find object file for module " <>+                        quotes (ppr mod) $$+                     while_linking_expr++    while_linking_expr = text "while linking an interpreted expression"++        -- This one is a build-system bug++    get_linkable osuf mod_name      -- A home-package module+        | Just mod_info <- lookupHpt hpt mod_name+        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))+        | otherwise+        = do    -- It's not in the HPT because we are in one shot mode,+                -- so use the Finder to get a ModLocation...+             mb_stuff <- findHomeModule hsc_env mod_name+             case mb_stuff of+                  Found loc mod -> found loc mod+                  _ -> no_obj mod_name+        where+            found loc mod = do {+                -- ...and then find the linkable for it+               mb_lnk <- findObjectLinkableMaybe mod loc ;+               case mb_lnk of {+                  Nothing  -> no_obj mod ;+                  Just lnk -> adjust_linkable lnk+              }}++            adjust_linkable lnk+                | Just new_osuf <- replace_osuf = do+                        new_uls <- mapM (adjust_ul new_osuf)+                                        (linkableUnlinked lnk)+                        return lnk{ linkableUnlinked=new_uls }+                | otherwise =+                        return lnk++            adjust_ul new_osuf (DotO file) = do+                MASSERT(osuf `isSuffixOf` file)+                let file_base = fromJust (stripExtension osuf file)+                    new_file = file_base <.> new_osuf+                ok <- doesFileExist new_file+                if (not ok)+                   then dieWith dflags span $+                          text "cannot find object file "+                                <> quotes (text new_file) $$ while_linking_expr+                   else return (DotO new_file)+            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)+            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)+            adjust_ul _ l@(BCOs {}) = return l++++{- **********************************************************************++              Loading a Decls statement++  ********************************************************************* -}++loadDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()+loadDecls hsc_env span cbc@CompiledByteCode{..} = do+    -- Initialise the linker (if it's not been done already)+    initLoaderState hsc_env++    -- Extract the Loader for passing into required places+    let dl = hsc_loader hsc_env++    -- Take lock for the actual work.+    modifyLS_ dl $ \pls0 -> do+      -- Link the packages and modules required+      (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods+      if failed ok+        then throwGhcExceptionIO (ProgramError "")+        else do+          -- Link the expression itself+          let ie = plusNameEnv (itbl_env pls) bc_itbls+              ce = closure_env pls++          -- Link the necessary packages and linkables+          new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]+          nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings+          let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs+                         , itbl_env    = ie }+          return pls2+  where+    free_names = uniqDSetToList $+      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos++    needed_mods :: [Module]+    needed_mods = [ nameModule n | n <- free_names,+                    isExternalName n,       -- Names from other modules+                    not (isWiredInName n)   -- Exclude wired-in names+                  ]                         -- (see note below)+    -- Exclude wired-in names because we may not have read+    -- their interface files, so getLinkDeps will fail+    -- All wired-in names are in the base package, which we link+    -- by default, so we can safely ignore them here.++{- **********************************************************************++              Loading a single module++  ********************************************************************* -}++loadModule :: HscEnv -> Module -> IO ()+loadModule hsc_env mod = do+  initLoaderState hsc_env+  let dl = hsc_loader hsc_env+  modifyLS_ dl $ \pls -> do+    (pls', ok) <- loadDependencies hsc_env pls noSrcSpan [mod]+    if failed ok+      then throwGhcExceptionIO (ProgramError "could not load module")+      else return pls'++{- **********************************************************************++                Link some linkables+        The linkables may consist of a mixture of+        byte-code modules and object modules++  ********************************************************************* -}++loadModules :: HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)+loadModules hsc_env pls linkables+  = mask_ $ do  -- don't want to be interrupted by ^C in here++        let (objs, bcos) = partition isObjectLinkable+                              (concatMap partitionLinkable linkables)++                -- Load objects first; they can't depend on BCOs+        (pls1, ok_flag) <- loadObjects hsc_env pls objs++        if failed ok_flag then+                return (pls1, Failed)+          else do+                pls2 <- dynLinkBCOs hsc_env pls1 bcos+                return (pls2, Succeeded)+++-- HACK to support f-x-dynamic in the interpreter; no other purpose+partitionLinkable :: Linkable -> [Linkable]+partitionLinkable li+   = let li_uls = linkableUnlinked li+         li_uls_obj = filter isObject li_uls+         li_uls_bco = filter isInterpretable li_uls+     in+         case (li_uls_obj, li_uls_bco) of+            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},+                           li {linkableUnlinked=li_uls_bco}]+            _ -> [li]++findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable+findModuleLinkable_maybe lis mod+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of+        []   -> Nothing+        [li] -> Just li+        _    -> pprPanic "findModuleLinkable" (ppr mod)++linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet l objs_loaded =+  case findModuleLinkable_maybe objs_loaded (linkableModule l) of+        Nothing -> False+        Just m  -> linkableTime l == linkableTime m+++{- **********************************************************************++                The object-code linker++  ********************************************************************* -}++-- | Load the object files and link them+--+-- If the interpreter uses dynamic-linking, build a shared library and load it.+-- Otherwise, use the RTS linker.+loadObjects :: HscEnv -> LoaderState -> [Linkable]+            -> IO (LoaderState, SuccessFlag)+loadObjects hsc_env pls objs = do+        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs+            pls1                     = pls { objs_loaded = objs_loaded' }+            unlinkeds                = concatMap linkableUnlinked new_objs+            wanted_objs              = map nameOfObject unlinkeds++        if interpreterDynamic (hscInterp hsc_env)+            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs+                    return (pls2, Succeeded)+            else do mapM_ (loadObj hsc_env) wanted_objs++                    -- Link them all together+                    ok <- resolveObjs hsc_env++                    -- If resolving failed, unload all our+                    -- object modules and carry on+                    if succeeded ok then+                            return (pls1, Succeeded)+                      else do+                            pls2 <- unload_wkr hsc_env [] pls1+                            return (pls2, Failed)+++-- | Create a shared library containing the given object files and load it.+dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState+dynLoadObjs _       pls                           []   = return pls+dynLoadObjs hsc_env pls@LoaderState{..} objs = do+    let dflags = hsc_dflags hsc_env+    let platform = targetPlatform dflags+    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]+    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]+    (soFile, libPath , libName) <-+      newTempLibName dflags TFL_CurrentModule (platformSOExt platform)+    let+        dflags2 = dflags {+                      -- We don't want the original ldInputs in+                      -- (they're already linked in), but we do want+                      -- to link against previous dynLoadObjs+                      -- libraries if there were any, so that the linker+                      -- can resolve dependencies when it loads this+                      -- library.+                      ldInputs =+                           concatMap (\l -> [ Option ("-l" ++ l) ])+                                     (nub $ snd <$> temp_sos)+                        ++ concatMap (\lp -> Option ("-L" ++ lp)+                                          : if gopt Opt_RPath dflags+                                            then [ Option "-Xlinker"+                                                 , Option "-rpath"+                                                 , Option "-Xlinker"+                                                 , Option lp ]+                                            else [])+                                     (nub $ fst <$> temp_sos)+                        ++ concatMap+                             (\lp -> Option ("-L" ++ lp)+                                  : if gopt Opt_RPath dflags+                                    then [ Option "-Xlinker"+                                         , Option "-rpath"+                                         , Option "-Xlinker"+                                         , Option lp ]+                                    else [])+                             minus_big_ls+                        -- See Note [-Xlinker -rpath vs -Wl,-rpath]+                        ++ map (\l -> Option ("-l" ++ l)) minus_ls,+                      -- Add -l options and -L options from dflags.+                      --+                      -- When running TH for a non-dynamic way, we still+                      -- need to make -l flags to link against the dynamic+                      -- libraries, so we need to add WayDyn to ways.+                      --+                      -- Even if we're e.g. profiling, we still want+                      -- the vanilla dynamic libraries, so we set the+                      -- ways / build tag to be just WayDyn.+                      targetWays_ = Set.singleton WayDyn,+                      outputFile_ = Just soFile+                  }+    -- link all "loaded packages" so symbols in those can be resolved+    -- Note: We are loading packages with local scope, so to see the+    -- symbols in this link we must link all loaded packages again.+    linkDynLib dflags2 objs pkgs_loaded++    -- if we got this far, extend the lifetime of the library file+    changeTempFilesLifetime dflags TFL_GhcSession [soFile]+    m <- loadDLL hsc_env soFile+    case m of+        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }+        Just err -> linkFail msg err+  where+    msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"++rmDupLinkables :: [Linkable]    -- Already loaded+               -> [Linkable]    -- New linkables+               -> ([Linkable],  -- New loaded set (including new ones)+                   [Linkable])  -- New linkables (excluding dups)+rmDupLinkables already ls+  = go already [] ls+  where+    go already extras [] = (already, extras)+    go already extras (l:ls)+        | linkableInSet l already = go already     extras     ls+        | otherwise               = go (l:already) (l:extras) ls++{- **********************************************************************++                The byte-code linker++  ********************************************************************* -}+++dynLinkBCOs :: HscEnv -> LoaderState -> [Linkable] -> IO LoaderState+dynLinkBCOs hsc_env pls bcos = do++        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos+            pls1                     = pls { bcos_loaded = bcos_loaded' }+            unlinkeds :: [Unlinked]+            unlinkeds                = concatMap linkableUnlinked new_bcos++            cbcs :: [CompiledByteCode]+            cbcs      = map byteCodeOfObject unlinkeds+++            ies        = map bc_itbls cbcs+            gce       = closure_env pls+            final_ie  = foldr plusNameEnv (itbl_env pls) ies++        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs++        -- We only want to add the external ones to the ClosureEnv+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs++        -- Immediately release any HValueRefs we're not going to add+        freeHValueRefs hsc_env (map snd to_drop)+        -- Wrap finalizers on the ones we want to keep+        new_binds <- makeForeignNamedHValueRefs hsc_env to_add++        return pls1 { closure_env = extendClosureEnv gce new_binds,+                      itbl_env    = final_ie }++-- Link a bunch of BCOs and return references to their values+linkSomeBCOs :: HscEnv+             -> ItblEnv+             -> ClosureEnv+             -> [CompiledByteCode]+             -> IO [(Name,HValueRef)]+                        -- The returned HValueRefs are associated 1-1 with+                        -- the incoming unlinked BCOs.  Each gives the+                        -- value of the corresponding unlinked BCO++linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []+ where+  fun CompiledByteCode{..} inner accum =+    case bc_breaks of+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->+                   inner ((breakarray, bc_bcos) : accum)++  do_link [] = return []+  do_link mods = do+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]+        names = map (unlinkedBCOName . snd) flat+        bco_ix = mkNameEnv (zip names [0..])+    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco+                         | (breakarray, bco) <- flat ]+    hvrefs <- createBCOs hsc_env resolved+    return (zip names hvrefs)++-- | Useful to apply to the result of 'linkSomeBCOs'+makeForeignNamedHValueRefs+  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]+makeForeignNamedHValueRefs hsc_env bindings =+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings++{- **********************************************************************++                Unload some object modules++  ********************************************************************* -}++-- ---------------------------------------------------------------------------+-- | Unloading old objects ready for a new compilation sweep.+--+-- The compilation manager provides us with a list of linkables that it+-- considers \"stable\", i.e. won't be recompiled this time around.  For+-- each of the modules current linked in memory,+--+--   * if the linkable is stable (and it's the same one -- the user may have+--     recompiled the module on the side), we keep it,+--+--   * otherwise, we unload it.+--+--   * we also implicitly unload all temporary bindings at this point.+--+unload :: HscEnv+       -> [Linkable] -- ^ The linkables to *keep*.+       -> IO ()+unload hsc_env linkables+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here++        -- Initialise the linker (if it's not been done already)+        initLoaderState hsc_env++        -- Extract Loader for passing into required places+        let dl = hsc_loader hsc_env++        new_pls+            <- modifyLS dl $ \pls -> do+                 pls1 <- unload_wkr hsc_env linkables pls+                 return (pls1, pls1)++        let dflags = hsc_dflags hsc_env+        debugTraceMsg dflags 3 $+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)+        debugTraceMsg dflags 3 $+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+        return ()++unload_wkr :: HscEnv+           -> [Linkable]                -- stable linkables+           -> LoaderState+           -> IO LoaderState+-- Does the core unload business+-- (the wrapper blocks exceptions and deals with the LS get and put)++unload_wkr hsc_env keep_linkables pls@LoaderState{..}  = do+  -- NB. careful strictness here to avoid keeping the old LS when+  -- we're unloading some code.  -fghci-leak-check with the tests in+  -- testsuite/ghci can detect space leaks here.++  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables++      discard keep l = not (linkableInSet l keep)++      (objs_to_unload, remaining_objs_loaded) =+         partition (discard objs_to_keep) objs_loaded+      (bcos_to_unload, remaining_bcos_loaded) =+         partition (discard bcos_to_keep) bcos_loaded++  mapM_ unloadObjs objs_to_unload+  mapM_ unloadObjs bcos_to_unload++  -- If we unloaded any object files at all, we need to purge the cache+  -- of lookupSymbol results.+  when (not (null (objs_to_unload +++                   filter (not . null . linkableObjs) bcos_to_unload))) $+    purgeLookupSymbolCache hsc_env++  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded++      -- Note that we want to remove all *local*+      -- (i.e. non-isExternal) names too (these are the+      -- temporary bindings from the command line).+      keep_name :: (Name, a) -> Bool+      keep_name (n,_) = isExternalName n &&+                        nameModule n `elemModuleSet` bcos_retained++      itbl_env'     = filterNameEnv keep_name itbl_env+      closure_env'  = filterNameEnv keep_name closure_env++      !new_pls = pls { itbl_env = itbl_env',+                       closure_env = closure_env',+                       bcos_loaded = remaining_bcos_loaded,+                       objs_loaded = remaining_objs_loaded }++  return new_pls+  where+    unloadObjs :: Linkable -> IO ()+    unloadObjs lnk+        -- The RTS's PEi386 linker currently doesn't support unloading.+      | isWindowsHost = return ()++      | hostIsDynamic = return ()+        -- We don't do any cleanup when linking objects with the+        -- dynamic linker.  Doing so introduces extra complexity for+        -- not much benefit.++      | otherwise+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]+                -- The components of a BCO linkable may contain+                -- dot-o files.  Which is very confusing.+                --+                -- But the BCO parts can be unlinked just by+                -- letting go of them (plus of course depopulating+                -- the symbol table which is done in the main body)++{- **********************************************************************++                Loading packages++  ********************************************************************* -}++data LibrarySpec+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o+                        -- We allow batched loading to ensure that cyclic symbol+                        -- references can be resolved (see #13786).+                        -- For dynamic objects only, try to find the object+                        -- file in all the directories specified in+                        -- v_Library_paths before giving up.++   | Archive FilePath   -- Full path name of a .a file, including trailing .a++   | DLL String         -- "Unadorned" name of a .DLL/.so+                        --  e.g.    On unix     "qt"  denotes "libqt.so"+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL+                        --  suffixes platform-dependently++   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library+                        -- (ends with .dll or .so).++   | Framework String   -- Only used for darwin, but does no harm++instance Outputable LibrarySpec where+  ppr (Objects objs) = text "Objects" <+> ppr objs+  ppr (Archive a) = text "Archive" <+> text a+  ppr (DLL s) = text "DLL" <+> text s+  ppr (DLLPath f) = text "DLLPath" <+> text f+  ppr (Framework s) = text "Framework" <+> text s++-- If this package is already part of the GHCi binary, we'll already+-- have the right DLLs for this package loaded, so don't try to+-- load them again.+--+-- But on Win32 we must load them 'again'; doing so is a harmless no-op+-- as far as the loader is concerned, but it does initialise the list+-- of DLL handles that rts/Linker.c maintains, and that in turn is+-- used by lookupSymbol.  So we must call addDLL for each library+-- just to get the DLL handle into the list.+partOfGHCi :: [PackageName]+partOfGHCi+ | isWindowsHost || isDarwinHost = []+ | otherwise = map (PackageName . mkFastString)+                   ["base", "template-haskell", "editline"]++showLS :: LibrarySpec -> String+showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"+showLS (Archive nm)   = "(static archive) " ++ nm+showLS (DLL nm)       = "(dynamic) " ++ nm+showLS (DLLPath nm)   = "(dynamic) " ++ nm+showLS (Framework nm) = "(framework) " ++ nm++-- | Load exactly the specified packages, and their dependents (unless of+-- course they are already loaded).  The dependents are loaded+-- automatically, and it doesn't matter what order you specify the input+-- packages.+--+loadPackages :: HscEnv -> [UnitId] -> IO ()+-- NOTE: in fact, since each module tracks all the packages it depends on,+--       we don't really need to use the package-config dependencies.+--+-- However we do need the package-config stuff (to find aux libs etc),+-- and following them lets us load libraries in the right order, which+-- perhaps makes the error message a bit more localised if we get a link+-- failure.  So the dependency walking code is still here.++loadPackages hsc_env new_pkgs = do+  -- It's probably not safe to try to load packages concurrently, so we take+  -- a lock.+  initLoaderState hsc_env+  let dl = hsc_loader hsc_env+  modifyLS_ dl $ \pls ->+    loadPackages' hsc_env new_pkgs pls++loadPackages' :: HscEnv -> [UnitId] -> LoaderState -> IO LoaderState+loadPackages' hsc_env new_pks pls = do+    pkgs' <- link (pkgs_loaded pls) new_pks+    return $! pls { pkgs_loaded = pkgs' }+  where+     dflags = hsc_dflags hsc_env+     pkgstate = unitState dflags++     link :: [UnitId] -> [UnitId] -> IO [UnitId]+     link pkgs new_pkgs =+         foldM link_one pkgs new_pkgs++     link_one pkgs new_pkg+        | new_pkg `elem` pkgs   -- Already linked+        = return pkgs++        | Just pkg_cfg <- lookupUnitId pkgstate new_pkg+        = do {  -- Link dependents first+               pkgs' <- link pkgs (unitDepends pkg_cfg)+                -- Now link the package itself+             ; loadPackage hsc_env pkg_cfg+             ; return (new_pkg : pkgs') }++        | otherwise+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))+++loadPackage :: HscEnv -> UnitInfo -> IO ()+loadPackage hsc_env pkg+   = do+        let dflags    = hsc_dflags hsc_env+            platform  = targetPlatform dflags+            is_dyn    = interpreterDynamic (hscInterp hsc_env)+            dirs | is_dyn    = map ST.unpack $ Packages.unitLibraryDynDirs pkg+                 | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg++        let hs_libs   = map ST.unpack $ Packages.unitLibraries pkg+            -- The FFI GHCi import lib isn't needed as+            -- GHC.Linker.Loader + rts/Linker.c link the+            -- interpreted references to FFI to the compiled FFI.+            -- We therefore filter it out so that we don't get+            -- duplicate symbol errors.+            hs_libs'  =  filter ("HSffi" /=) hs_libs++        -- Because of slight differences between the GHC dynamic linker and+        -- the native system linker some packages have to link with a+        -- different list of libraries when using GHCi. Examples include: libs+        -- that are actually gnu ld scripts, and the possibility that the .a+        -- libs do not exactly match the .so/.dll equivalents. So if the+        -- package file provides an "extra-ghci-libraries" field then we use+        -- that instead of the "extra-libraries" field.+            extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)+                                      then Packages.unitExtDepLibsSys pkg+                                      else Packages.unitExtDepLibsGhc pkg)+            linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]+            extra_libs = extdeplibs ++ linkerlibs++        -- See Note [Fork/Exec Windows]+        gcc_paths <- getGCCPaths dflags (platformOS platform)+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs++        hs_classifieds+           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'+        extra_classifieds+           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs+        let classifieds = hs_classifieds ++ extra_classifieds++        -- Complication: all the .so's must be loaded before any of the .o's.+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+            dlls       = [ dll  | DLL dll        <- classifieds ]+            objs       = [ obj  | Objects objs    <- classifieds+                                , obj <- objs ]+            archs      = [ arch | Archive arch   <- classifieds ]++        -- Add directories to library search paths+        let dll_paths  = map takeDirectory known_dlls+            all_paths  = nub $ map normalise $ dll_paths ++ dirs+        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env++        maybePutSDoc dflags+            (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")++        -- See comments with partOfGHCi+#if defined(CAN_LOAD_DLL)+        when (unitPackageName pkg `notElem` partOfGHCi) $ do+            loadFrameworks hsc_env platform pkg+            -- See Note [Crash early load_dyn and locateLib]+            -- Crash early if can't load any of `known_dlls`+            mapM_ (load_dyn hsc_env True) known_dlls+            -- For remaining `dlls` crash early only when there is surely+            -- no package's DLL around ... (not is_dyn)+            mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName platform) dlls+#endif+        -- After loading all the DLLs, we can load the static objects.+        -- Ordering isn't important here, because we do one final link+        -- step to resolve everything.+        mapM_ (loadObj hsc_env) objs+        mapM_ (loadArchive hsc_env) archs++        maybePutStr dflags "linking ... "+        ok <- resolveObjs hsc_env++        -- DLLs are loaded, reset the search paths+        -- Import libraries will be loaded via loadArchive so only+        -- reset the DLL search path after all archives are loaded+        -- as well.+        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache++        if succeeded ok+           then maybePutStrLn dflags "done."+           else let errmsg = text "unable to load unit `"+                             <> pprUnitInfoForUser pkg <> text "'"+                 in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))++{-+Note [Crash early load_dyn and locateLib]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a package is "normal" (exposes it's code from more than zero Haskell+modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then+it has it's code compiled and linked into the DLL, which GHCi linker picks+when loading the package's code (see the big comment in the beginning of+`locateLib`).++When loading DLLs, GHCi linker simply calls the system's `dlopen` or+`LoadLibrary` APIs. This is quite different from the case when GHCi linker+loads an object file or static library. When loading an object file or static+library GHCi linker parses them and resolves all symbols "manually".+These object file or static library may reference some external symbols+defined in some external DLLs. And GHCi should know which these+external DLLs are.++But when GHCi loads a DLL, it's the *system* linker who manages all+the necessary dependencies, and it is able to load this DLL not having+any extra info. Thus we don't *have to* crash in this case even if we+are unable to load any supposed dependencies explicitly.++Suppose during GHCi session a client of the package wants to+`foreign import` a symbol which isn't exposed by the package DLL, but+is exposed by such an external (dependency) DLL.+If the DLL isn't *explicitly* loaded because `load_dyn` failed to do+this, then the client code eventually crashes because the GHCi linker+isn't able to locate this symbol (GHCi linker maintains a list of+explicitly loaded DLLs it looks into when trying to find a symbol).++This is why we still should try to load all the dependency DLLs+even though we know that the system linker loads them implicitly when+loading the package DLL.++Why we still keep the `crash_early` opportunity then not allowing such+a permissive behaviour for any DLLs? Well, we, perhaps, improve a user+experience in some cases slightly.++But if it happens there exist other corner cases where our current+usage of `crash_early` flag is overly restrictive, we may lift the+restriction very easily.+-}++-- we have already searched the filesystem; the strings passed to load_dyn+-- can be passed directly to loadDLL.  They are either fully-qualified+-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,+-- loadDLL is going to search the system paths to find the library.+load_dyn :: HscEnv -> Bool -> FilePath -> IO ()+load_dyn hsc_env crash_early dll = do+  r <- loadDLL hsc_env dll+  case r of+    Nothing  -> return ()+    Just err ->+      if crash_early+        then cmdLineErrorIO err+        else let dflags = hsc_dflags hsc_env in+          when (wopt Opt_WarnMissedExtraSharedLib dflags)+            $ putLogMsg dflags+                (Reason Opt_WarnMissedExtraSharedLib) SevWarning+                  noSrcSpan $ withPprStyle defaultUserStyle (note err)+  where+    note err = vcat $ map text+      [ err+      , "It's OK if you don't want to use symbols from it directly."+      , "(the package DLL is loaded by the system linker"+      , " which manages dependencies by itself)." ]++loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO ()+loadFrameworks hsc_env platform pkg+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks+  where+    fw_dirs    = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg+    frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg++    load fw = do  r <- loadFramework hsc_env fw_dirs fw+                  case r of+                    Nothing  -> return ()+                    Just err -> cmdLineErrorIO ("can't load framework: "+                                                ++ fw ++ " (" ++ err ++ ")" )++-- Try to find an object file for a given library in the given paths.+-- If it isn't present, we assume that addDLL in the RTS can find it,+-- which generally means that it should be a dynamic library in the+-- standard system search path.+-- For GHCi we tend to prefer dynamic libraries over static ones as+-- they are easier to load and manage, have less overhead.+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String+          -> IO LibrarySpec+locateLib hsc_env is_hs lib_dirs gcc_dirs lib+  | not is_hs+    -- For non-Haskell libraries (e.g. gmp, iconv):+    --   first look in library-dirs for a dynamic library (on User paths only)+    --   (libfoo.so)+    --   then  try looking for import libraries on Windows (on User paths only)+    --   (.dll.a, .lib)+    --   first look in library-dirs for a dynamic library (on GCC paths only)+    --   (libfoo.so)+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)+    --   then  try looking for import libraries on Windows (on GCC paths only)+    --   (.dll.a, .lib)+    --   then  look in library-dirs for a static library (libfoo.a)+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)+    --   then  try looking for import libraries on Windows (.dll.a, .lib)+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)+    --   then  try "gcc --print-file-name" to search gcc's search path+    --       for a dynamic library (#5289)+    --   otherwise, assume loadDLL can find it+    --+    --   The logic is a bit complicated, but the rationale behind it is that+    --   loading a shared library for us is O(1) while loading an archive is+    --   O(n). Loading an import library is also O(n) so in general we prefer+    --   shared libraries because they are simpler and faster.+    --+  =+#if defined(CAN_LOAD_DLL)+    findDll   user `orElse`+#endif+    tryImpLib user `orElse`+#if defined(CAN_LOAD_DLL)+    findDll   gcc  `orElse`+    findSysDll     `orElse`+#endif+    tryImpLib gcc  `orElse`+    findArchive    `orElse`+    tryGcc         `orElse`+    assumeDll++  | loading_dynamic_hs_libs -- search for .so libraries first.+  = findHSDll     `orElse`+    findDynObject `orElse`+    assumeDll++  | otherwise+    -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a+  = findObject  `orElse`+    findArchive `orElse`+    assumeDll++   where+     dflags = hsc_dflags hsc_env+     interp = hscInterp hsc_env+     dirs   = lib_dirs ++ gcc_dirs+     gcc    = False+     user   = True++     obj_file+       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"+       | otherwise = lib <.> "o"+     dyn_obj_file = lib <.> "dyn_o"+     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"+                  , lib <.> "a" -- native code has no lib_tag+                  , "lib" ++ lib, lib+                  ]+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""++     loading_profiled_hs_libs = interpreterProfiled interp+     loading_dynamic_hs_libs  = interpreterDynamic  interp++     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"+                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"+                    ]++     hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags+     hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name++     so_name     = platformSOName platform lib+     lib_so_name = "lib" ++ so_name+     dyn_lib_file = case (arch, os) of+                             (ArchX86_64, OSSolaris2) -> "64" </> so_name+                             _ -> so_name++     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file+     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file+     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name+                     in  apply (map local arch_files)+     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file+     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs+                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $+                        findSystemLibrary hsc_env so_name+     tryGcc        = let search   = searchForLibUsingGcc dflags+                         dllpath  = liftM (fmap DLLPath)+                         short    = dllpath $ search so_name lib_dirs+                         full     = dllpath $ search lib_so_name lib_dirs+                         gcc name = liftM (fmap Archive) $ search name lib_dirs+                         files    = import_libs ++ arch_files+                         dlls     = [short, full]+                         archives = map gcc files+                     in apply $+#if defined(CAN_LOAD_DLL)+                          dlls +++#endif+                          archives+     tryImpLib re = case os of+                       OSMinGW32 ->+                        let dirs' = if re == user then lib_dirs else gcc_dirs+                            implib name = liftM (fmap Archive) $+                                            findFile dirs' name+                        in apply (map implib import_libs)+                       _         -> return Nothing++     -- TH Makes use of the interpreter so this failure is not obvious.+     -- So we are nice and warn/inform users why we fail before we do.+     -- But only for haskell libraries, as C libraries don't have a+     -- profiling/non-profiling distinction to begin with.+     assumeDll+      | is_hs+      , not loading_dynamic_hs_libs+      , interpreterProfiled interp+      = do+          warningMsg dflags+            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$+              text " \tTrying dynamic library instead. If this fails try to rebuild" <+>+              text "libraries with profiling support.")+          return (DLL lib)+      | otherwise = return (DLL lib)+     infixr `orElse`+     f `orElse` g = f >>= maybe g return++     apply :: [IO (Maybe a)] -> IO (Maybe a)+     apply []     = return Nothing+     apply (x:xs) = do x' <- x+                       if isJust x'+                          then return x'+                          else apply xs++     platform = targetPlatform dflags+     arch = platformArch platform+     os = platformOS platform++searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)+searchForLibUsingGcc dflags so dirs = do+   -- GCC does not seem to extend the library search path (using -L) when using+   -- --print-file-name. So instead pass it a new base location.+   str <- askLd dflags (map (FileOption "-B") dirs+                          ++ [Option "--print-file-name", Option so])+   let file = case lines str of+                []  -> ""+                l:_ -> l+   if (file == so)+      then return Nothing+      else do b <- doesFileExist file -- file could be a folder (see #16063)+              return (if b then Just file else Nothing)++-- | Retrieve the list of search directory GCC and the System use to find+--   libraries and components. See Note [Fork/Exec Windows].+getGCCPaths :: DynFlags -> OS -> IO [FilePath]+getGCCPaths dflags os+  = case os of+      OSMinGW32 ->+        do gcc_dirs <- getGccSearchDirectory dflags "libraries"+           sys_dirs <- getSystemDirectories+           return $ nub $ gcc_dirs ++ sys_dirs+      _         -> return []++-- | Cache for the GCC search directories as this can't easily change+--   during an invocation of GHC. (Maybe with some env. variable but we'll)+--   deal with that highly unlikely scenario then.+{-# NOINLINE gccSearchDirCache #-}+gccSearchDirCache :: IORef [(String, [String])]+gccSearchDirCache = unsafePerformIO $ newIORef []++-- Note [Fork/Exec Windows]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.+-- So instead get a list of location that GCC would search and use findDirs+-- which hopefully is written in an optimized mannor to take advantage of+-- caching. At the very least we remove the overhead of the fork/exec and waits+-- which dominate a large percentage of startup time on Windows.+getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]+getGccSearchDirectory dflags key = do+    cache <- readIORef gccSearchDirCache+    case lookup key cache of+      Just x  -> return x+      Nothing -> do+        str <- askLd dflags [Option "--print-search-dirs"]+        let line = dropWhile isSpace str+            name = key ++ ": ="+        if null line+          then return []+          else do let val = split $ find name line+                  dirs <- filterM doesDirectoryExist val+                  modifyIORef' gccSearchDirCache ((key, dirs):)+                  return val+      where split :: FilePath -> [FilePath]+            split r = case break (==';') r of+                        (s, []    ) -> [s]+                        (s, (_:xs)) -> s : split xs++            find :: String -> String -> String+            find r x = let lst = lines x+                           val = filter (r `isPrefixOf`) lst+                       in if null val+                             then []+                             else case break (=='=') (head val) of+                                     (_ , [])    -> []+                                     (_, (_:xs)) -> xs++-- | Get a list of system search directories, this to alleviate pressure on+-- the findSysDll function.+getSystemDirectories :: IO [FilePath]+#if defined(mingw32_HOST_OS)+getSystemDirectories = fmap (:[]) getSystemDirectory+#else+getSystemDirectories = return []+#endif++-- | Merge the given list of paths with those in the environment variable+--   given. If the variable does not exist then just return the identity.+addEnvPaths :: String -> [String] -> IO [String]+addEnvPaths name list+  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current+       -- working directory. Replace empty strings in the env variable with+       -- `working_dir` (see also #14695).+       working_dir <- getCurrentDirectory+       values <- lookupEnv name+       case values of+         Nothing  -> return list+         Just arr -> return $ list ++ splitEnv working_dir arr+    where+      splitEnv :: FilePath -> String -> [String]+      splitEnv working_dir value =+        case break (== envListSep) value of+          (x, []    ) ->+            [if null x then working_dir else x]+          (x, (_:xs)) ->+            (if null x then working_dir else x) : splitEnv working_dir xs+#if defined(mingw32_HOST_OS)+      envListSep = ';'+#else+      envListSep = ':'+#endif++-- ----------------------------------------------------------------------------+-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)+++{- **********************************************************************++                Helper functions++  ********************************************************************* -}++maybePutSDoc :: DynFlags -> SDoc -> IO ()+maybePutSDoc dflags s+    = when (verbosity dflags > 1) $+          putLogMsg dflags+              NoReason+              SevInteractive+              noSrcSpan+              $ withPprStyle defaultUserStyle s++maybePutStr :: DynFlags -> String -> IO ()+maybePutStr dflags s = maybePutSDoc dflags (text s)++maybePutStrLn :: DynFlags -> String -> IO ()+maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")