ghc-lib 0.20210228 → 0.20210331

raw patch · 205 files changed

+12958/−9810 lines, 205 filesdep ~basedep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +58/−41
• compiler/GHC/Builtin/Types/Literals.hs +96/−78
• compiler/GHC/ByteCode/Asm.hs +124/−18
• compiler/GHC/ByteCode/InfoTable.hs +12/−13
• compiler/GHC/ByteCode/Instr.hs +60/−32
• compiler/GHC/ByteCode/Linker.hs +71/−52
• compiler/GHC/Cmm/DebugBlock.hs +2/−2
• compiler/GHC/Cmm/LayoutStack.hs +2/−1
• compiler/GHC/Cmm/Parser.y +13/−6
• compiler/GHC/CmmToAsm.hs +9/−5
• compiler/GHC/CmmToAsm/Dwarf.hs +2/−2
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +27/−7
• compiler/GHC/CmmToAsm/Ppr.hs +6/−8
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +3/−0
• compiler/GHC/CmmToAsm/Reg/Linear.hs +47/−53
• compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +1/−0
• compiler/GHC/CmmToAsm/Reg/Linear/State.hs +22/−16
• compiler/GHC/CmmToAsm/Reg/Target.hs +5/−0
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +1/−8
• compiler/GHC/CmmToC.hs +16/−5
• compiler/GHC/CmmToLlvm.hs +9/−2
• compiler/GHC/CmmToLlvm/Base.hs +8/−4
• compiler/GHC/Core/Map/Expr.hs +4/−3
• compiler/GHC/Core/Opt/CSE.hs +70/−16
• compiler/GHC/Core/Opt/CallArity.hs +1/−1
• compiler/GHC/Core/Opt/CprAnal.hs +145/−82
• compiler/GHC/Core/Opt/DmdAnal.hs +43/−64
• compiler/GHC/Core/Opt/FloatIn.hs +1/−0
• compiler/GHC/Core/Opt/FloatOut.hs +2/−1
• compiler/GHC/Core/Opt/Pipeline.hs +6/−5
• compiler/GHC/Core/Opt/SetLevels.hs +7/−6
• compiler/GHC/Core/Opt/Simplify.hs +92/−32
• compiler/GHC/Core/Opt/Simplify/Env.hs +46/−26
• compiler/GHC/Core/Opt/Simplify/Monad.hs +0/−1
• compiler/GHC/Core/Opt/Simplify/Utils.hs +11/−10
• compiler/GHC/Core/Opt/SpecConstr.hs +8/−8
• compiler/GHC/Core/Opt/Specialise.hs +8/−6
• compiler/GHC/Core/Opt/WorkWrap.hs +7/−7
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +430/−418
• compiler/GHC/Core/Rules.hs +1/−0
• compiler/GHC/Core/Tidy.hs +5/−3
• compiler/GHC/CoreToByteCode.hs +0/−2116
• compiler/GHC/CoreToStg.hs +77/−47
• compiler/GHC/CoreToStg/Prep.hs +26/−12
• compiler/GHC/Data/Graph/UnVar.hs +1/−1
• compiler/GHC/Driver/Backpack.hs +12/−7
• compiler/GHC/Driver/CodeOutput.hs +78/−32
• compiler/GHC/Driver/Main.hs +182/−111
• compiler/GHC/Driver/Make.hs +107/−121
• compiler/GHC/Driver/MakeFile.hs +26/−22
• compiler/GHC/Driver/Pipeline.hs +84/−49
• compiler/GHC/Hs/Stats.hs +1/−1
• compiler/GHC/HsToCore.hs +23/−22
• compiler/GHC/HsToCore/Arrows.hs +32/−29
• compiler/GHC/HsToCore/Binds.hs +9/−9
• compiler/GHC/HsToCore/Coverage.hs +74/−58
• compiler/GHC/HsToCore/Docs.hs +123/−43
• compiler/GHC/HsToCore/Expr.hs +141/−127
• compiler/GHC/HsToCore/Expr.hs-boot +2/−2
• compiler/GHC/HsToCore/Foreign/Decl.hs +20/−20
• compiler/GHC/HsToCore/ListComp.hs +3/−3
• compiler/GHC/HsToCore/Match.hs +9/−10
• compiler/GHC/HsToCore/Match.hs-boot +1/−1
• compiler/GHC/HsToCore/Match/Literal.hs +19/−18
• compiler/GHC/HsToCore/Monad.hs +24/−18
• compiler/GHC/HsToCore/Pmc.hs +13/−15
• compiler/GHC/HsToCore/Pmc/Check.hs +81/−0
• compiler/GHC/HsToCore/Pmc/Desugar.hs +6/−6
• compiler/GHC/HsToCore/Pmc/Solver.hs +227/−125
• compiler/GHC/HsToCore/Pmc/Solver/Types.hs +5/−5
• compiler/GHC/HsToCore/Quote.hs +92/−86
• compiler/GHC/HsToCore/Types.hs +2/−2
• compiler/GHC/HsToCore/Usage.hs +9/−2
• compiler/GHC/HsToCore/Utils.hs +62/−8
• compiler/GHC/Iface/Binary.hs +40/−67
• compiler/GHC/Iface/Env.hs +55/−96
• compiler/GHC/Iface/Ext/Ast.hs +297/−216
• compiler/GHC/Iface/Ext/Binary.hs +45/−44
• compiler/GHC/Iface/Ext/Utils.hs +27/−0
• compiler/GHC/Iface/Load.hs +198/−167
• compiler/GHC/Iface/Make.hs +4/−3
• compiler/GHC/Iface/Recomp.hs +154/−116
• compiler/GHC/Iface/Rename.hs +1/−1
• compiler/GHC/Iface/Tidy.hs +27/−34
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +4/−3
• compiler/GHC/IfaceToCore.hs +21/−8
• compiler/GHC/IfaceToCore.hs-boot +1/−1
• compiler/GHC/Linker/Dynamic.hs +6/−5
• compiler/GHC/Linker/ExtraObj.hs +12/−12
• compiler/GHC/Linker/Loader.hs +243/−230
• compiler/GHC/Linker/MacOS.hs +4/−5
• compiler/GHC/Linker/Static.hs +10/−10
• compiler/GHC/Linker/Windows.hs +5/−4
• compiler/GHC/Rename/Bind.hs +106/−88
• compiler/GHC/Rename/Env.hs +50/−29
• compiler/GHC/Rename/Expr.hs +313/−173
• compiler/GHC/Rename/Expr.hs-boot +15/−5
• compiler/GHC/Rename/Fixity.hs +1/−1
• compiler/GHC/Rename/HsType.hs +100/−76
• compiler/GHC/Rename/Module.hs +101/−95
• compiler/GHC/Rename/Names.hs +88/−60
• compiler/GHC/Rename/Pat.hs +55/−49
• compiler/GHC/Rename/Splice.hs +26/−18
• compiler/GHC/Rename/Utils.hs +35/−33
• compiler/GHC/Runtime/Debugger.hs +6/−6
• compiler/GHC/Runtime/Eval.hs +71/−43
• compiler/GHC/Runtime/Heap/Inspect.hs +9/−5
• compiler/GHC/Runtime/Interpreter.hs +156/−153
• compiler/GHC/Runtime/Loader.hs +19/−14
• compiler/GHC/Stg/CSE.hs +6/−6
• compiler/GHC/Stg/Debug.hs +240/−0
• compiler/GHC/Stg/DepAnal.hs +2/−2
• compiler/GHC/Stg/FVs.hs +7/−5
• compiler/GHC/Stg/Lift.hs +3/−3
• compiler/GHC/Stg/Lift/Analysis.hs +5/−5
• compiler/GHC/Stg/Lift/Monad.hs +2/−2
• compiler/GHC/Stg/Lint.hs +18/−11
• compiler/GHC/Stg/Pipeline.hs +4/−3
• compiler/GHC/Stg/Stats.hs +2/−2
• compiler/GHC/Stg/Unarise.hs +36/−8
• compiler/GHC/StgToByteCode.hs +2281/−0
• compiler/GHC/StgToCmm.hs +84/−56
• compiler/GHC/StgToCmm/ArgRep.hs +1/−1
• compiler/GHC/StgToCmm/Bind.hs +4/−3
• compiler/GHC/StgToCmm/Closure.hs +3/−3
• compiler/GHC/StgToCmm/DataCon.hs +23/−10
• compiler/GHC/StgToCmm/Env.hs +7/−24
• compiler/GHC/StgToCmm/Expr.hs +12/−10
• compiler/GHC/StgToCmm/Expr.hs-boot +7/−0
• compiler/GHC/StgToCmm/Foreign.hs +0/−1
• compiler/GHC/StgToCmm/Heap.hs +0/−1
• compiler/GHC/StgToCmm/Layout.hs +21/−1
• compiler/GHC/StgToCmm/Lit.hs +105/−0
• compiler/GHC/StgToCmm/Monad.hs +14/−10
• compiler/GHC/StgToCmm/Prim.hs +53/−55
• compiler/GHC/StgToCmm/Prof.hs +54/−2
• compiler/GHC/StgToCmm/Ticky.hs +1/−0
• compiler/GHC/StgToCmm/Utils.hs +51/−63
• compiler/GHC/SysTools/Process.hs +19/−14
• compiler/GHC/SysTools/Tasks.hs +27/−19
• compiler/GHC/Tc/Deriv.hs +12/−12
• compiler/GHC/Tc/Deriv/Functor.hs +12/−14
• compiler/GHC/Tc/Deriv/Generate.hs +87/−78
• compiler/GHC/Tc/Deriv/Generics.hs +16/−7
• compiler/GHC/Tc/Deriv/Utils.hs +3/−3
• compiler/GHC/Tc/Errors.hs +266/−208
• compiler/GHC/Tc/Errors/Hole.hs +2/−2
• compiler/GHC/Tc/Gen/Annotation.hs +3/−3
• compiler/GHC/Tc/Gen/App.hs +99/−69
• compiler/GHC/Tc/Gen/Arrow.hs +16/−11
• compiler/GHC/Tc/Gen/Bind.hs +35/−30
• compiler/GHC/Tc/Gen/Default.hs +5/−5
• compiler/GHC/Tc/Gen/Export.hs +49/−47
• compiler/GHC/Tc/Gen/Expr.hs +74/−45
• compiler/GHC/Tc/Gen/Foreign.hs +6/−6
• compiler/GHC/Tc/Gen/Head.hs +43/−35
• compiler/GHC/Tc/Gen/HsType.hs +203/−85
• compiler/GHC/Tc/Gen/Match.hs +61/−45
• compiler/GHC/Tc/Gen/Match.hs-boot +2/−2
• compiler/GHC/Tc/Gen/Pat.hs +12/−12
• compiler/GHC/Tc/Gen/Rule.hs +3/−3
• compiler/GHC/Tc/Gen/Sig.hs +19/−19
• compiler/GHC/Tc/Gen/Splice.hs +192/−29
• compiler/GHC/Tc/Instance/FunDeps.hs +8/−8
• compiler/GHC/Tc/Instance/Typeable.hs +20/−9
• compiler/GHC/Tc/Module.hs +360/−342
• compiler/GHC/Tc/Plugin.hs +5/−1
• compiler/GHC/Tc/Solver.hs +23/−9
• compiler/GHC/Tc/Solver/Canonical.hs +15/−8
• compiler/GHC/Tc/Solver/Interact.hs +182/−46
• compiler/GHC/Tc/Solver/Monad.hs +8/−3
• compiler/GHC/Tc/TyCl.hs +133/−62
• compiler/GHC/Tc/TyCl/Class.hs +28/−23
• compiler/GHC/Tc/TyCl/Instance.hs +45/−36
• compiler/GHC/Tc/TyCl/PatSyn.hs +38/−35
• compiler/GHC/Tc/TyCl/Utils.hs +20/−16
• compiler/GHC/Tc/Types/EvTerm.hs +6/−1
• compiler/GHC/Tc/Utils/Backpack.hs +47/−20
• compiler/GHC/Tc/Utils/Env.hs +15/−15
• compiler/GHC/Tc/Utils/Instantiate.hs +2/−2
• compiler/GHC/Tc/Utils/Monad.hs +113/−98
• compiler/GHC/Tc/Utils/TcMType.hs +23/−8
• compiler/GHC/Tc/Utils/Unify.hs +13/−6
• compiler/GHC/Tc/Utils/Zonk.hs +74/−57
• compiler/GHC/Tc/Validity.hs +7/−7
• compiler/GHC/ThToHs.hs +353/−321
• compiler/GHC/Types/Unique/SDFM.hs +2/−2
• compiler/GHC/Unit/Finder.hs +109/−113
• ghc-lib.cabal +11/−5
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +2/−0
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +2/−0
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +2/−0
• ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +1/−0
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +110/−108
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +13/−13
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1285/−1283
• ghc-lib/stage0/lib/DerivedConstants.h +13/−13
• ghc-lib/stage0/lib/ghcautoconf.h +5/−2
• ghc-lib/stage0/lib/llvm-targets +3/−1
• includes/CodeGen.Platform.hs +69/−1
• includes/stg/MachRegs.h +80/−2
• libraries/ghci/GHCi/CreateBCO.hs +6/−0
• libraries/ghci/GHCi/InfoTable.hsc +32/−0
• libraries/ghci/GHCi/Run.hs +4/−4
• libraries/ghci/GHCi/TH.hs +2/−0

@@ -159,9 +159,10 @@         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,         modInfoModBreaks,         ModBreaks(..), BreakIndex,-        BreakInfo(breakInfo_number, breakInfo_module),+        BreakInfo(..),         GHC.Runtime.Eval.back,         GHC.Runtime.Eval.forward,+        GHC.Runtime.Eval.setupBreakpoint,          -- * Abstract syntax elements @@ -282,10 +283,7 @@         parser,          -- * API Annotations-        ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,-        getAnnotation, getAndRemoveAnnotation,-        getAnnotationComments, getAndRemoveAnnotationComments,-        unicodeAnn,+        AnnKeywordId(..),EpaComment(..),          -- * Miscellaneous         --sessionHscEnv,@@ -310,7 +308,8 @@ import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.CmdLine-import GHC.Driver.Session hiding (WarnReason(..))+import GHC.Driver.Session+import qualified GHC.Driver.Session as Session import GHC.Driver.Backend import GHC.Driver.Config import GHC.Driver.Main@@ -321,11 +320,11 @@ import GHC.Driver.Ppr  import GHC.ByteCode.Types+import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types import GHC.Runtime.Context import GHCi.RemoteTypes @@ -351,7 +350,7 @@ import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family -import GHC.SysTools.FileCleanup+import GHC.Utils.TmpFs import GHC.SysTools import GHC.SysTools.BaseDir @@ -391,6 +390,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.SourceFile+import GHC.Types.Error ( DiagnosticMessage )  import GHC.Unit import GHC.Unit.Env@@ -533,10 +533,11 @@       hsc_env <- getSession       let dflags = hsc_dflags hsc_env       let logger = hsc_logger hsc_env+      let tmpfs  = hsc_tmpfs hsc_env       liftIO $ do-          cleanTempFiles logger dflags-          cleanTempDirs logger dflags-          stopInterp hsc_env -- shut down the IServ+          cleanTempFiles logger tmpfs dflags+          cleanTempDirs logger tmpfs dflags+          traverse_ stopInterp (hsc_interp hsc_env)           --  exceptions will be blocked while we clean the temporary files,           -- so there shouldn't be any difficulty if we receive further           -- signals.@@ -643,7 +644,7 @@   (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env)    -- Interpreter-  interp  <- if gopt Opt_ExternalInterpreter dflags+  interp <- if gopt Opt_ExternalInterpreter dflags     then do          let            prog = pgm_i dflags ++ flavour@@ -667,10 +668,13 @@             , iservConfTrace    = tr             }          s <- liftIO $ newMVar IServPending-         return (Just (ExternalInterp conf (IServ s)))+         loader <- liftIO Loader.uninitializedLoader+         return (Just (Interp (ExternalInterp conf (IServ s)) loader))     else #if defined(HAVE_INTERNAL_INTERPRETER)-      return (Just InternalInterp)+     do+      loader <- liftIO Loader.uninitializedLoader+      return (Just (Interp InternalInterp loader)) #else       return Nothing #endif@@ -897,7 +901,7 @@   -- the REPL. See #12356.   if xopt LangExt.StaticPointers dflags0   then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag-            [mkPlainWarnMsg interactiveSrcSpan+            [mkPlainMsgEnvelope Session.WarningWithoutFlag interactiveSrcSpan              $ text "StaticPointers is not supported in GHCi interactive expressions."]           return $ xopt_unset dflags0 LangExt.StaticPointers   else return dflags0@@ -933,7 +937,7 @@ removeTarget target_id   = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })   where-   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]+   filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]  -- | Attempts to guess what Target a string refers to.  This function -- implements the @--make@/GHCi command-line syntax for filenames:@@ -946,23 +950,25 @@ -- --   - otherwise interpret the string as a module name ---guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target-guessTarget str (Just phase)-   = return (Target (TargetFile str (Just phase)) True Nothing)-guessTarget str Nothing+guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target+guessTarget str mUnitId (Just phase)+   = do+     tuid <- unitIdOrHomeUnit mUnitId+     return (Target (TargetFile str (Just phase)) True tuid Nothing)+guessTarget str mUnitId Nothing    | isHaskellSrcFilename file-   = return (target (TargetFile file Nothing))+   = target (TargetFile file Nothing)    | otherwise    = do exists <- liftIO $ doesFileExist hs_file         if exists-           then return (target (TargetFile hs_file Nothing))+           then target (TargetFile hs_file Nothing)            else do         exists <- liftIO $ doesFileExist lhs_file         if exists-           then return (target (TargetFile lhs_file Nothing))+           then target (TargetFile lhs_file Nothing)            else do         if looksLikeModuleName file-           then return (target (TargetModule (mkModuleName file)))+           then target (TargetModule (mkModuleName file))            else do         dflags <- getDynFlags         liftIO $ throwGhcExceptionIO@@ -977,8 +983,16 @@          hs_file  = file <.> "hs"          lhs_file = file <.> "lhs" -         target tid = Target tid obj_allowed Nothing+         target tid = do+           tuid <- unitIdOrHomeUnit mUnitId+           pure $ Target tid obj_allowed tuid Nothing +-- | Unwrap 'UnitId' or retrieve the 'UnitId'+-- of the current 'HomeUnit'.+unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId+unitIdOrHomeUnit mUnitId = do+  currentHomeUnitId <- homeUnitId . ue_home_unit . hsc_unit_env <$> getSession+  pure (fromMaybe currentHomeUnitId mUnitId)  -- | Inform GHC that the working directory has changed.  GHC will flush -- its cache of module locations, since it may no longer be valid.@@ -988,7 +1002,9 @@ -- you should also unload the current program (set targets to empty, -- followed by load). workingDirectoryChanged :: GhcMonad m => m ()-workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)+workingDirectoryChanged = do+  hsc_env <- getSession+  liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)   -- %************************************************************************@@ -1019,9 +1035,7 @@ data ParsedModule =   ParsedModule { pm_mod_summary   :: ModSummary                , pm_parsed_source :: ParsedSource-               , pm_extra_src_files :: [FilePath]-               , pm_annotations :: ApiAnns }-               -- See Note [Api annotations] in GHC.Parser.Annotation+               , pm_extra_src_files :: [FilePath] }  instance ParsedMod ParsedModule where   modSummary m    = pm_mod_summary m@@ -1113,9 +1127,8 @@    hsc_env <- getSession    let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }    hpm <- liftIO $ hscParse hsc_env_tmp ms-   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)-                           (hpm_annotations hpm))-               -- See Note [Api annotations] in GHC.Parser.Annotation+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))+               -- See Note [exact print annotations] in GHC.Parser.Annotation  -- | Typecheck and rename a parsed module. --@@ -1128,8 +1141,7 @@  (tc_gbl_env, rn_info)        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $                       HsParsedModule { hpm_module = parsedSource pmod,-                                       hpm_src_files = pm_extra_src_files pmod,-                                       hpm_annotations = pm_annotations pmod }+                                       hpm_src_files = pm_extra_src_files pmod }  details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env  safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env @@ -1243,7 +1255,7 @@ compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do    -- First, set the target to the desired filename-   target <- guessTarget fn Nothing+   target <- guessTarget fn Nothing Nothing    addTarget target    _ <- load LoadAllTargets    -- Then find dependencies@@ -1481,7 +1493,7 @@                      -- if it is visible from at least one module in the list.   -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load                      -- modules for everything that is in scope unqualified.-  -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))+  -> m (Messages DiagnosticMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do   hsc_env <- getSession   liftIO $ runTcInteractive hsc_env $@@ -1654,11 +1666,13 @@ -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do-  let dflags     = hsc_dflags hsc_env-      home_unit  = hsc_home_unit hsc_env+  let fc        = hsc_FC hsc_env+  let home_unit = hsc_home_unit hsc_env+  let units     = hsc_units hsc_env+  let dflags    = hsc_dflags hsc_env   case maybe_pkg of     Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do-      res <- findImportedModule hsc_env mod_name maybe_pkg+      res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg       case res of         Found _ m -> return m         err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err@@ -1667,7 +1681,7 @@       case home of         Just m  -> return m         Nothing -> liftIO $ do-           res <- findImportedModule hsc_env mod_name maybe_pkg+           res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg            case res of              Found loc m | not (isHomeModule home_unit m) -> return m                          | otherwise -> modNotLoadedError dflags m loc@@ -1693,7 +1707,10 @@   case home of     Just m  -> return m     Nothing -> liftIO $ do-      res <- findExposedPackageModule hsc_env mod_name Nothing+      let fc     = hsc_FC hsc_env+      let units  = hsc_units hsc_env+      let dflags = hsc_dflags hsc_env+      res <- findExposedPackageModule fc units dflags mod_name Nothing       case res of         Found _ m -> return m         err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err

@@ -11,7 +11,6 @@   , typeNatAddTyCon   , typeNatMulTyCon   , typeNatExpTyCon-  , typeNatLeqTyCon   , typeNatSubTyCon   , typeNatDivTyCon   , typeNatModTyCon@@ -22,6 +21,8 @@   , typeCharCmpTyCon   , typeConsSymbolTyCon   , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon   ) where  import GHC.Prelude@@ -40,11 +41,12 @@ import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders ) import GHC.Builtin.Names                   ( gHC_TYPELITS+                  , gHC_TYPELITS_INTERNAL                   , gHC_TYPENATS+                  , gHC_TYPENATS_INTERNAL                   , typeNatAddTyFamNameKey                   , typeNatMulTyFamNameKey                   , typeNatExpTyFamNameKey-                  , typeNatLeqTyFamNameKey                   , typeNatSubTyFamNameKey                   , typeNatDivTyFamNameKey                   , typeNatModTyFamNameKey@@ -55,11 +57,13 @@                   , typeCharCmpTyFamNameKey                   , typeConsSymbolTyFamNameKey                   , typeUnconsSymbolTyFamNameKey+                  , typeCharToNatTyFamNameKey+                  , typeNatToCharTyFamNameKey                   ) import GHC.Data.FastString-import Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List  ( isPrefixOf, isSuffixOf )+import qualified Data.Char as Char  {- Note [Type-level literals]@@ -146,7 +150,6 @@   [ typeNatAddTyCon   , typeNatMulTyCon   , typeNatExpTyCon-  , typeNatLeqTyCon   , typeNatSubTyCon   , typeNatDivTyCon   , typeNatModTyCon@@ -157,6 +160,8 @@   , typeCharCmpTyCon   , typeConsSymbolTyCon   , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon   ]  typeNatAddTyCon :: TyCon@@ -236,24 +241,7 @@   name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")             typeNatLogTyFamNameKey typeNatLogTyCon -typeNatLeqTyCon :: TyCon-typeNatLeqTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])-    boolTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective -  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")-                typeNatLeqTyFamNameKey typeNatLeqTyCon-  ops = BuiltInSynFamily-    { sfMatchFam      = matchFamLeq-    , sfInteractTop   = interactTopLeq-    , sfInteractInert = interactInertLeq-    }  typeNatCmpTyCon :: TyCon typeNatCmpTyCon =@@ -266,7 +254,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS_INTERNAL (fsLit "CmpNat")                 typeNatCmpTyFamNameKey typeNatCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpNat@@ -285,7 +273,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpSymbol")                 typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpSymbol@@ -340,6 +328,43 @@       , sfInteractInert = interactInertUnconsSymbol       } +typeCharToNatTyCon :: TyCon+typeCharToNatTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CharToNat")+                  typeCharToNatTyFamNameKey typeCharToNatTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamCharToNat+      , sfInteractTop   = interactTopCharToNat+      , sfInteractInert = \_ _ _ _ -> []+      }+++typeNatToCharTyCon :: TyCon+typeNatToCharTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ naturalTy ])+    charTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "NatToChar")+                  typeNatToCharTyFamNameKey typeNatToCharTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamNatToChar+      , sfInteractTop   = interactTopNatToChar+      , sfInteractInert = \_ _ _ _ -> []+      }+ -- Make a unary built-in constructor of kind: Nat -> Nat mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon1 op tcb =@@ -383,12 +408,13 @@ axAddDef   , axMulDef   , axExpDef-  , axLeqDef   , axCmpNatDef   , axCmpSymbolDef   , axAppendSymbolDef   , axConsSymbolDef   , axUnconsSymbolDef+  , axCharToNatDef+  , axNatToCharDef   , axAdd0L   , axAdd0R   , axMul0L@@ -398,10 +424,8 @@   , axExp1L   , axExp0R   , axExp1R-  , axLeqRefl   , axCmpNatRefl   , axCmpSymbolRefl-  , axLeq0L   , axSubDef   , axSub0R   , axAppendSymbol0R@@ -422,9 +446,6 @@ axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $               \x y -> Just $ num (x ^ y) -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ bool (x <= y)- axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy               $ \x y -> Just $ ordering (compare x y) @@ -461,6 +482,14 @@     \str -> Just $       mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str)) +axCharToNatDef =+  mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $+    \c -> Just $ num (charToInteger c)++axNatToCharDef =+  mkUnAxiom "NatToCharDef" typeNatToCharTyCon isNumLitTy $+    \n -> fmap mkCharLitTy (integerToChar n)+ axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $               \x y -> fmap num (minus x y) @@ -489,12 +518,10 @@ axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1 axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1 axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t-axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True axCmpNatRefl    = mkAxiom1 "CmpNatRefl"                 $ \(Pair s _) -> (cmpNat s s) === ordering EQ axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"                 $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ-axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True axAppendSymbol0R  = mkAxiom1 "Concat0R"             $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t axAppendSymbol0L  = mkAxiom1 "Concat0L"@@ -508,7 +535,6 @@   [ axAddDef   , axMulDef   , axExpDef-  , axLeqDef   , axCmpNatDef   , axCmpSymbolDef   , axCmpCharDef@@ -524,11 +550,9 @@   , axExp1L   , axExp0R   , axExp1R-  , axLeqRefl   , axCmpNatRefl   , axCmpSymbolRefl   , axCmpCharRefl-  , axLeq0L   , axSubDef   , axSub0R   , axAppendSymbol0R@@ -564,9 +588,6 @@ (.^.) :: Type -> Type -> Type s .^. t = mkTyConApp typeNatExpTyCon [s,t] -(<==) :: Type -> Type -> Type-s <== t = mkTyConApp typeNatLeqTyCon [s,t]- cmpNat :: Type -> Type -> Type cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] @@ -582,24 +603,12 @@ num :: Integer -> Type num = mkNumLitTy -bool :: Bool -> Type-bool b = if b then mkTyConApp promotedTrueDataCon []-              else mkTyConApp promotedFalseDataCon []- charSymbolPair :: Type -> Type -> Type charSymbolPair = mkPromotedPairTy charTy typeSymbolKind  charSymbolPairKind :: Kind charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind] -isBoolLitTy :: Type -> Maybe Bool-isBoolLitTy tc =-  do (tc,[]) <- splitTyConApp_maybe tc-     case () of-       _ | tc == promotedFalseDataCon -> return False-         | tc == promotedTrueDataCon  -> return True-         | otherwise                   -> Nothing- orderingKind :: Kind orderingKind = mkTyConApp orderingTyCon [] @@ -734,15 +743,6 @@   where mbX = isNumLitTy s matchFamLog _ = Nothing -matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamLeq [s,t]-  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)-  | Just x <- mbX, Just y <- mbY =-    Just (axLeqDef, [s,t], bool (x <= y))-  | tcEqType s t  = Just (axLeqRefl, [s], bool True)-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamLeq _ = Nothing  matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamCmpNat [s,t]@@ -794,6 +794,29 @@   mbX = isStrLitTy s matchFamUnconsSymbol _ = Nothing +matchFamCharToNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCharToNat [c]+  | Just c' <- isCharLitTy c, n <- charToInteger c'+  = Just (axCharToNatDef, [c], mkNumLitTy n)+  | otherwise = Nothing+matchFamCharToNat _ = Nothing++matchFamNatToChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamNatToChar [n]+  | Just n' <- isNumLitTy n, Just c <- integerToChar n'+  = Just (axNatToCharDef, [n], mkCharLitTy c)+  | otherwise = Nothing+matchFamNatToChar _ = Nothing++charToInteger :: Char -> Integer+charToInteger c = fromIntegral (Char.ord c)++integerToChar :: Integer -> Maybe Char+integerToChar n | inBounds = Just (Char.chr (fromInteger n))+  where inBounds = n >= charToInteger minBound &&+                   n <= charToInteger maxBound+integerToChar _ = Nothing+ {------------------------------------------------------------------------------- Interact with axioms -------------------------------------------------------------------------------}@@ -883,13 +906,6 @@ interactTopLog _ _ = []   -- I can't think of anything...  -interactTopLeq :: [Xi] -> Xi -> [Pair Type]-interactTopLeq [s,t] r-  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)-  where-  mbY = isNumLitTy t-  mbZ = isBoolLitTy r-interactTopLeq _ _ = []  interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] interactTopCmpNat [s,t] r@@ -948,7 +964,21 @@  interactTopUnconsSymbol _ _ = [] +interactTopCharToNat :: [Xi] -> Xi -> [Pair Type]+interactTopCharToNat [s] r+  -- (CharToNat c ~ 122) => (c ~ 'z')+  | Just n <- isNumLitTy r+  , Just c <- integerToChar n+  = [ s === mkCharLitTy c ]+interactTopCharToNat _ _ = [] +interactTopNatToChar :: [Xi] -> Xi -> [Pair Type]+interactTopNatToChar [s] r+  -- (NatToChar n ~ 'z') => (n ~ 122)+  | Just c <- isCharLitTy r+  = [ s === mkNumLitTy (charToInteger c) ]+interactTopNatToChar _ _ = []+ {------------------------------------------------------------------------------- Interaction with inerts -------------------------------------------------------------------------------}@@ -993,18 +1023,6 @@ interactInertLog _ _ _ _ = []  -interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertLeq [x1,y1] z1 [x2,y2] z2-  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]-  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]-  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]-  where bothTrue = isJust $ do True <- isBoolLitTy z1-                               True <- isBoolLitTy z2-                               return ()--interactInertLeq _ _ _ _ = []-- interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2   | sameZ && tcEqType x1 x2         = [ y1 === y2 ]@@ -1110,7 +1128,7 @@     Nothing     NotInjective   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpChar")+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpChar")                   typeCharCmpTyFamNameKey typeCharCmpTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamCmpChar

@@ -9,25 +9,22 @@ -- | Bytecode assembler and linker module GHC.ByteCode.Asm (         assembleBCOs, assembleOneBCO,-         bcoFreeNames,         SizedSeq, sizeSS, ssElts,-        iNTERP_STACK_CHECK_THRESH+        iNTERP_STACK_CHECK_THRESH,+        mkTupleInfoLit   ) where  #include "GhclibHsVersions.h"  import GHC.Prelude -import GHC.Driver.Env-import GHC.Driver.Session- import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter-import GHC.Runtime.Heap.Layout+import GHC.Runtime.Heap.Layout hiding ( WordOff )  import GHC.Types.Name import GHC.Types.Name.Set@@ -45,6 +42,7 @@  import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Platform+import GHC.Platform.Profile  import Control.Monad import Control.Monad.ST ( runST )@@ -96,13 +94,19 @@  -- Top level assembler fn. assembleBCOs-  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]+  :: Interp+  -> Profile+  -> [ProtoBCO Name]+  -> [TyCon]+  -> [RemotePtr ()]   -> Maybe ModBreaks   -> IO CompiledByteCode-assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do-  itblenv <- mkITbls hsc_env tycons-  bcos    <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos-  (bcos',ptrs) <- mallocStrings hsc_env bcos+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  itblenv <- mkITbls interp profile tycons+  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos+  (bcos',ptrs) <- mallocStrings interp bcos   return CompiledByteCode     { bc_bcos = bcos'     , bc_itbls =  itblenv@@ -118,10 +122,10 @@ --  b) For -fexternal-interpreter It's more efficient to malloc the strings --     as a single batch message, especially when compiling in parallel. ---mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])-mallocStrings hsc_env ulbcos = do+mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])+mallocStrings interp ulbcos = do   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])-  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)+  ptrs <- interpCmd interp (MallocStrings bytestrings)   return (evalState (mapM splice ulbcos) ptrs, ptrs)  where   splice bco@UnlinkedBCO{..} = do@@ -154,10 +158,12 @@   collectPtr _ = return ()  -assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO-assembleOneBCO hsc_env pbco = do-  ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco-  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]+assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO+assembleOneBCO interp profile pbco = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  ubco <- assembleBCO (profilePlatform profile) pbco+  ([ubco'], _ptrs) <- mallocStrings interp [ubco]   return ubco'  assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO@@ -335,7 +341,12 @@  -- Bring in all the bci_ bytecode constants. #include "rts/Bytecodes.h"+#if __GLASGOW_HASKELL__ <= 901+#  define bci_RETURN_T          69+#  define bci_PUSH_ALTS_T       70+#endif + largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci @@ -381,6 +392,16 @@                            -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit (push_alts pk) [Op p]+  PUSH_ALTS_TUPLE proto tuple_info tuple_proto+                           -> do let ul_bco = assembleBCO platform proto+                                     ul_tuple_bco = assembleBCO platform+                                                                tuple_proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)+                                 info <- int (fromIntegral $+                                              mkTupleInfoSig tuple_info)+                                 emit bci_PUSH_ALTS_T+                                      [Op p, Op info, Op p_tup]   PUSH_PAD8                -> emit bci_PUSH_PAD8 []   PUSH_PAD16               -> emit bci_PUSH_PAD16 []   PUSH_PAD32               -> emit bci_PUSH_PAD32 []@@ -439,6 +460,7 @@   ENTER                    -> emit bci_ENTER []   RETURN                   -> emit bci_RETURN []   RETURN_UBX rep           -> emit (return_ubx rep) []+  RETURN_TUPLE             -> emit bci_RETURN_T []   CCALL off m_addr i       -> do np <- addr m_addr                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]   BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray@@ -515,6 +537,90 @@ return_ubx V16 = error "return_ubx: vector" return_ubx V32 = error "return_ubx: vector" return_ubx V64 = error "return_ubx: vector"++{-+  we can only handle up to a fixed number of words on the stack,+  because we need a stg_ctoi_tN stack frame for each size N. See+  Note [unboxed tuple bytecodes and tuple_BCO].++  If needed, you can support larger tuples by adding more in+  StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and+  raising this limit.++  Note that the limit is the number of words passed on the stack.+  If the calling convention passes part of the tuple in registers, the+  maximum number of tuple elements may be larger. Elements can also+  take multiple words on the stack (for example Double# on a 32 bit+  platform).++ -}+maxTupleNativeStackSize :: WordOff+maxTupleNativeStackSize = 62++{-+  Maximum number of supported registers for returning tuples.++  If GHC uses more more than these (because of a change in the calling+  convention or a new platform) mkTupleInfoSig will panic.++  You can raise the limits after modifying stg_ctoi_t and stg_ret_t+  (StgMiscClosures.cmm) to save and restore the additional registers.+ -}+maxTupleVanillaRegs, maxTupleFloatRegs, maxTupleDoubleRegs,+    maxTupleLongRegs :: Int+maxTupleVanillaRegs = 6+maxTupleFloatRegs = 6+maxTupleDoubleRegs = 6+maxTupleLongRegs = 1++{-+  Construct the tuple_info word that stg_ctoi_t and stg_ret_t use+  to convert a tuple between the native calling convention and the+  interpreter.++  See Note [GHCi tuple layout] for more information.+ -}+mkTupleInfoSig :: TupleInfo -> Word32+mkTupleInfoSig ti@TupleInfo{..}+  | tupleNativeStackSize > maxTupleNativeStackSize =+    pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"+             (ppr tupleNativeStackSize <+> text "stack words." <+>+              text "Use -fobject-code to get around this limit"+             )+  | tupleVanillaRegs `shiftR` maxTupleVanillaRegs /= 0 =+    pprPanic "mkTupleInfoSig: too many vanilla registers" (ppr tupleVanillaRegs)+  | tupleLongRegs `shiftR` maxTupleLongRegs /= 0 =+    pprPanic "mkTupleInfoSig: too many long registers" (ppr tupleLongRegs)+  | tupleFloatRegs `shiftR` maxTupleFloatRegs /= 0 =+    pprPanic "mkTupleInfoSig: too many float registers" (ppr tupleFloatRegs)+  | tupleDoubleRegs `shiftR` maxTupleDoubleRegs /= 0 =+    pprPanic "mkTupleInfoSig: too many double registers" (ppr tupleDoubleRegs)+  {-+    Check that we can pack the register counts/bitmaps and stack size+    in the information word. In particular we check that each component+    fits in the bits we have reserved for it.++    This overlaps with some of the above checks. It's likely that if the+    number of registers changes, the number of bits will also need to be+    updated.+   -}+  | tupleNativeStackSize < 16384 && -- 14 bits stack usage+    tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float)+    tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double)+    tupleLongRegs < 4 && -- 2 bit bitmap+    tupleVanillaRegs < 65536 && -- 4 bit count (tupleVanillaRegs is still a bitmap)+    -- check that there are no "holes", i.e. that R1..Rn are all in use+    tupleVanillaRegs .&. (tupleVanillaRegs + 1) == 0+    = fromIntegral tupleNativeStackSize .|.+      unRegBitmap (tupleLongRegs `shiftL` 14) .|.+      unRegBitmap (tupleDoubleRegs `shiftL` 16) .|.+      unRegBitmap (tupleFloatRegs `shiftL` 22) .|.+      fromIntegral (countTrailingZeros (1 + tupleVanillaRegs) `shiftL` 28)+  | otherwise = pprPanic "mkTupleInfoSig: unsupported tuple shape" (ppr ti)++mkTupleInfoLit :: Platform -> TupleInfo -> Literal+mkTupleInfoLit platform tuple_info =+  mkLitWord platform . fromIntegral $ mkTupleInfoSig tuple_info  -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the

@@ -13,7 +13,6 @@ import GHC.Prelude  import GHC.Driver.Session-import GHC.Driver.Env  import GHC.Platform import GHC.Platform.Profile@@ -40,30 +39,30 @@ -}  -- Make info tables for the data decls in this module-mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv-mkITbls hsc_env tcs =+mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv+mkITbls interp profile tcs =   foldr plusNameEnv emptyNameEnv <$>-    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)+    mapM mkITbl (filter isDataTyCon tcs)  where-  mkITbl :: HscEnv -> TyCon -> IO ItblEnv-  mkITbl hsc_env tc+  mkITbl :: TyCon -> IO ItblEnv+  mkITbl tc     | dcs `lengthIs` n -- paranoia; this is an assertion.-    = make_constr_itbls hsc_env dcs+    = make_constr_itbls interp profile dcs        where           dcs = tyConDataCons tc           n   = tyConFamilySize tc-  mkITbl _ _ = panic "mkITbl"+  mkITbl _ = panic "mkITbl"  mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]  -- Assumes constructors are numbered from zero, not one-make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv-make_constr_itbls hsc_env cons =+make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv+make_constr_itbls interp profile cons =+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter   mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])  where-  profile = targetProfile (hsc_dflags hsc_env)-   mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)   mk_itbl dcon conNo = do      let rep_args = [ NonVoid prim_rep@@ -85,6 +84,6 @@          constants = platformConstants platform          tables_next_to_code = platformTablesNextToCode platform -     r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really+     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really                               conNo (tagForCon platform dcon) descr)      return (getName dcon, ItblPtr r)

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- --  (c) The University of Glasgow 2002-2006@@ -17,22 +18,19 @@ import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout     ( ArgRep(..) )-import GHC.Core.Ppr import GHC.Utils.Outputable-import GHC.Data.FastString import GHC.Types.Name import GHC.Types.Unique-import GHC.Types.Id-import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon-import GHC.Types.Var.Set import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout  import Data.Word import GHC.Stack.CCS (CostCentre) +import GHC.Stg.Syntax+ -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -45,7 +43,7 @@         protoBCOBitmapSize :: Word16,         protoBCOArity      :: Int,         -- what the BCO came from, for debugging only-        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),+        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs,         -- malloc'd pointers         protoBCOFFIs       :: [FFIInfo]    }@@ -91,6 +89,9 @@    -- Push an alt continuation    | PUSH_ALTS          (ProtoBCO Name)    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+   | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation+                        !TupleInfo+                        (ProtoBCO Name) -- tuple return BCO     -- Pushing 8, 16 and 32 bits of padding (for constructors).    | PUSH_PAD8@@ -173,8 +174,9 @@     -- To Infinity And Beyond    | ENTER-   | RETURN             -- return a lifted value+   | RETURN            -- return a lifted value    | RETURN_UBX ArgRep -- return an unlifted value, here's its rep+   | RETURN_TUPLE      -- return an unboxed tuple (info already on stack)     -- Breakpoints    | BRK_FUN          Word16 Unique (RemotePtr CostCentre)@@ -193,37 +195,46 @@       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity                 <+> text (show ffis) <> colon)         $$ nest 3 (case origin of-                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))-                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'-                      Right rhs -> pprCoreExprShort (deAnnotate rhs))+                      Left alts ->+                        vcat (zipWith (<+>) (char '{' : repeat (char ';'))+                             (map (pprStgAltShort shortStgPprOpts) alts))+                      Right rhs ->+                        pprStgRhsShort shortStgPprOpts rhs+                  )         $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)         $$ nest 3 (vcat (map ppr instrs)) --- Print enough of the Core expression to enable the reader to find--- the expression in the -ddump-prep output.  That is, we need to+-- Print enough of the STG expression to enable the reader to find+-- the expression in the -ddump-stg output.  That is, we need to -- include at least a binder. -pprCoreExprShort :: CoreExpr -> SDoc-pprCoreExprShort expr@(Lam _ _)-  = let-        (bndrs, _) = collectBinders expr-    in-    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."+pprStgExprShort :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc+pprStgExprShort _ (StgCase _expr var _ty _alts) =+  text "case of" <+> ppr var+pprStgExprShort _ (StgLet _ bnd _) =+  text "let" <+> pprStgBindShort bnd <+> text "in ..."+pprStgExprShort _ (StgLetNoEscape _ bnd _) =+  text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..."+pprStgExprShort opts (StgTick t e) = ppr t <+> pprStgExprShort opts e+pprStgExprShort opts e = pprStgExpr opts e -pprCoreExprShort (Case _expr var _ty _alts)- = text "case of" <+> ppr var+pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc+pprStgBindShort (StgNonRec x _) =+  ppr x <+> text "= ..."+pprStgBindShort (StgRec bs) =+  char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }" -pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))-pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))+pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc+pprStgAltShort opts (con, args, expr) =+  ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr -pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e-pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"+pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc+pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) =+  hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])+       4 (pprStgExprShort opts body)+pprStgRhsShort opts rhs = pprStgRhs opts rhs -pprCoreExprShort e = pprCoreExpr e -pprCoreAltShort :: CoreAlt -> SDoc-pprCoreAltShort (Alt con args expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr- instance Outputable BCInstr where    ppr (STKCHECK n)          = text "STKCHECK" <+> ppr n    ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset@@ -239,8 +250,13 @@    ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."                                                <> ppr op    ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)+    ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)    ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)+   ppr (PUSH_ALTS_TUPLE bco tuple_info tuple_bco) =+                               hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)+                                    2+                                    (ppr tuple_bco $+$ ppr bco)     ppr PUSH_PAD8             = text "PUSH_PAD8"    ppr PUSH_PAD16            = text "PUSH_PAD16"@@ -297,8 +313,11 @@    ppr ENTER                 = text "ENTER"    ppr RETURN                = text "RETURN"    ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk+   ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"    ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>" ++ -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn.  These _must_ be -- correct, or overestimates of reality, to be safe.@@ -326,8 +345,16 @@ bciStackUse PUSH_G{}              = 1 bciStackUse PUSH_PRIMOP{}         = 1 bciStackUse PUSH_BCO{}            = 1-bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} ++                                    3 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} ++                                         4 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_TUPLE bco info _) =+   -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)+   -- tuple+   -- (tuple_info, tuple_bco, stg_ret_t)+   1 {- profiling only -} ++   7 + fromIntegral (tupleSize info) + protoBCOStackUse bco bciStackUse (PUSH_PAD8)           = 1  -- overapproximation bciStackUse (PUSH_PAD16)          = 1  -- overapproximation bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch@@ -365,7 +392,8 @@ bciStackUse JMP{}                 = 0 bciStackUse ENTER{}               = 0 bciStackUse RETURN{}              = 0-bciStackUse RETURN_UBX{}          = 1+bciStackUse RETURN_UBX{}          = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header bciStackUse CCALL{}               = 0 bciStackUse SWIZZLE{}             = 0 bciStackUse BRK_FUN{}             = 0

@@ -8,19 +8,22 @@ --  -- | Bytecode assembler and linker-module GHC.ByteCode.Linker (-        ClosureEnv, emptyClosureEnv, extendClosureEnv,-        linkBCO, lookupStaticPtr,-        lookupIE,-        nameToCLabel, linkFail-  ) where+module GHC.ByteCode.Linker+  ( ClosureEnv+  , emptyClosureEnv+  , extendClosureEnv+  , linkBCO+  , lookupStaticPtr+  , lookupIE+  , nameToCLabel+  , linkFail+  )+where  #include "GhclibHsVersions.h"  import GHC.Prelude -import GHC.Driver.Env- import GHC.Runtime.Interpreter import GHC.ByteCode.Types import GHCi.RemoteTypes@@ -65,88 +68,104 @@ -}  linkBCO-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  :: Interp+  -> ItblEnv+  -> ClosureEnv+  -> NameEnv Int+  -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO hsc_env ie ce bco_ix breakarray+linkBCO interp ie ce bco_ix breakarray            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)-  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)+  lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)+  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)   return (ResolvedBCO isLittleEndian arity insns bitmap               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)               (addListToSS emptySS ptrs)) -lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word-lookupLiteral _ _ (BCONPtrWord lit) = return lit-lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do-  Ptr a# <- lookupStaticPtr hsc_env sym-  return (W# (int2Word# (addr2Int# a#)))-lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do-  Ptr a# <- lookupIE hsc_env ie nm-  return (W# (int2Word# (addr2Int# a#)))-lookupLiteral _ _ (BCONPtrStr _) =-  -- should be eliminated during assembleBCOs-  panic "lookupLiteral: BCONPtrStr"+lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word+lookupLiteral interp ie ptr = case ptr of+  BCONPtrWord lit -> return lit+  BCONPtrLbl  sym -> do+    Ptr a# <- lookupStaticPtr interp sym+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrItbl nm -> do+    Ptr a# <- lookupIE interp ie nm+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrStr _ ->+    -- should be eliminated during assembleBCOs+    panic "lookupLiteral: BCONPtrStr" -lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())-lookupStaticPtr hsc_env addr_of_label_string = do-  m <- lookupSymbol hsc_env addr_of_label_string+lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())+lookupStaticPtr interp addr_of_label_string = do+  m <- lookupSymbol interp addr_of_label_string   case m of     Just ptr -> return ptr     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"                   (unpackFS addr_of_label_string) -lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())-lookupIE hsc_env ie con_nm =+lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp ie con_nm =   case lookupNameEnv ie con_nm of     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))     Nothing -> do -- try looking up in the object files.        let sym_to_find1 = nameToCLabel con_nm "con_info"-       m <- lookupSymbol hsc_env sym_to_find1+       m <- lookupSymbol interp sym_to_find1        case m of           Just addr -> return addr           Nothing              -> do -- perhaps a nullary constructor?                    let sym_to_find2 = nameToCLabel con_nm "static_info"-                   n <- lookupSymbol hsc_env sym_to_find2+                   n <- lookupSymbol interp sym_to_find2                    case n of                       Just addr -> return addr                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"                                       (unpackFS sym_to_find1 ++ " or " ++                                        unpackFS sym_to_find2) -lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())-lookupPrimOp hsc_env primop = do+lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp primop = do   let sym_to_find = primopToCLabel primop "closure"-  m <- lookupSymbol hsc_env (mkFastString sym_to_find)+  m <- lookupSymbol interp (mkFastString sym_to_find)   case m of     Just p -> return (toRemotePtr p)     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find  resolvePtr-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  :: Interp+  -> ItblEnv+  -> ClosureEnv+  -> NameEnv Int+  -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)-  | Just ix <- lookupNameEnv bco_ix nm =-    return (ResolvedBCORef ix) -- ref to another BCO in this group-  | Just (_, rhv) <- lookupNameEnv ce nm =-    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))-  | otherwise =-    ASSERT2(isExternalName nm, ppr nm)-    do let sym_to_find = nameToCLabel nm "closure"-       m <- lookupSymbol hsc_env sym_to_find-       case m of-         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))-         Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)-resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =-  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op-resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =-  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco-resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =-  return (ResolvedBCOPtrBreakArray breakarray)+resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of+  BCOPtrName nm+    | Just ix <- lookupNameEnv bco_ix nm+    -> return (ResolvedBCORef ix) -- ref to another BCO in this group++    | Just (_, rhv) <- lookupNameEnv ce nm+    -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))++    | otherwise+    -> ASSERT2(isExternalName nm, ppr nm)+       do+          let sym_to_find = nameToCLabel nm "closure"+          m <- lookupSymbol interp sym_to_find+          case m of+            Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)++  BCOPtrPrimOp op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op++  BCOPtrBCO bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco++  BCOPtrBreakArray+    -> return (ResolvedBCOPtrBreakArray breakarray)  linkFail :: String -> String -> IO a linkFail who what

@@ -39,13 +39,13 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import GHC.Core import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Utils.Misc      ( seqList )  import GHC.Cmm.Dataflow.Block@@ -118,7 +118,7 @@               -- recover by copying ticks below.               scp' | SubScope _ scp' <- scp      = scp'                    | CombinedScope scp' _ <- scp = scp'-#if __GLASGOW_HASKELL__ <= 810+#if __GLASGOW_HASKELL__ < 901                    | otherwise                   = panic "findP impossible" #endif 

@@ -8,7 +8,8 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Monad      ( newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation  import GHC.Types.Basic

@@ -218,13 +218,13 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign import GHC.StgToCmm.Expr+import GHC.StgToCmm.Lit import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout     hiding (ArgRep(..)) import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame ) -import GHC.Core           ( Tickish(SourceNote) )- import GHC.Cmm.Opt import GHC.Cmm.Graph import GHC.Cmm@@ -249,6 +249,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.SrcLoc+import GHC.Types.Tickish  ( GenTickish(SourceNote) ) import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config@@ -1448,8 +1449,9 @@   ]   where platform = profilePlatform profile -parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe CmmGroup)-parseCmmFile dflags home_unit filename = do++parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))+parseCmmFile dflags this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let         init_loc = mkRealSrcLoc (mkFastString filename) 1 1@@ -1463,8 +1465,13 @@         return (warnings, errors, Nothing)     POk pst code -> do         st <- initC-        let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()-            (cmm,_) = runC dflags no_module st fcode+        let fcode = do+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)+                                              (mapMaybe topInfoTable cmm)+              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info+              return (cmm ++ cmm2, used_info)+            (cmm, _) = runC dflags no_module st fcode             (warnings,errors) = getMessages pst         if not (isEmptyBag errors)          then return (warnings, errors, Nothing)

@@ -5,13 +5,16 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,-    DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -168,6 +171,7 @@       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"+      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" 

@@ -7,7 +7,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Expr        ( GlobalReg(..) ) import GHC.Settings.Config ( cProjectName, cProjectVersion )-import GHC.Core            ( Tickish(..) )+import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock import GHC.Unit.Module import GHC.Utils.Outputable@@ -210,7 +210,7 @@       | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk       | otherwise                 = Nothing   -- block was optimized out -tickToDwarf :: Tickish () -> [DwarfInfo]+tickToDwarf :: CmmTickish -> [DwarfInfo] tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss] tickToDwarf _ = [] 

@@ -57,7 +57,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Core              ( Tickish(..) )+import GHC.Types.Tickish     ( GenTickish(..) ) import GHC.Types.SrcLoc      ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )  -- The rest:@@ -2381,6 +2381,10 @@ coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do     (src, code) <- getSomeReg x     platform <- getPlatform+    upper <- getNewRegNat II64+    lower <- getNewRegNat II64+    l1 <- getBlockIdNat+    l2 <- getBlockIdNat     let         code' dst = code `appOL` maybe_exts `appOL` toOL [                 ST II64 src (spRel platform 3),@@ -2388,12 +2392,28 @@                 FCFID dst dst             ] `appOL` maybe_frsp dst -        maybe_exts = case fromRep of-                        W8 ->  unitOL $ EXTS II8 src src-                        W16 -> unitOL $ EXTS II16 src src-                        W32 -> unitOL $ EXTS II32 src src-                        W64 -> nilOL-                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"+        maybe_exts+          = case fromRep of+              W8 ->  unitOL $ EXTS II8 src src+              W16 -> unitOL $ EXTS II16 src src+              W32 -> unitOL $ EXTS II32 src src+              W64 -> case toRep of+                        W32 -> toOL [ SRA II64 upper src (RIImm (ImmInt 53))+                                    , CLRLI II64 lower src 53+                                    , ADD upper upper (RIImm (ImmInt 1))+                                    , ADD lower lower (RIImm (ImmInt 2047))+                                    , CMPL II64 upper (RIImm (ImmInt 2))+                                    , OR lower lower (RIReg src)+                                    , CLRRI II64 lower lower 11+                                    , BCC LTT l2 Nothing+                                    , BCC ALWAYS l1 Nothing+                                    , NEWBLOCK l1+                                    , MR src lower+                                    , BCC ALWAYS l2 Nothing+                                    , NEWBLOCK l2+                                    ]+                        _   -> nilOL+              _       -> panic "PPC.CodeGen.coerceInt2FP: no match"          maybe_frsp dst                 = case toRep of

@@ -38,15 +38,13 @@ import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import GHC.Exts hiding (extendWord8#)+import GHC.Exts import GHC.Word -#if MIN_VERSION_base(4,16,0)-import GHC.Base (extendWord8#)-#else-extendWord8# :: Word# -> Word#-extendWord8# w = w-{-# INLINE extendWord8# #-}+#if !MIN_VERSION_base(4,16,0)+word8ToWord# :: Word# -> Word#+word8ToWord# w = w+{-# INLINE word8ToWord# #-} #endif  -- -----------------------------------------------------------------------------@@ -111,7 +109,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# (extendWord8# w#)))+       chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))         octal :: Word8 -> String        octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)

@@ -120,6 +120,7 @@                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER@@ -151,6 +152,7 @@                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT@@ -184,6 +186,7 @@                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE

@@ -172,18 +172,18 @@         | LiveInfo info entry_ids@(first_id:_) block_live _ <- static         = do                 -- do register allocation on each component.-                (final_blocks, stats, stack_use)+                !(!final_blocks, !stats, !stack_use)                         <- linearRegAlloc config entry_ids block_live sccs                  -- make sure the block that was first in the input list                 --      stays at the front of the output-                let ((first':_), rest')+                let !(!(!first':_), !rest')                                 = partition ((== first_id) . blockId) final_blocks                  let max_spill_slots = maxSpillSlots config                     extra_stack                       | stack_use > max_spill_slots-                      = Just (stack_use - max_spill_slots)+                      = Just $! stack_use - max_spill_slots                       | otherwise                       = Nothing @@ -228,6 +228,7 @@       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"+      ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"  where@@ -252,7 +253,7 @@  linearRegAlloc' config initFreeRegs entry_ids block_live sccs  = do   us      <- getUniqueSupplyM-        let (_, stack, stats, blocks) =+        let !(_, !stack, !stats, !blocks) =                 runR config mapEmpty initFreeRegs emptyRegMap emptyStackMap us                     $ linearRA_SCCs entry_ids block_live [] sccs         return  (blocks, stats, getStackUse stack)@@ -276,7 +277,7 @@  linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)  = do-        blockss' <- process entry_ids block_live blocks [] (return []) False+        blockss' <- process entry_ids block_live blocks         linearRA_SCCs entry_ids block_live                 (reverse (concat blockss') ++ blocksAcc)                 sccs@@ -293,45 +294,41 @@    more sanity checking to guard against this eventuality. -} -process :: OutputableRegConstraint freeRegs instr+process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => [BlockId]         -> BlockMap RegSet         -> [GenBasicBlock (LiveInstr instr)]-        -> [GenBasicBlock (LiveInstr instr)]-        -> [[NatBasicBlock instr]]-        -> Bool         -> RegM freeRegs [[NatBasicBlock instr]]--process _ _ [] []         accum _-        = return $ reverse accum--process entry_ids block_live [] next_round accum madeProgress-        | not madeProgress+process entry_ids block_live =+    \blocks -> go blocks [] (return []) False+  where+    go :: [GenBasicBlock (LiveInstr instr)]+       -> [GenBasicBlock (LiveInstr instr)]+       -> [[NatBasicBlock instr]]+       -> Bool+       -> RegM freeRegs [[NatBasicBlock instr]]+    go [] []         accum _madeProgress+      = return $ reverse accum +    go [] next_round accum madeProgress+      | not madeProgress           {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.              pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."                 (  text "Unreachable blocks:"                 $$ vcat (map ppr next_round)) -}-        = return $ reverse accum--        | otherwise-        = process entry_ids block_live-                  next_round [] accum False+      = return $ reverse accum -process entry_ids block_live (b@(BasicBlock id _) : blocks)-        next_round accum madeProgress- = do-        block_assig <- getBlockAssigR+      | otherwise+      = go next_round [] accum False -        if isJust (mapLookup id block_assig)-             || id `elem` entry_ids-         then do-                b'  <- processBlock block_live b-                process entry_ids block_live blocks-                        next_round (b' : accum) True+    go (b@(BasicBlock id _) : blocks) next_round accum madeProgress+      = do+          block_assig <- getBlockAssigR+          if isJust (mapLookup id block_assig) || id `elem` entry_ids+            then do b' <- processBlock block_live b+                    go blocks next_round (b' : accum) True -         else   process entry_ids block_live blocks-                        (b : next_round) accum madeProgress+            else do go blocks (b : next_round) accum madeProgress   -- | Do register allocation on this basic block@@ -347,7 +344,7 @@         initBlock id block_live          (instrs', fixups)-                <- linearRA block_live [] [] id instrs+                <- linearRA block_live id instrs         -- pprTraceM "blockResult" $ ppr (instrs', fixups)         return  $ BasicBlock id instrs' : fixups @@ -384,30 +381,28 @@  -- | Do allocation for a sequence of instructions. linearRA-        :: OutputableRegConstraint freeRegs instr+        :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.-        -> [instr]                              -- ^ accumulator for instructions already processed.-        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.         -> BlockId                              -- ^ id of the current block, for debugging.         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.-         -> RegM freeRegs                 ( [instr]                       --   instructions after register allocation                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.---linearRA _          accInstr accFixup _ []-        = return-                ( reverse accInstr              -- instrs need to be returned in the correct order.-                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.---linearRA block_live accInstr accFixups id (instr:instrs)- = do-        (accInstr', new_fixups) <- raInsn block_live accInstr id instr--        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs+linearRA block_live block_id = go [] []+  where+    go :: [instr]                              -- ^ accumulator for instructions already processed.+       -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.+       -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.+       -> RegM freeRegs+               ( [instr]                       --   instructions after register allocation+               , [NatBasicBlock instr] )       --   fresh blocks of fixup code.+    go !accInstr !accFixups [] = do+        return ( reverse accInstr               -- instrs need to be returned in the correct order.+               , accFixups )                    -- it doesn't matter what order the fixup blocks are returned in. +    go accInstr accFixups (instr:instrs) = do+        (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr+        go accInstr' (new_fixups ++ accFixups) instrs  -- | Do allocation for a single instruction. raInsn@@ -600,8 +595,7 @@                                  | src == dst   -> []                                 _               -> [patched_instr] -    let code = squashed_instr ++ w_spills ++ reverse r_spills-                ++ clobber_saves ++ new_instrs+    let code = concat [ squashed_instr, w_spills, reverse r_spills, clobber_saves, new_instrs ]  --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do@@ -857,7 +851,7 @@         case freeRegs_thisClass of          -- case (2): we have a free register          (first_free : _) ->-           do   let final_reg+           do   let !final_reg                         | Just reg <- pref_reg                         , reg `elem` freeRegs_thisClass                         = reg

@@ -83,5 +83,6 @@    ArchAlpha     -> panic "maxSpillSlots ArchAlpha"    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"+   ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"    ArchUnknown   -> panic "maxSpillSlots ArchUnknown"

@@ -50,6 +50,7 @@ import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Exts (oneShot)  import Control.Monad (ap) @@ -64,16 +65,21 @@         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }         deriving (Functor) +-- | Smart constructor for 'RegM', as described in Note [The one-shot state+-- monad trick] in GHC.Utils.Monad.+mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a+mkRegM f = RegM (oneShot f)+ instance Applicative (RegM freeRegs) where-      pure a  =  RegM $ \s -> RA_Result s a+      pure a  =  mkRegM $ \s -> RA_Result s a       (<*>) = ap  instance Monad (RegM freeRegs) where-  m >>= k   =  RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }+  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }  -- | Get native code generator configuration getConfig :: RegM a NCGConfig-getConfig = RegM $ \s -> RA_Result s (ra_config s)+getConfig = mkRegM $ \s -> RA_Result s (ra_config s)  -- | Get target platform from native code generator configuration getPlatform :: RegM a Platform@@ -117,7 +123,7 @@ spillR :: Instruction instr        => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \s ->+spillR reg temp = mkRegM $ \s ->   let (stack1,slot) = getStackSlotFor (ra_stack s) temp       instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot   in@@ -127,42 +133,42 @@ loadR :: Instruction instr       => Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \s ->+loadR reg slot = mkRegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)  getFreeRegsR :: RegM freeRegs freeRegs-getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->+getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->   RA_Result s freeregs  setFreeRegsR :: freeRegs -> RegM freeRegs ()-setFreeRegsR regs = RegM $ \ s ->+setFreeRegsR regs = mkRegM $ \ s ->   RA_Result s{ra_freeregs = regs} ()  getAssigR :: RegM freeRegs (RegMap Loc)-getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->+getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->   RA_Result s assig  setAssigR :: RegMap Loc -> RegM freeRegs ()-setAssigR assig = RegM $ \ s ->+setAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_assig=assig} ()  getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)-getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->+getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->   RA_Result s assig  setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()-setBlockAssigR assig = RegM $ \ s ->+setBlockAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_blockassig = assig} ()  setDeltaR :: Int -> RegM freeRegs ()-setDeltaR n = RegM $ \ s ->+setDeltaR n = mkRegM $ \ s ->   RA_Result s{ra_delta = n} ()  getDeltaR :: RegM freeRegs Int-getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)+getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)  getUniqueR :: RegM freeRegs Unique-getUniqueR = RegM $ \s ->+getUniqueR = mkRegM $ \s ->   case takeUniqFromSupply (ra_us s) of     (uniq, us) -> RA_Result s{ra_us = us} uniq @@ -170,9 +176,9 @@ -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill-    = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()+    = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()  -- | Record a created fixup block recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () recordFixupBlock from between to-    = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()+    = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()

@@ -52,6 +52,7 @@       ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"+      ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"       ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown" @@ -71,6 +72,7 @@       ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"+      ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"       ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown" @@ -89,6 +91,7 @@       ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"+      ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"       ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown" @@ -107,6 +110,7 @@       ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"+      ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"       ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown" @@ -125,6 +129,7 @@       ArchAlpha     -> panic "targetRegDotColor ArchAlpha"       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"+      ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"       ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"       ArchUnknown   -> panic "targetRegDotColor ArchUnknown" 

@@ -4,13 +4,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-} -#if __GLASGOW_HASKELL__ <= 808--- GHC 8.10 deprecates this flag, but GHC 8.8 needs it--- The default iteration limit is a bit too low for the definitions--- in this module.-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}-#endif- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -79,7 +72,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel-import GHC.Core          ( Tickish(..) )+import GHC.Types.Tickish ( GenTickish(..) ) import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )  -- The rest:

@@ -1304,13 +1304,24 @@ commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs --- Print in C hex format: 0x13fa+-- | Print in C hex format+--+-- Examples:+--+--   5114    :: W32  ===>  ((StgWord32)0x13faU)+--   (-5114) :: W32  ===>  ((StgWord32)(-0x13faU))+--+-- We use casts to support types smaller than `unsigned int`; C literal+-- suffixes support longer but not shorter types. pprHexVal :: Platform -> Integer -> Width -> SDoc-pprHexVal platform w rep-  | w < 0     = parens (char '-' <>-                    text "0x" <> intToDoc (-w) <> repsuffix rep)-  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+pprHexVal platform w rep = parens ctype <> rawlit   where+      rawlit+        | w < 0     = parens (char '-' <>+                          text "0x" <> intToDoc (-w) <> repsuffix rep)+        | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+      ctype = machRep_U_CType platform rep+         -- type suffix for literals:         -- Integer literals are unsigned in Cmm/C.  We explicitly cast to         -- signed values for doing signed operations, but at all other

@@ -66,7 +66,8 @@          let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags          when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $            "You are using an unsupported version of LLVM!" $$-           "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>+           "Currently only" <+> text (llvmVersionStr supportedLlvmVersionMin) <+>+           "to" <+> text (llvmVersionStr supportedLlvmVersionMax) <+> "is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."          let isS390X = platformArch (targetPlatform dflags) == ArchS390X@@ -75,8 +76,14 @@            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>            "You are using LLVM version: " <> text (llvmVersionStr ver) +       -- HACK: the Nothing case here is potentially wrong here but we+       -- currently don't use the LLVM version to guide code generation+       -- so this is okay.+       let llvm_ver :: LlvmVersion+           llvm_ver = fromMaybe supportedLlvmVersionMin mb_ver+        -- run code generation-       a <- runLlvm logger dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $+       a <- runLlvm logger dflags llvm_ver bufh $          llvmCodeGen' dflags cmm_stream         bFlush bufh

@@ -15,7 +15,8 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,+        LlvmVersion, supportedLlvmVersionMin, supportedLlvmVersionMax,+        llvmVersionSupported, parseLlvmVersion,         llvmVersionStr, llvmVersionList,          LlvmM,@@ -265,6 +266,7 @@  -- Newtype to avoid using the Eq instance! newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)  parseLlvmVersion :: String -> Maybe LlvmVersion parseLlvmVersion =@@ -281,11 +283,13 @@         (ver_str, rest) = span isDigit s  -- | The LLVM Version that is currently supported.-supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])+supportedLlvmVersionMin, supportedLlvmVersionMax :: LlvmVersion+supportedLlvmVersionMin = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])+supportedLlvmVersionMax = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])  llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION+llvmVersionSupported v =+  v > supportedLlvmVersionMin && v <= supportedLlvmVersionMax  llvmVersionStr :: LlvmVersion -> String llvmVersionStr = intercalate "." . map show . llvmVersionList

@@ -32,6 +32,7 @@ import GHC.Core.Map.Type import GHC.Core import GHC.Core.Type+import GHC.Types.Tickish import GHC.Types.Var  import GHC.Utils.Misc@@ -324,11 +325,11 @@                                                      in xtList (xtA env1) as f }  -- TODO: this seems a bit dodgy, see 'eqTickish'-type TickishMap a = Map.Map (Tickish Id) a-lkTickish :: Tickish Id -> TickishMap a -> Maybe a+type TickishMap a = Map.Map CoreTickish a+lkTickish :: CoreTickish -> TickishMap a -> Maybe a lkTickish = lookupTM -xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a+xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a xtTickish = alterTM  ------------------------

@@ -18,7 +18,7 @@ import GHC.Core.Subst import GHC.Types.Var    ( Var ) import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Id     ( Id, idType, idHasRules+import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding                         , idInlineActivation, setInlineActivation                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma                         , isJoinId, isJoinId_maybe )@@ -30,6 +30,7 @@ import GHC.Core import GHC.Utils.Outputable import GHC.Types.Basic+import GHC.Types.Tickish import GHC.Core.Map.Expr import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn ) import GHC.Utils.Panic@@ -236,8 +237,8 @@  Nor do we want to change the reverse mapping. Suppose we have -   {-# Unf = Stable (\pq. build blah) #-}-   foo = <expr>+   foo {-# Unf = Stable (\pq. build blah) #-}+       = <expr>    bar = <expr>  There could conceivably be merit in rewriting the RHS of bar:@@ -250,6 +251,23 @@ In this case we still want to do CSE (#13340). Hence the use of isAnyInlinePragma rather than isStableUnfolding. +Now consider+   foo = <expr>+   bar {-# Unf = Stable ... #-}+      = <expr>++where the unfolding was added by strictness analysis, say.  Then+CSE goes ahead, so we get+   bar = foo+and probably use SUBSTITUTE that will make 'bar' dead.  But just+possibly not -- see Note [Dealing with ticks].  In that case we might+be left with+   bar = tick t1 (tick t2 foo)+in which case we would really like to get rid of the stable unfolding+(generated by the strictness analyser, say).  Hence the zapStableUnfolding+in cse_bind.  Not a big deal, and only makes a difference when ticks+get into the picture.+ Note [Corner case for case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another reason that we do not use SUBSTITUTE for@@ -389,9 +407,10 @@   | otherwise   = (env', (out_id'', out_rhs))   where-    (env', out_id') = addBinding env in_id out_id out_rhs-    (cse_done, out_rhs) = try_for_cse env in_rhs-    out_id'' | cse_done  = delayInlining toplevel out_id'+    (env', out_id') = addBinding env in_id out_id out_rhs cse_done+    (cse_done, out_rhs)  = try_for_cse env in_rhs+    out_id'' | cse_done  = zapStableUnfolding $+                           delayInlining toplevel out_id'              | otherwise = out_id'  delayInlining :: TopLevelFlag -> Id -> Id@@ -409,19 +428,23 @@   | otherwise   = bndr -addBinding :: CSEnv                      -- Includes InId->OutId cloning-           -> InVar                      -- Could be a let-bound type-           -> OutId -> OutExpr           -- Processed binding-           -> (CSEnv, OutId)             -- Final env, final bndr+addBinding :: CSEnv            -- Includes InId->OutId cloning+           -> InVar            -- Could be a let-bound type+           -> OutId -> OutExpr -- Processed binding+           -> Bool             -- True <=> RHS was CSE'd and is a variable+                               --          or maybe (Tick t variable)+           -> (CSEnv, OutId)   -- Final env, final bndr -- Extend the CSE env with a mapping [rhs -> out-id] -- unless we can instead just substitute [in-id -> rhs] -- -- It's possible for the binder to be a type variable (see -- Note [Type-let] in GHC.Core), in which case we can just substitute.-addBinding env in_id out_id rhs'+addBinding env in_id out_id rhs' cse_done   | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)   | noCSE in_id      = (env,                              out_id)   | use_subst        = (extendCSSubst env in_id rhs',     out_id)+  | cse_done         = (env,                              out_id)+                       -- See Note [Dealing with ticks]   | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)   where     id_expr'  = varToCoreExpr out_id@@ -438,9 +461,8 @@      -- Should we use SUBSTITUTE or EXTEND?     -- See Note [CSE for bindings]-    use_subst = case rhs' of-                   Var {} -> True-                   _      -> False+    use_subst | Var {} <- rhs' = True+              | otherwise      = False  -- | Given a binder `let x = e`, this function -- determines whether we should add `e -> x` to the cs_map@@ -487,6 +509,38 @@  This is done by cse_bind.  I got it wrong the first time (#13367). +Note [Dealing with ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~+Ticks complicate CSE a bit, as I discovered in the fallout from+fixing #19360.++* To get more CSE-ing, we strip all the tickishFloatable ticks from+  an expression+  - when inserting into the cs_map (see extendCSEnv)+  - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse)+  Quite why only the tickishFloatble ticks, I'm not quite sure.++* If we get a hit in cs_map, we wrap the result in the ticks from the+  thing we are looking up (see try_for_cse)++Net result: if we get a hit, we might replace+  let x = tick t1 (tick t2 e)+with+  let x = tick t1 (tick t2 y)+where 'y' is the variable that 'e' maps to.  Now consider addBinding for+the binding for 'x':++* We can't use SUBSTITUTE because those ticks might not be trivial (we+  use tickishIsCode in exprIsTrivial)++* We should not use EXTEND, because we definitely don't want to+  add  (tick t1 (tick t2 y)) :-> x+  to the cs_map. Remember we strip off the ticks, so that would amount+  to adding y :-> x, very silly.++TL;DR: we do neither; hence the cse_done case in addBinding.++ Note [Delay inlining after CSE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#15445) we have@@ -603,14 +657,14 @@     combineAlts alt_env (map cse_alt alts)   where     ty' = substTy (csEnvSubst env) ty-    scrut1 = tryForCSE env scrut+    (cse_done, scrut1) = try_for_cse env scrut      bndr1 = zapIdOccInfo bndr       -- Zapping the OccInfo is needed because the extendCSEnv       -- in cse_alt may mean that a dead case binder       -- becomes alive, and Lint rejects that     (env1, bndr2)    = addBinder env bndr1-    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 cse_done          -- addBinding: see Note [CSE for case expressions]      con_target :: OutExpr

@@ -706,7 +706,7 @@         | isDeadEndDiv result_info = length demands         | otherwise = a -    (demands, result_info) = splitStrictSig (idStrictness v)+    (demands, result_info) = splitDmdSig (idDmdSig v)  --------------------------------------- -- Functions related to CallArityRes --

@@ -21,20 +21,26 @@ import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Basic-import GHC.Core.DataCon import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Core.DataCon+import GHC.Core.Multiplicity import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram ) import GHC.Core.Type import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )-import GHC.Data.Maybe   ( isJust, isNothing )+import GHC.Data.Graph.UnVar -- for UnVarSet+import GHC.Data.Maybe   ( isNothing )  import Control.Monad ( guard ) import Data.List ( mapAccumL ) +import GHC.Driver.Ppr+_ = pprTrace -- Tired of commenting out the import all the time+ {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that@@ -108,7 +114,7 @@   let env            = emptyAnalEnv fam_envs   let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds   dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $-    dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr+    dumpIdInfoOfProgram (ppr . cprSigInfo) binds_plus_cpr   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_cpr `seq` return binds_plus_cpr @@ -177,7 +183,8 @@   | otherwise   = (lam_ty, Lam var body')   where-    env'             = extendSigEnvForDemand env var (idDemandInfo var)+    -- See Note [CPR for binders that will be unboxed]+    env'             = extendSigEnvForArg env var     (body_ty, body') = cprAnal env' body     lam_ty           = abstractCprTy body_ty @@ -185,11 +192,8 @@   = (res_ty, Case scrut' case_bndr ty alts')   where     (scrut_ty, scrut') = cprAnal env scrut-    -- We used to give the case binder the CPR property unconditionally.-    -- See Historic Note [Optimistic case binder CPR]     env'               = extendSigEnv env case_bndr (CprSig scrut_ty)-    be_optimistic      = assumeOptimisticFieldCpr scrut scrut_ty-    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' be_optimistic) alts+    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' scrut_ty) alts     res_ty             = foldl' lubCprType botCprType alt_tys  cprAnal' env (Let (NonRec id rhs) body)@@ -206,49 +210,28 @@  cprAnalAlt   :: AnalEnv-  -> Bool     -- ^ Does Note [Optimistic field binder CPR] apply?-  -> Alt Var  -- ^ current alternative+  -> CprType -- ^ CPR type of the scrutinee+  -> Alt Var -- ^ current alternative   -> (CprType, Alt Var)-cprAnalAlt env be_optimistic (Alt con bndrs rhs)+cprAnalAlt env scrut_ty (Alt con bndrs rhs)   = (rhs_ty, Alt con bndrs rhs')   where     env_alt-      | DataAlt dc <- con, be_optimistic-      -- Optimistically give strictly used field binders the CPR property.-      -- See Note [Optimistic field binder CPR].-      -- What we actually want here is Nested CPR.-      = giveStrictFieldsCpr env dc bndrs+      | DataAlt dc <- con+      , let ids = filter isId bndrs+      , CprType arity cpr <- scrut_ty+      , ASSERT( arity == 0 ) True+      = case unpackConFieldsCpr dc cpr of+          AllFieldsSame field_cpr+            | let sig = mkCprSig 0 field_cpr+            -> extendSigEnvAllSame env ids sig+          ForeachField field_cprs+            | let sigs = zipWith (mkCprSig . idArity) ids field_cprs+            -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)       | otherwise       = env     (rhs_ty, rhs') = cprAnal env_alt rhs -giveStrictFieldsCpr :: AnalEnv -> DataCon -> [Id] -> AnalEnv--- See Note [Optimistic field binder CPR]-giveStrictFieldsCpr env dc bs = foldl' do_one_field env (fields_w_dmds dc bs)-  where-    -- 'extendSigEnvForDemand' gives 'id' the CPR property if 'dmd' is strict-    do_one_field env (id, dmd) = extendSigEnvForDemand env id dmd-    fields_w_dmds dc bndrs = -- returns the fields paired with their 'idDemandInfo'-       -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils-       [ (id, applyWhen (isMarkedStrict mark) strictifyDmd (idDemandInfo id))-       | (id, mark) <- filter isId bndrs `zip` dataConRepStrictness dc-       ]---- | Decide whether to optimistically give 'DataAlt' field binders the CPR--- property based on strictness.--- Tests (A) and (B) of Note [Optimistic field binder CPR].-assumeOptimisticFieldCpr :: CoreExpr -> CprType -> Bool-assumeOptimisticFieldCpr scrut scrut_ty = is_var scrut && case_will_cancel-  where-    -- Test (A): The case will only cancel when 'scrut' has the CPR property.-    case_will_cancel | CprType 0 cpr <- scrut_ty = isJust (asConCpr cpr)-                     | otherwise                 = False-    -- Test (B): Guess whether 'scrut' is a parameter. Surely not if it's not a-    -- variable!-    is_var (Cast e _) = is_var e-    is_var (Var v)    = isLocalId v-    is_var _          = False- -- -- * CPR transformer --@@ -269,7 +252,7 @@       = fst $ cprAnal env rhs       -- Imported function or data con worker       | isGlobalId id-      = getCprSig (idCprInfo id)+      = getCprSig (idCprSig id)       | otherwise       = topCprType @@ -291,11 +274,11 @@       | otherwise              = mkCprSig 0 botCpr     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal     orig_virgin = ae_virgin orig_env-    init_pairs | orig_virgin  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]                | otherwise    = orig_pairs-    init_env = extendSigEnvList orig_env (map fst init_pairs)+    init_env = extendSigEnvFromIds orig_env (map fst init_pairs) -    -- The fixed-point varies the idCprInfo field of the binders and and their+    -- The fixed-point varies the idCprSig field of the binders and and their     -- entries in the AnalEnv, and terminates if that annotation does not change     -- any more.     loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])@@ -308,7 +291,7 @@         (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs         -- Make sure we reset the virgin flag to what it was when we are stable         reset_env'     = env'{ ae_virgin = orig_virgin }-        found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs+        found_fixpoint = map (idCprSig . fst) pairs' == map (idCprSig . fst) pairs      step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])     step env pairs = mapAccumL go env pairs@@ -342,7 +325,7 @@       | otherwise   = rhs_ty     -- See Note [Arity trimming for CPR signatures]     sig  = mkCprSigForArity (idArity id) rhs_ty'-    id'  = setIdCprInfo id sig+    id'  = setIdCprSig id sig     env' = extendSigEnv env id sig      -- See Note [CPR for thunks]@@ -413,36 +396,69 @@   -- ^ Needed when expanding type families and synonyms of product types.   } -type SigEnv = VarEnv CprSig- instance Outputable AnalEnv where   ppr (AE { ae_sigs = env, ae_virgin = virgin })     = text "AE" <+> braces (vcat          [ text "ae_virgin =" <+> ppr virgin          , text "ae_sigs =" <+> ppr env ]) +-- | An environment storing 'CprSig's for local Ids.+-- Puts binders with 'topCprSig' in a space-saving 'IntSet'.+-- See Note [Efficient Top sigs in SigEnv].+data SigEnv+  = SE+  { se_tops :: !UnVarSet+  -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.+  , se_sigs :: !(VarEnv CprSig)+  -- ^ Ids that have something other than 'topCprSig'.+  }++instance Outputable SigEnv where+  ppr (SE { se_tops = tops, se_sigs = sigs })+    = text "SE" <+> braces (vcat+         [ text "se_tops =" <+> ppr tops+         , text "se_sigs =" <+> ppr sigs ])+ emptyAnalEnv :: FamInstEnvs -> AnalEnv emptyAnalEnv fam_envs   = AE-  { ae_sigs = emptyVarEnv+  { ae_sigs = SE emptyUnVarSet emptyVarEnv   , ae_virgin = True   , ae_fam_envs = fam_envs   } --- | Extend an environment with the CPR sigs attached to the id-extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv-extendSigEnvList env ids-  = env { ae_sigs = sigs' }-  where-    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]+modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv+modifySigEnv f env = env { ae_sigs = f (ae_sigs env) } +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig+-- See Note [Efficient Top sigs in SigEnv]+lookupSigEnv AE{ae_sigs = SE tops sigs} id+  | id `elemUnVarSet` tops = Just topCprSig+  | otherwise              = lookupVarEnv sigs id+ extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+-- See Note [Efficient Top sigs in SigEnv] extendSigEnv env id sig-  = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }+  | isTopCprSig sig+  = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env+  | otherwise+  = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env -lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id+-- | Extend an environment with the (Id, CPR sig) pairs+extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv+extendSigEnvList env ids_cprs+  = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs +-- | Extend an environment with the CPR sigs attached to the ids+extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv+extendSigEnvFromIds env ids+  = foldl' (\env id -> extendSigEnv env id (idCprSig id)) env ids++-- | Extend an environment with the same CPR sig for all ids+extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv+extendSigEnvAllSame env ids sig+  = foldl' (\env id -> extendSigEnv env id sig) env ids+ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -451,29 +467,63 @@ -- In this case, we can still look at their demand to attach CPR signatures -- anticipating the unboxing done by worker/wrapper. -- See Note [CPR for binders that will be unboxed].-extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv-extendSigEnvForDemand env id dmd-  | isId id-  , Just (_, DataConPatContext { dcpc_dc = dc })-      <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd-  = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))-  | otherwise-  = env+extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv+extendSigEnvForArg env id+  = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id)))++-- | Produces a 'CprType' according to how a strict argument will be unboxed.+-- Examples:+--+--   * A head-strict demand @1L@ on @Int@ would translate to @1@+--   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@+--   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,+--     because the unboxing strategy would not unbox the @a@.+argCprType :: AnalEnv -> Type -> Demand -> CprType+argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)   where+    go ty dmd+      | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds+          <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd+      -- No existentials; see Note [Which types are unboxed?])+      -- Otherwise we'd need to call dataConRepInstPat here and thread a+      -- UniqSupply. So argCprType is a bit less aggressive than it could+      -- be, for the sake of coding convenience.+      , null (dataConExTyCoVars dc)+      , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)+      = ConCpr (dataConTag dc) (zipWith go arg_tys ds)+      | otherwise+      = topCpr     -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE     -- function, we just assume that we aren't. That flag is only relevant     -- to Note [Do not unpack class dictionaries], the few unboxing     -- opportunities on dicts it prohibits are probably irrelevant to CPR.-    has_inlineable_prag = False+    no_inlineable_prag = False  {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Fixed-point iteration may fail to terminate. But we cannot simply give up and return the environment and code unchanged! We still need to do one additional round, to ensure that all expressions have been traversed at least once, and any unsound CPR annotations have been updated. +Note [Efficient Top sigs in SigEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's pretty common for binders in the SigEnv to have a 'topCprSig'.+Wide records with 100 fields like in T9675 even will generate code where the+majority of binders has Top signature. To save some allocations, we store+those binders with a Top signature in a separate UnVarSet (which is an IntSet+with a convenient Var-tailored API).++Why store top signatures at all in the SigEnv? After all, when 'cprTransform'+encounters a locally-bound Id without an entry in the SigEnv, it should behave+as if that binder has a Top signature!+Well, the problem is when case binders should have a Top signatures. They always+have an unfolding and thus look to 'cprTransform' as if they bind a data+structure, Note [CPR for data structures], and thus would always have the CPR+property. So we need some mechanism to separate data structures from case+binders with a Top signature, and the UnVarSet provides that in the least+convoluted way I can think of.+ Note [CPR for binders that will be unboxed] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a lambda-bound variable will be unboxed by worker/wrapper (so it must be@@ -496,21 +546,37 @@ f1, and so the boxed version *won't* be available; in that case it's very helpful to give 'x' the CPR property. -This is all done in 'extendSigEnvForDemand'.+This is all done in 'extendSigEnvForArg'.  Note that -  * We only want to do this for something that definitely unboxes as per-    'wantToUnbox', else we may get over-optimistic CPR results e.g.-    (from \x -> x!).+  * Whether or not something unboxes is decided by 'wantToUnbox', else we may+    get over-optimistic CPR results (e.g., from \(x :: a) -> x!). -  * This also (approximately) applies to DataAlt field binders;-    See Note [Optimistic field binder CPR].+  * If the demand unboxes deeply, we can give the binder a /nested/ CPR+    property, e.g. +      g :: (Int, Int) -> Int+      g p = case p of+        (x, y) | x < 0     -> 0+               | otherwise -> x++    `x` should have the CPR property because it will be unboxed. We do so+    by giving `p` the Nested CPR property `1(1,)`, indicating that we not only+    have `p` available unboxed, but also its field `x`. Analysis of the Case+    will then transfer the CPR property to `x`.++    Before we were able to express Nested CPR, we used to guess which field+    binders should get the CPR property.+    See Historic Note [Optimistic field binder CPR].+   * See Note [CPR examples] -Note [Optimistic field binder CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Historic Note [Optimistic field binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes how we used to guess whether fields have the CPR property+before we were able to express Nested CPR for arguments.+ Consider    data T a = MkT a@@ -530,9 +596,6 @@   (A) Flat CPR on the scrutinee   (B) A variable scrutinee. Otherwise surely it can't be a parameter.   (C) Strict demand on the field binder `y` (or it binds a strict field)--(A) and (B) are tested in 'assumeOptimisticFieldCpr',-(C) in 'giveStrictFieldsCpr' via 'extendSigEnvForDemand'.  While (A) is a necessary condition to give a field the CPR property, there are ways in which (B) and (C) are too lax, leading to unsound analysis results and

@@ -145,7 +145,7 @@ where e* are exported, but n* are not. Intuitively, we can see that @n1@ is only ever called with two arguments and in every call site, the first component of the result of the call-is evaluated. Thus, we'd like it to have idDemandInfo @UCU(C1(P(SU,A))@.+is evaluated. Thus, we'd like it to have idDemandInfo @LCL(CM(P(1L,A))@. NB: We may *not* give e2 a similar annotation, because it is exported and external callers might use it in arbitrary ways, expressed by 'topDmd'. This can then be exploited by Nested CPR and eta-expansion,@@ -220,7 +220,7 @@ -- -- It calls a function that knows how to analyse this \"body\" given -- an 'AnalEnv' with updated demand signatures for the binding group--- (reflecting their 'idStrictnessInfo') and expects to receive a+-- (reflecting their 'idDmdSigInfo') and expects to receive a -- 'DmdType' in return, which it uses to annotate the binding group with their -- 'idDemandInfo'. dmdAnalBind@@ -313,24 +313,6 @@         -- the vanilla call demand seem to be due to (b).  So we don't         -- bother to re-analyse the RHS. -{--Note [Ensure demand is strict]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important not to analyse e with a lazy demand because-a) When we encounter   case s of (a,b) ->-        we demand s with U(d1d2)... but if the overall demand is lazy-        that is wrong, and we'd need to reduce the demand on s,-        which is inconvenient-b) More important, consider-        f (let x = R in x+x), where f is lazy-   We still want to mark x as demanded, because it will be when we-   enter the let.  If we analyse f's arg with a Lazy demand, we'll-   just mark x as Lazy-c) The application rule wouldn't be right either-   Evaluating (f x) in a L demand does *not* cause-   evaluation of f in a C(L) demand!--}- -- If e is complicated enough to become a thunk, its contents will be evaluated -- at most once, so oneify it. dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand@@ -357,9 +339,6 @@         -> SubDemand         -- The main one takes a *SubDemand*         -> CoreExpr -> (DmdType, CoreExpr) --- The SubDemand is always strict and not absent---    See Note [Ensure demand is strict]- dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $                   dmdAnal' env d e @@ -649,7 +628,7 @@ see Note [Demand on case-alternative binders] in GHC.Types.Demand. This is crucial. Example:    f x = case x of y { (a,b) -> k y a }-If we just take scrut_demand = U(L,A), then we won't pass x to the+If we just take scrut_demand = 1P(L,A), then we won't pass x to the worker, so the worker will rebuild      x = (a, absent-error) and that'll crash.@@ -722,11 +701,11 @@   -- See #18429 for some perf measurements.   | Just _ <- isClassOpId_maybe var   = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $-    dmdTransformDictSelSig (idStrictness var) dmd+    dmdTransformDictSelSig (idDmdSig var) dmd   -- Imported functions   | isGlobalId var-  , let res = dmdTransformSig (idStrictness var) dmd-  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+  , let res = dmdTransformSig (idDmdSig var) dmd+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr dmd, ppr res])     res   -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').   -- In that case, we have a strictness signature to unleash in our AnalEnv.@@ -761,12 +740,12 @@ -- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature -- for the LetDown rule. It works as follows: -----  * assuming a demand of <U>+--  * assuming the weakest possible body sub-demand, L --  * looking at the definition --  * determining a strictness signature ----- Since it assumed a demand of <U>, the resulting signature is applicable at--- any call site.+-- Since it assumed a body sub-demand of L, the resulting signature is+-- applicable at any call site. dmdAnalRhsSig   :: TopLevelFlag   -> RecFlag@@ -793,9 +772,9 @@     (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty -    sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)+    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) -    id' = id `setIdStrictness` sig+    id' = id `setIdDmdSig` sig     env' = extendAnalEnv top_lvl env id' sig      -- See Note [Aggregated demand for cardinality]@@ -906,10 +885,10 @@     (     B -> j 4             )     (     C -> \y. blah        ) -The entire thing is in a C(S) context, so j's strictness signature+The entire thing is in a C1(L) context, so j's strictness signature will be    [A]b meaning one absent argument, returns bottom.  That seems odd because-there's a \y inside.  But it's right because when consumed in a C(1)+there's a \y inside.  But it's right because when consumed in a C1(L) context the RHS of the join point is indeed bottom.  Note [Demand signatures are computed for a threshold demand based on idArity]@@ -922,7 +901,7 @@ 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+in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] 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@@ -940,12 +919,12 @@       then \y -> ... y ...       else \y -> ... y ... -We'd analyse `f` under a unary call demand C(S), corresponding to idArity+We'd analyse `f` under a unary call demand C1(L), corresponding to idArity being 1. That's enough to look under the manifest lambda and find out how a unary call would use `x`, but not enough to look into the lambdas in the if branches. -On the other hand, if we analysed for call demand C(C(S)), we'd get useful+On the other hand, if we analysed for call demand C1(C1(L)), we'd get useful strictness info for `y` (and more precise info on `x`) and possibly CPR information, but @@ -971,13 +950,13 @@   * idArity is analysis information itself, thus volatile   * We already *have* dmdTypeDepth, wo why not just use it to encode the     threshold for when to unleash the signature-    (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand)+    (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)  Consider the following expression, for example:      (let go x y = `x` seq ... in go) |> co -`go` might have a strictness signature of `<S><L>`. The simplifier will identify+`go` might have a strictness signature of `<1L><L>`. The simplifier will identify `go` as a nullary join point through `joinPointBinding_maybe` and float the coercion into the binding, leading to an arity decrease: @@ -1058,11 +1037,11 @@ the Nil case.  Partly the Nil case is not a hot path.  But more specifically, the whole function gets the CPR property if we do. -That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where+That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where (solely because the result was a product) we used a product demand (albeit with lazy components) for the body. But that gives very silly behaviour -- see #17932.   Happily it turns out now to be entirely-unnecessary: we get good results with C(C(C(S))).   So I simply+unnecessary: we get good results with C1(C1(C1(L))).   So I simply deleted the special case. -} @@ -1083,23 +1062,23 @@   = loop 1 initial_pairs   where     -- See Note [Initialising strictness]-    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]+    initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ]                   | otherwise     = orig_pairs      -- If fixed-point iteration does not yield a result we use this instead     -- See Note [Safe abortion in the fixed-point iteration]     abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])     abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)             -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'             lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs-            zapped_pairs = zapIdStrictness pairs'+            zapped_pairs = zapIdDmdSig pairs' -    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that     -- annotation does not change any more.     loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)                    --                                     | (id,_)<- pairs]) $                    loop' n pairs @@ -1108,7 +1087,7 @@       | n == 10        = abort       | otherwise      = loop (n+1) pairs'       where-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs         first_round       = n == 1         (lazy_fv, pairs') = step first_round pairs         final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')@@ -1128,14 +1107,14 @@                 -- so this can significantly reduce the number of iterations needed          my_downRhs (env, lazy_fv) (id,rhs)-          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $             ((env', lazy_fv'), (id', rhs'))           where             (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs             lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1 -    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]+    zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]  {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1169,7 +1148,7 @@           A g1 -> case (x |> g1) of (p,q) -> ...           B    -> error "urk" -where A,B are the constructors of a GADT.  We'll get a U(U,U) demand+where A,B are the constructors of a GADT.  We'll get a 1P(L,L) demand on x from the A branch, but that's a stupid demand for x itself, which has type 'a'. Indeed we get ASSERTs going off (notably in splitUseProdDmd, #8569).@@ -1180,7 +1159,7 @@   f 0 _         = 0   f _ (MkT n t) = f n t -Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))).+Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))). Notice that this happens because T is a product type, and is recrusive. If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, and bale out entirely, which is inefficient and over-conservative.@@ -1221,11 +1200,11 @@ addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs dmd_ty lazy_fvs   = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs-        -- Using bothDmdType (rather than just both'ing the envs)+        -- Using plusDmdType (rather than just plus'ing the envs)         -- is vital.  Consider         --      let f = \x -> (x,y)         --      in  error (f 3)-        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L+        -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L         -- demand with the bottom coming up from 'error'         --         -- I got a loop in the fixpointer without this, due to an interaction@@ -1400,7 +1379,7 @@         -- The DmdEnv gives the demand on the free vars of the function         -- when it is given enough args to satisfy the strictness signature -type SigEnv = VarEnv (StrictSig, TopLevelFlag)+type SigEnv = VarEnv (DmdSig, TopLevelFlag)  instance Outputable AnalEnv where   ppr env = text "AE" <+> braces (vcat@@ -1427,16 +1406,16 @@  extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs top_lvl sigs vars-  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]+  = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig   = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv+extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id  nonVirgin :: AnalEnv -> AnalEnv@@ -1521,10 +1500,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some of the information that the demand analyser determines is not always preserved by the simplifier.  For example, the simplifier will happily rewrite-  \y [Demand=1*U] let x = y in x + x+  \y [Demand=MU] let x = y in x + x to-  \y [Demand=1*U] y + y-which is quite a lie.+  \y [Demand=MU] y + y+which is quite a lie: Now y occurs more than just once.  The once-used information is (currently) only used by the code generator, though.  So:@@ -1541,7 +1520,7 @@    This way, correct information finds its way into the module interface    (strictness signatures!) and the code generator (single-entry thunks!) -Note that, in contrast, the single-call information (C1(..)) /can/ be+Note that, in contrast, the single-call information (CM(..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls. 

@@ -34,6 +34,7 @@  import GHC.Types.Basic      ( RecFlag(..), isRec ) import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set 

@@ -22,6 +22,7 @@ import GHC.Utils.Logger  ( dumpIfSet_dyn, DumpFormat (..), Logger ) import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,                            isJoinId, isJoinId_maybe )+import GHC.Types.Tickish import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Data.Bag@@ -738,7 +739,7 @@   where     (floats', ceils) = partitionAtJoinCeiling floats -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds+wrapTick :: CoreTickish -> FloatBinds -> FloatBinds wrapTick t (FB tops ceils defns)   = FB (mapBag wrap_bind tops) (wrap_defns ceils)        (M.map (M.map wrap_defns) defns)

@@ -70,6 +70,7 @@ import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.Tickish import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr@@ -559,7 +560,7 @@         let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn                           ++ (mg_rules guts)         let ropts = initRuleOpts dflags-        liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan+        liftIO $ putLogMsg logger dflags Err.MCDump noSrcSpan                      $ withPprStyle defaultDumpStyle                      (ruleCheckProgram ropts current_phase pat                         rule_fn (mg_binds guts))@@ -981,7 +982,7 @@ x_exported, and therefore carry the tick anyway. -} -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks+type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks  shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds@@ -1095,8 +1096,8 @@     , local_id `setInlinePragma` defaultInlinePragma )   where     local_info = idInfo local_id-    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info-                                 `setCprInfo`           cprInfo local_info+    transfer exp_info = exp_info `setDmdSigInfo`    dmdSigInfo local_info+                                 `setCprSigInfo`           cprSigInfo local_info                                  `setUnfoldingInfo`     unfoldingInfo local_info                                  `setInlinePragInfo`    inlinePragInfo local_info                                  `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info@@ -1114,6 +1115,6 @@                }       binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds   Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds+    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . dmdSigInfo) 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,11 +103,12 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig )+import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique       ( hasKey )+import GHC.Types.Tickish      ( tickishIsCode ) import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType                         , mightBeUnliftedType, closeOverKindsDSet ) import GHC.Core.Multiplicity     ( pattern Many )@@ -445,7 +446,7 @@     arity      = idArity fn      stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitStrictSig (idStrictness fn) of+    stricts = case splitDmdSig (idDmdSig fn) of                 (arg_ds, _) | arg_ds `lengthExceeds` n_val_args                             -> []                             | otherwise@@ -821,7 +822,7 @@      t = f (g True)   If f is lazy, we /do/ float (g True) because then we can allocate   the thunk statically rather than dynamically.  But if f is strict-  we don't (see the use of idStrictness in lvlApp).  It's not clear+  we don't (see the use of idDmdSig in lvlApp).  It's not clear   if this test is worth the bother: it's only about CAFs!  It's controlled by a flag (floatConsts), because doing this too@@ -1023,7 +1024,7 @@  -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now --@@ -1032,8 +1033,8 @@   = case mb_str of       Nothing           -> id       Just (arity, sig) -> id `setIdArity`      (arity + n_extra)-                              `setIdStrictness` (prependArgsStrictSig n_extra sig)-                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr+                              `setIdDmdSig` (prependArgsDmdSig n_extra sig)+                              `setIdCprSig`    mkCprSig (arity + n_extra) botCpr  notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by

@@ -5,6 +5,7 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where@@ -41,8 +42,8 @@ import GHC.Core import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd-                        , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv )+import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd+                        , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv ) import GHC.Types.Cpr    ( mkCprSig, botCpr ) import GHC.Core.Ppr     ( pprCoreExpr ) import GHC.Types.Unique ( hasKey )@@ -58,6 +59,7 @@ import GHC.Types.Basic import GHC.Utils.Monad  ( mapAccumLM, liftIO ) import GHC.Utils.Logger+import GHC.Types.Tickish import GHC.Types.Var    ( isTyCoVar ) import GHC.Data.Maybe   ( orElse ) import Control.Monad@@ -165,6 +167,38 @@ the time: every update to a binder is automatically reflected to its bound occurrences. +Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.+++ ************************************************************************ *                                                                      * \subsection{Bindings}@@ -180,7 +214,8 @@                 -- anything into scope, then we don't get a complaint about that.                 -- It's rather as if the top-level binders were imported.                 -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".-        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        -- See Note [Bangs in the Simplifier]+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)         ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0         ; freeTick SimplifierDone         ; return (floats, env2) }@@ -193,7 +228,9 @@     simpl_binds env []           = return (emptyFloats env, env)     simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind                                       ; (floats, env2) <- simpl_binds env1 binds-                                      ; return (float `addFloats` floats, env2) }+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }      simpl_bind env (Rec pairs)       = simplRecBind env TopLevel Nothing pairs@@ -294,7 +331,7 @@   = ASSERT( isId bndr )     ASSERT2( not (isJoinId bndr), ppr bndr )     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   rhs_env     = rhs_se `setInScopeFromE` env+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]                 (tvs, body) = case collectTyAndValBinders rhs of                                 (tvs, [], body)                                   | surely_not_lam body -> (tvs, body)@@ -542,8 +579,8 @@        ; return (floats, bndr, rhs') }  where    info = idInfo bndr-   worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info-                               `setCprInfo`        cprInfo info+   worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info+                               `setCprSigInfo`        cprSigInfo info                                `setDemandInfo`     demandInfo info                                `setInlinePragInfo` inlinePragInfo info                                `setArityInfo`      arityInfo info@@ -815,18 +852,18 @@     -- eta-expansion *reduces* the arity of the binding to less     -- than that of the strictness sig. This can happen: see Note [Arity decrease].     info3 | isEvaldUnfolding new_unf-            || (case strictnessInfo info2 of-                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)+            || (case dmdSigInfo info2 of+                  DmdSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)           = zapDemandInfo info2 `orElse` info2           | otherwise           = info2      -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig-                                     `setCprInfo`        bot_cpr+    info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig+                                     `setCprSigInfo`        bot_cpr           | otherwise        = info3 -    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div+    bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div     bot_cpr = mkCprSig new_arity botCpr       -- Zap call arity info. We have used it by now (via@@ -940,7 +977,7 @@ -}  simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr env (Type ty)+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]   = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]        ; return (Type ty') } @@ -971,7 +1008,7 @@            -> SimplCont            -> SimplM (SimplFloats, OutExpr) -simplExprF env e cont+simplExprF !env e !cont -- See Note [Bangs in the Simplifier]   = {- pprTrace "simplExprF" (vcat       [ ppr e       , text "cont =" <+> ppr cont@@ -1160,7 +1197,7 @@ -- long as this is a non-scoping tick, to let case and application -- optimisations apply. -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont+simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont           -> SimplM (SimplFloats, OutExpr) simplTick env tickish expr cont   -- A scoped tick turns into a continuation, so that we can spot@@ -1244,7 +1281,7 @@ --    do { let (inc,outc) = splitCont cont --       ; (env', expr') <- simplExprF (zapFloats env) expr inc --       ; let tickish' = simplTickish env tickish---       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),+--       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), --                                   mkTick (mkNoCount tickish') rhs) --              -- when wrapping a float with mkTick, we better zap the Id's --              -- strictness info and arity, because it might be wrong now.@@ -1254,8 +1291,8 @@     simplTickish env tickish-    | Breakpoint n ids <- tickish-          = Breakpoint n (map (getDoneId . substId env) ids)+    | Breakpoint ext n ids <- tickish+          = Breakpoint ext n (map (getDoneId . substId env) ids)     | otherwise = tickish    -- Push type application and coercion inside a tick@@ -1868,24 +1905,33 @@ simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var-  | isTyVar var = return (Type (substTyVar env var))-  | isCoVar var = return (Coercion (substCoVar env var))+  -- Why $! ? See Note [Bangs in the Simplifier]+  | isTyVar var = return $! Type $! (substTyVar env var)+  | isCoVar var = return $! Coercion $! (substCoVar env var)   | otherwise   = case substId env var of-        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e         DoneId var1          -> return (Var var1)         DoneEx e _           -> return e  simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont   = case substId env var of-      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont-                                -- Don't trim; haven't already simplified e,-                                -- so the cont is not embodied in e+      ContEx tvs cvs ids e ->+          let env' = setSubstEnv env tvs cvs ids+          in simplExprF env' e cont+          -- Don't trim; haven't already simplified e,+          -- so the cont is not embodied in e -      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)+      DoneId var1 ->+          let cont' = trimJoinCont var (isJoinId_maybe var1) cont+          in completeCall env var1 cont' -      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)+      DoneEx e mb_join ->+          let env' = zapSubstEnv env+              cont' = trimJoinCont var mb_join cont+          in simplExprF env' e cont'               -- Note [zapSubstEnv]               -- The template is already simplified, so don't re-substitute.               -- This is VITAL.  Consider@@ -1906,12 +1952,14 @@   -- Inline the variable's RHS   = do { checkedTick (UnfoldingDone var)        ; dump_inline expr cont-       ; simplExprF (zapSubstEnv env) expr cont }+       ; let env1 = zapSubstEnv env+       ; simplExprF env1 expr cont }    | otherwise   -- Don't inline; instead rebuild the call   = do { rule_base <- getSimplRules-       ; let info = mkArgInfo env var (getRules rule_base var)+       ; let rules = getRules rule_base var+             info = mkArgInfo env var rules                               n_val_args call_cont        ; rebuildCall env info cont } @@ -3996,14 +4044,17 @@       = return rule      simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs })+                          , ru_fn = fn_name, ru_rhs = rhs+                          , ru_act = act })       = do { (env', bndrs') <- simplBinders env bndrs            ; let rhs_ty = substTy env' (exprType rhs)                  rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]                                 Nothing   -> mkBoringStop rhs_ty                                 Just cont -> ASSERT2( join_ok, bad_join_msg )                                              cont-                 rule_env = updMode updModeForRules env'+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]                  fn_name' = case mb_new_id of                               Just id -> idName id                               Nothing -> fn_name@@ -4018,9 +4069,18 @@                  bad_join_msg = vcat [ ppr mb_new_id, ppr rule                                      , ppr (fmap isJoinId_maybe mb_new_id) ] -           ; args' <- mapM (simplExpr rule_env) args-           ; rhs'  <- simplExprC rule_env rhs rhs_cont+           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont            ; return (rule { ru_bndrs = bndrs'                           , ru_fn    = fn_name'                           , ru_args  = args'                           , ru_rhs   = rhs' }) }++{- Note [Simplifying the RHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can simplify the RHS of a RULE much as we do the RHS of a stable+unfolding.  We used to use the much more conservative updModeForRules+for the RHS as well as the LHS, but that seems more conservative+than necesary.  Allowing some inlining might, for example, eliminate+a binding.+-}

@@ -90,7 +90,7 @@      -- Static in the sense of lexically scoped,      -- wrt the original expression -        seMode      :: SimplMode+        seMode      :: !SimplMode          -- The current substitution       , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType@@ -103,7 +103,7 @@          -- The current set of in-scope variables         -- They are all OutVars, and all bound in this module-      , seInScope   :: InScopeSet       -- OutVars only+      , seInScope   :: !InScopeSet       -- OutVars only        , seCaseDepth :: !Int  -- Depth of multi-branch case alternatives     }@@ -325,7 +325,10 @@ setMode mode env = env { seMode = mode }  updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv-updMode upd env = env { seMode = upd (seMode env) }+updMode upd env+  = -- Avoid keeping env alive in case inlining fails.+    let mode = upd $! (seMode env)+    in env { seMode = mode }  bumpCaseDepth :: SimplEnv -> SimplEnv bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }@@ -363,8 +366,12 @@ addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv         -- The new Ids are guaranteed to be freshly allocated addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs-  = env { seInScope = in_scope `extendInScopeSetList` vs,-          seIdSubst = id_subst `delVarEnvList` vs }+-- See Note [Bangs in the Simplifier]+  = let !in_scope1 = in_scope `extendInScopeSetList` vs+        !id_subst1 = id_subst `delVarEnvList` vs+    in+    env { seInScope = in_scope1,+          seIdSubst = id_subst1 }         -- Why delete?  Consider         --      let x = a*b in (x, \x -> x+3)         -- We add [x |-> a*b] to the substitution, but we must@@ -544,8 +551,8 @@       = SimplFloats { sfLetFloats  = unitLetFloat bind                     , sfJoinFloats = emptyJoinFloats                     , sfInScope    = in_scope' }--    in_scope' = seInScope env `extendInScopeSetBind` bind+    -- See Note [Bangs in the Simplifier]+    !in_scope' = seInScope env `extendInScopeSetBind` bind  extendFloats :: SimplFloats -> OutBind -> SimplFloats -- Add this binding to the floats, and extend the in-scope env too@@ -616,10 +623,11 @@                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }   where-    floats'  | isNilOL bs  = emptyLetFloats-             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))-    jfloats' | isNilOL jbs = emptyJoinFloats-             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))+    -- See Note [Bangs in the Simplifier]+    !floats'  | isNilOL bs  = emptyLetFloats+              | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))+    !jfloats' | isNilOL jbs = emptyJoinFloats+              | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))  wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression; they should all@@ -649,12 +657,14 @@   = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings     letFloatBinds lbs +{-# INLINE mapLetFloats #-} mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats mapLetFloats (LetFloats fs ff) fun-   = LetFloats (mapOL app fs) ff+   = LetFloats fs1 ff    where     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'-    app (Rec bs)     = Rec (map fun bs)+    app (Rec bs)     = Rec (strictMap fun bs)+    !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]  {- ************************************************************************@@ -748,7 +758,7 @@ -}  simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs+simplBinders  !env bndrs = mapAccumLM simplBinder  env bndrs  ------------- simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)@@ -757,7 +767,7 @@ -- Return with IdInfo already substituted, but (fragile) occurrence info zapped -- The substitution is extended only if the variable is cloned, because -- we *don't* need to use it to track occurrence info.-simplBinder env bndr+simplBinder !env bndr   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr                         ; seqTyVar tv `seq` return (env', tv) }   | otherwise     = do  { let (env', id) = substIdBndr env bndr@@ -766,16 +776,18 @@ --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- A non-recursive let binder-simplNonRecBndr env id-  = do  { let (env1, id1) = substIdBndr env id+simplNonRecBndr !env id+  -- See Note [Bangs in the Simplifier]+  = do  { let (!env1, id1) = substIdBndr env id         ; seqId id1 `seq` return (env1, id1) }  --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids+  -- See Note [Bangs in the Simplifier]   = ASSERT(all (not . isJoinId) ids)-    do  { let (env1, ids1) = mapAccumL substIdBndr env ids+    do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 }  @@ -810,6 +822,10 @@ --      all fragile info is zapped substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) +-- Inline to make the (OutId -> OutId) function a known call.+-- This is especially important for `substNonCoVarIdBndr` which+-- passes an identity lambda.+{-# INLINE subst_id_bndr #-} subst_id_bndr :: SimplEnv               -> InBndr    -- Env and binder to transform               -> (OutId -> OutId)  -- Adjust the type@@ -817,7 +833,7 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })               old_id adjust_type   = ASSERT2( not (isCoVar old_id), ppr old_id )-    (env { seInScope = in_scope `extendInScopeSet` new_id,+    (env { seInScope = new_in_scope,            seIdSubst = new_subst }, new_id)     -- It's important that both seInScope and seIdSubst are updated with     -- the new_id, /after/ applying adjust_type. That's why adjust_type@@ -825,20 +841,23 @@     -- place that gives a non-identity adjust_type) we'd have to fiddle     -- afresh with both seInScope and seIdSubst   where-    id1  = uniqAway in_scope old_id-    id2  = substIdType env id1-    id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding+    -- See Note [Bangs in the Simplifier]+    !id1  = uniqAway in_scope old_id+    !id2  = substIdType env id1+    !id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding                                       -- and fragile OccInfo-    new_id = adjust_type id3+    !new_id = adjust_type id3          -- Extend the substitution if the unique has changed,         -- or there's some useful occurrence information         -- See the notes with substTyVarBndr for the delSubstEnv-    new_subst | new_id /= old_id+    !new_subst | new_id /= old_id               = extendVarEnv id_subst old_id (DoneId new_id)               | otherwise               = delVarEnv id_subst old_id +    !new_in_scope = in_scope `extendInScopeSet` new_id+ ------------------------------------ seqTyVar :: TyVar -> () seqTyVar b = b `seq` ()@@ -947,7 +966,7 @@     orig_ar = idJoinArity join_id     orig_ty = idType join_id -    new_join_ty = go orig_ar orig_ty+    new_join_ty = go orig_ar orig_ty :: Type      go 0 _  = new_res_ty     go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty@@ -956,7 +975,8 @@             | otherwise             = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) -    scale_bndr (Anon af t) = Anon af (scaleScaled mult t)+    -- See Note [Bangs in the Simplifier]+    scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)     scale_bndr b@(Named _) = b  {- Note [Scaling join point arguments]

@@ -5,7 +5,6 @@ \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} -} -{-# LANGUAGE DeriveFunctor #-} module GHC.Core.Opt.Simplify.Monad (         -- The monad         SimplM,

@@ -57,6 +57,7 @@ import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Demand import GHC.Types.Var.Set@@ -166,7 +167,7 @@       , sc_cont :: SimplCont }    | TickIt              -- (TickIt t K)[e] = K[ tick t e ]-        (Tickish Id)    -- Tick tickish <hole>+        CoreTickish     -- Tick tickish <hole>         SimplCont  type StaticEnv = SimplEnv       -- Just the static part is relevant@@ -546,7 +547,7 @@       = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]       | otherwise       = -- add_type_str fun_ty $-        case splitStrictSig (idStrictness fun) of+        case splitDmdSig (idDmdSig fun) of           (demands, result_info)                 | not (demands `lengthExceeds` n_val_args)                 ->      -- Enough args, use the strictness given.@@ -883,12 +884,12 @@  updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode -- See Note [Simplifying inside stable unfoldings]-updModeForStableUnfoldings inline_rule_act current_mode-  = current_mode { sm_phase      = phaseFromActivation inline_rule_act+updModeForStableUnfoldings unf_act current_mode+  = current_mode { sm_phase      = phaseFromActivation unf_act                  , sm_inline     = True                  , sm_eta_expand = False }-                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]-       -- For sm_rules, just inherit; sm_rules might be "off"+       -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]+       -- sm_rules: just inherit; sm_rules might be "off"        -- because of -fno-enable-rewrite-rules   where     phaseFromActivation (ActiveAfter _ n) = Phase n@@ -1254,15 +1255,15 @@   | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]                                                        -- in module Exitify   | not (one_occ (idOccInfo bndr))           = Nothing-  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)+  | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)    -- Note [Stable unfoldings and preInlineUnconditionally]   | not (isInlinePragma inline_prag)-  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)+  , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)   | otherwise                                = Nothing   where     unf = idUnfolding bndr-    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)+    extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)      one_occ IAmDead = True -- Happens in ((\x.1) v)     one_occ OneOcc{ occ_n_br   = 1@@ -1941,7 +1942,7 @@     abstract subst (NonRec id rhs)       = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'-                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app+                 !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app            ; return (subst', NonRec poly_id2 poly_rhs) }       where         rhs' = GHC.Core.Subst.substExpr subst rhs

@@ -36,7 +36,7 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type     hiding ( substTy )-import GHC.Core.TyCon   ( tyConUnique, tyConName )+import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr     ( pprParendExpr )@@ -44,6 +44,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name+import GHC.Types.Tickish import GHC.Types.Basic import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )                           , gopt, hasPprDebug )@@ -64,7 +65,6 @@ import Data.List (nubBy, sortBy, partition) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module-import GHC.Core.TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) import Data.Ord( comparing ) @@ -1716,7 +1716,7 @@                 -- Usual w/w hack to avoid generating                 -- a spec_rhs of unlifted type and no args -              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args+              spec_lam_args_str = handOutStrictnessInformation (fst (splitDmdSig spec_str)) spec_lam_args                 -- Annotate the variables with the strictness information from                 -- the function (see Note [Strictness information in worker binders]) @@ -1725,8 +1725,8 @@               spec_id    = mkLocalId spec_name Many                                      (mkLamTypes spec_lam_args body_ty)                              -- See Note [Transfer strictness]-                             `setIdStrictness` spec_str-                             `setIdCprInfo` topCprSig+                             `setIdDmdSig` spec_str+                             `setIdCprSig` topCprSig                              `setIdArity` count isId spec_lam_args                              `asJoinId_maybe` spec_join_arity               spec_str   = calcSpecStrictness fn spec_lam_args pats@@ -1757,13 +1757,13 @@  calcSpecStrictness :: Id                     -- The original function                    -> [Var] -> [CoreExpr]    -- Call pattern-                   -> StrictSig              -- Strictness of specialised thing+                   -> DmdSig              -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats-  = mkClosedStrictSig spec_dmds div+  = mkClosedDmdSig spec_dmds div   where     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    StrictSig (DmdType _ dmds div) = idStrictness fn+    DmdSig (DmdType _ dmds div) = idDmdSig fn      dmd_env = go emptyVarEnv dmds pats 

@@ -47,11 +47,13 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DFM import GHC.Types.Name+import GHC.Types.Tickish import GHC.Types.Id.Make  ( voidArgId, voidPrimId ) import GHC.Types.Var      ( isLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Error  import GHC.Utils.Monad    ( foldlM ) import GHC.Utils.Misc@@ -801,13 +803,13 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn   | wopt Opt_WarnMissedSpecs dflags     && not (null callers)-    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs-  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+    && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs   | otherwise                             = return ()   where     allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers     doWarn reason =-      warnMsg reason+      msg (mkMCDiagnostic reason)         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)                         | caller <- callers])@@ -1125,9 +1127,9 @@        ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }  ---------------specTickish :: SpecEnv -> Tickish Id -> Tickish Id-specTickish env (Breakpoint ix ids)-  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]+specTickish :: SpecEnv -> CoreTickish -> CoreTickish+specTickish env (Breakpoint ext ix ids)+  = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]]   -- drop vars from the list if they have a non-variable substitution.   -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish

@@ -511,9 +511,9 @@   where     uf_opts      = unfoldingOpts dflags     fn_info      = idInfo fn_id-    (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)+    (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) -    cpr_ty       = getCprSig (cprInfo fn_info)+    cpr_ty       = getCprSig (cprSigInfo fn_info)     -- Arity of the CPR sig should match idArity when it's not a join point.     -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal     cpr          = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info@@ -584,7 +584,7 @@     where       co :: (Int -> Int -> Char) ~ T -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+Then idArity is 2 (despite the type T), and it can have a DmdSig based on a threshold of 2. But we can't w/w it without a type error.  The situation is less grave for PAPs, but the implicit eta expansion caused a@@ -602,7 +602,7 @@   ----------------------splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr          -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs   | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]@@ -638,7 +638,7 @@   mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity-             -> CoreExpr -> Unique -> Divergence -> CprResult+             -> CoreExpr -> Unique -> Divergence -> Cpr              -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)              -> [(Id, CoreExpr)] mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr@@ -679,11 +679,11 @@                 `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding                         -- See Note [Worker-wrapper for INLINABLE functions] -                `setIdStrictness` mkClosedStrictSig work_demands div+                `setIdDmdSig` mkClosedDmdSig work_demands div                         -- Even though we may not be at top level,                         -- it's ok to give it an empty DmdEnv -                `setIdCprInfo` mkCprSig work_arity work_cpr_info+                `setIdCprSig` mkCprSig work_arity work_cpr_info                  `setIdDemandInfo` worker_demand 

@@ -8,7 +8,7 @@  module GHC.Core.Opt.WorkWrap.Utils    ( mkWwBodies, mkWWstr, mkWorkerArgs-   , DataConPatContext(..), splitArgType_maybe, wantToUnbox+   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox    , findTypeShape    , isWorkerSmallEnough    )@@ -20,7 +20,7 @@  import GHC.Core import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase-                        , dataConRepFSInstPat )+                        , bindNonRec, dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon@@ -29,14 +29,14 @@ import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup                         , mkCoreApp, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types      ( tupleDataCon, unboxedUnitTy )-import GHC.Types.Literal ( absentLiteralOf, rubbishLit )+import GHC.Builtin.Types      ( tupleDataCon )+import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred )-import GHC.Types.RepType  ( isVoidTy, typePrimRep )+import GHC.Types.RepType  ( isVoidTy, typeMonoPrimRep_maybe ) import GHC.Core.Coercion import GHC.Core.FamInstEnv import GHC.Types.Basic       ( Boxity(..) )@@ -135,7 +135,7 @@                              -- See Note [Freshen WW arguments]            -> Id             -- The original function            -> [Demand]       -- Strictness of original function-           -> CprResult      -- Info about function result+           -> Cpr            -- Info about function result            -> UniqSM (Maybe WwResult)  -- wrap_fn_args E       = \x y -> E@@ -511,105 +511,100 @@      Another tricky case was when f :: forall a. a -> forall a. a->a     (i.e. with shadowing), and then the worker used the same 'a' twice.+-} +{- ************************************************************************ *                                                                      *-\subsection{Strictness stuff}+\subsection{Unboxing Decision for Strictness and CPR} *                                                                      * ************************************************************************ -} -mkWWstr :: DynFlags-        -> FamInstEnvs-        -> Bool    -- True <=> INLINEABLE pragma on this function defn-                   -- See Note [Do not unpack class dictionaries]-        -> [Var]                                -- Wrapper args; have their demand info on them-                                                --  *Includes type variables*-        -> UniqSM (Bool,                        -- Is this useful-                   [Var],                       -- Worker args-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call-                                                -- and without its lambdas-                                                -- This fn adds the unboxing--                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,-                                                -- and lacking its lambdas.-                                                -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args-  = go args-  where-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg--    go []           = return (False, [], nop_fn, nop_fn)-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , work_fn1 . work_fn2) }--{--Note [Unpacking arguments with product and polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The argument is unpacked in a case if it has a product type and has a-strict *and* used demand put on it. I.e., arguments, with demands such-as the following ones:--   <S,U(U, L)>-   <S(L,S),U>--will be unpacked, but--   <S,U> or <B,U>--will not, because the pieces aren't used. This is quite important otherwise-we end up unpacking massive tuples passed to the bottoming function. Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--Does 'main' print "error 1" or "error no"?  We don't really want 'f'-to unbox its second argument.  This actually happened in GHC's onwn-source code, in Packages.applyPackageFlag, which ended up un-boxing-the enormous DynFlags tuple, and being strict in the-as-yet-un-filled-in unitState files.--}--------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)---   *  wrap_fn assumes wrap_arg is in scope,---        brings into scope work_args (via cases)---   * work_fn assumes work_args are in scope, a---        brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs-            -> Bool    -- True <=> INLINEABLE pragma on this function defn-                       -- See Note [Do not unpack class dictionaries]-            -> Var-            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg-  | isTyVar arg-  = return (False, [arg],  nop_fn, nop_fn)+-- | The information needed to build a pattern for a DataCon to be unboxed.+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype+-- wrappers.+--+-- If we get @DataConPatContext dc tys co@ for some type @ty@+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then+--+--   * @dc @exs flds :: T tys@+--   * @co :: T tys ~ ty@+data DataConPatContext+  = DataConPatContext+  { dcpc_dc      :: !DataCon+  , dcpc_tc_args :: ![Type]+  , dcpc_co      :: !Coercion+  } -  | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags fam_envs arg dmd-     -- Absent case.  We can't always handle absence for arbitrary-     -- unlifted types, so we need to choose just the cases we can-     -- (that's what mk_absent_let does)-  = return (True, [], nop_fn, work_fn)+-- | If @splitArgType_maybe ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+--+-- See Note [Which types are unboxed?].+splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext+splitArgType_maybe fam_envs ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , Just con <- tyConSingleAlgDataCon_maybe tc+  = Just DataConPatContext { dcpc_dc      = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co      = co }+splitArgType_maybe _ _ = Nothing -  | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd-  = unbox_one dflags fam_envs arg cs acdc+-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+-- @dc@ is the @n@th data constructor of @tc@.+--+-- See Note [Which types are unboxed?].+splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext+splitResultType_maybe fam_envs con_tag ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!+  , let cons = tyConDataCons tc+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the+                                 -- type constructor via a .hs-boot file (#8743)+  , let con = cons `getNth` (con_tag - fIRST_TAG)+  , null (dataConExTyCoVars con) -- no existentials;+                                 -- See Note [Which types are unboxed?]+                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt+                                 -- where we also check this.+  , all isLinear (dataConInstArgTys con tc_args)+  -- Deactivates CPR worker/wrapper splits on constructors with non-linear+  -- arguments, for the moment, because they require unboxed tuple with variable+  -- multiplicity fields.+  = Just DataConPatContext { dcpc_dc = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co = co }+splitResultType_maybe _ _ _ = Nothing -  | otherwise   -- Other cases-  = return (False, [arg], nop_fn, nop_fn)+isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+  case w of+    One -> True+    _ -> False -  where-    arg_ty = idType arg-    dmd    = idDemandInfo arg+-- | Describes the outer shape of an argument to be unboxed or left as-is+-- Depending on how @s@ is instantiated (e.g., 'Demand').+data UnboxingDecision s+  = StopUnboxing+  -- ^ We ran out of strictness info. Leave untouched.+  | Unbox !DataConPatContext [s]+  -- ^ The argument is used strictly or the returned product was constructed, so+  -- unbox it.+  -- The 'DataConPatContext' carries the bits necessary for+  -- instantiation with 'dataConRepInstPat'.+  -- The @[s]@ carries the bits of information with which we can continue+  -- unboxing, e.g. @s@ will be 'Demand'. -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext)+wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand -- See Note [Which types are unboxed?] wantToUnbox fam_envs has_inlineable_prag ty dmd =   case splitArgType_maybe fam_envs ty of@@ -622,8 +617,10 @@       , not (has_inlineable_prag && isClassPred ty)       -- See Note [mkWWstr and unsafeCoerce]       , cs `lengthIs` arity-      -> Just (cs, dcpc)-    _ -> Nothing+      -- See Note [Add demands for strict constructors]+      , let cs' = addDataConStrictness dc cs+      -> Unbox dcpc cs'+    _ -> StopUnboxing   where     split_prod_dmd_arity dmd arity       -- For seqDmd, it should behave like <S(AAAA)>, for some@@ -632,111 +629,97 @@       | _ :* Prod ds <- dmd = Just ds       | otherwise           = Nothing -unbox_one :: DynFlags -> FamInstEnvs -> Var-          -> [Demand]-          -> DataConPatContext-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                            , dcpc_co = co }-  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM-       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc-             (ex_tvs', arg_ids) =-               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args-             -- See Note [Add demands for strict constructors]-             cs'       = addDataConStrictness dc cs-             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs'-             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq-                                      dc (ex_tvs' ++ arg_ids')-             arg_no_unf = zapStableUnfolding arg-                          -- See Note [Zap unfolding when beta-reducing]-                          -- in GHC.Core.Opt.Simplify; and see #13890-             rebox_fn   = Let (NonRec arg_no_unf con_app)-             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co-       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')-       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                          -- Don't pass the arg, rebox instead+{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox ------------------------nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body+  1. A strict data type argument, that+       * is an algebraic data type (not a newtype)+       * has a single constructor (thus is a "product")+       * that may bind existentials+     We can transform+     > f (D @ex a b) = e+     to+     > $wf @ex a b = e+     via 'mkWWstr'. -addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds-  = zipWithEqual "addDataConStrictness" add ds strs-  where-    strs = dataConRepStrictness con-    add dmd str | isMarkedStrict str = strictifyDmd dmd-                | otherwise          = dmd+  2. The constructed result of a function, if+       * its type is an algebraic data type (not a newtype)+       * (might have multiple constructors, in contrast to (1))+       * the applied data constructor *does not* bind existentials+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'. -{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:+     NB: We don't allow existentials for CPR W/W, because we don't have unboxed+     dependent tuples (yet?). Otherwise, we could transform+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+     to+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) -1. If an argument is absent, it would be silly to pass it to-   the worker.  Hence the isAbsDmd case.  This case must come-   first because a demand like <S,A> or <B,A> is possible.-   E.g. <B,A> comes from a function like-       f x = error "urk"-   and <S,A> can come from Note [Add demands for strict constructors]+The respective tests are in 'splitArgType_maybe' and+'splitResultType_maybe', respectively. -2. If the argument is evaluated strictly, and we can split the-   product demand (splitProdDmd_maybe), then unbox it and w/w its-   pieces.  For example+Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way. -    f :: (Int, Int) -> Int-    f p = (case p of (a,b) -> a) + 1-  is split to-    f :: (Int, Int) -> Int-    f p = case p of (a,b) -> $wf a+Note [Unpacking arguments with product and polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The argument is unpacked in a case if it has a product type and has a+strict *and* used demand put on it. I.e., arguments, with demands such+as the following ones: -    $wf :: Int -> Int-    $wf a = a + 1+   <S,U(U, L)>+   <S(L,S),U> -  and-    g :: Bool -> (Int, Int) -> Int-    g c p = case p of (a,b) ->-               if c then a else b-  is split to-   g c p = case p of (a,b) -> $gw c a b-   $gw c a b = if c then a else b+will be unpacked, but -2a But do /not/ split if the components are not used; that is, the-   usage is just 'Used' rather than 'UProd'. In this case-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing-   a massive tuple which is barely used.  Example:+   <S,U> or <B,U> +will not, because the pieces aren't used. This is quite important otherwise+we end up unpacking massive tuples passed to the bottoming function. Example:+         f :: ((Int,Int) -> String) -> (Int,Int) -> a         f g pr = error (g pr)          main = print (f fst (1, error "no")) -   Here, f does not take 'pr' apart, and it's stupid to do so.-   Imagine that it had millions of fields. This actually happened-   in GHC itself where the tuple was DynFlags+Does 'main' print "error 1" or "error no"?  We don't really want 'f'+to unbox its second argument.  This actually happened in GHC's onwn+source code, in Packages.applyPackageFlag, which ended up un-boxing+the enormous DynFlags tuple, and being strict in the+as-yet-un-filled-in unitState files. -3. A plain 'seqDmd', which is head-strict with usage UHead, can't-   be split by splitProdDmd_maybe.  But we want it to behave just-   like U(AAAA) for suitable number of absent demands. So we have-   a special case for it, with arity coming from the data constructor.+Note [Do not unpack class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   f :: Ord a => [a] -> Int -> a+   {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+which can still be specialised by the type-class specialiser, something like+   fw :: Ord a => [a] -> Int# -> a -Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification:  there's no efficiency to be gained.]+BUT if f is strict in the Ord dictionary, we might unpack it, to get+   fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that. An example is #6056. -But it's sometimes bad not to make a wrapper.  Consider-        fw = \x# -> let x = I# x# in case e of-                                        p1 -> error_fn x-                                        p2 -> error_fn x-                                        p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]+But in any other situation a dictionary is just an ordinary value,+and can be unpacked.  So we track the INLINABLE pragma, and switch+off the unpacking in mkWWstr_one (see the isClassPred test). +Historical note: #14955 describes how I got this fix wrong the first time.++Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.+ Note [Add demands for strict constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this program (due to Roman):@@ -857,15 +840,184 @@ applying the strictness demands to the final result of DmdAnal. The result is that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`.+-} +{-+************************************************************************+*                                                                      *+\subsection{Strictness stuff}+*                                                                      *+************************************************************************+-} -Note [mkWWstr and unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in #8037.-If so, the worker/wrapper split doesn't work right and we get a Core Lint-bug.  The fix here is simply to decline to do w/w if that happens.+mkWWstr :: DynFlags+        -> FamInstEnvs+        -> Bool    -- True <=> INLINEABLE pragma on this function defn+                   -- See Note [Do not unpack class dictionaries]+        -> [Var]                                -- Wrapper args; have their demand info on them+                                                --  *Includes type variables*+        -> UniqSM (Bool,                        -- Is this useful+                   [Var],                       -- Worker args+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call+                                                -- and without its lambdas+                                                -- This fn adds the unboxing +                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,+                                                -- and lacking its lambdas.+                                                -- This fn does the reboxing+mkWWstr dflags fam_envs has_inlineable_prag args+  = go args+  where+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg++    go []           = return (False, [], nop_fn, nop_fn)+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , work_fn1 . work_fn2) }++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+--   *  wrap_fn assumes wrap_arg is in scope,+--        brings into scope work_args (via cases)+--   * work_fn assumes work_args are in scope, a+--        brings into scope wrap_arg (via lets)+-- See Note [How to do the worker/wrapper split]+mkWWstr_one :: DynFlags -> FamInstEnvs+            -> Bool    -- True <=> INLINEABLE pragma on this function defn+                       -- See Note [Do not unpack class dictionaries]+            -> Var+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one dflags fam_envs has_inlineable_prag arg+  | isTyVar arg+  = return (False, [arg],  nop_fn, nop_fn)++  | isAbsDmd dmd+  , Just work_fn <- mk_absent_let dflags arg dmd+     -- Absent case.  We can't always handle absence for rep-polymorphic+     -- types, so we need to choose just the cases we can+     -- (that's what mk_absent_let does)+  = return (True, [], nop_fn, work_fn)++  | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd+  = unbox_one dflags fam_envs arg cs dcpc++  | otherwise   -- Other cases+  = return (False, [arg], nop_fn, nop_fn)++  where+    arg_ty = idType arg+    dmd    = idDemandInfo arg++unbox_one :: DynFlags -> FamInstEnvs -> Var+          -> [Demand]+          -> DataConPatContext+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+unbox_one dflags fam_envs arg cs+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                            , dcpc_co = co }+  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM+       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc+             (ex_tvs', arg_ids) =+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args+             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs+             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq+                                      dc (ex_tvs' ++ arg_ids')+             arg_no_unf = zapStableUnfolding arg+                          -- See Note [Zap unfolding when beta-reducing]+                          -- in GHC.Core.Opt.Simplify; and see #13890+             rebox_fn   = Let (NonRec arg_no_unf con_app)+             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co+       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')+       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                          -- Don't pass the arg, rebox instead++----------------------+nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+  | Nothing <- dataConWrapId_maybe con+  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do+  = ds+addDataConStrictness con ds+  = zipWithEqual "addDataConStrictness" add ds strs+  where+    strs = dataConRepStrictness con+    add dmd str | isMarkedStrict str = strictifyDmd dmd+                | otherwise          = dmd++{- Note [How to do the worker/wrapper split]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker-wrapper transformation, mkWWstr_one, takes into account+several possibilities to decide if the function is worthy for+splitting:++1. If an argument is absent, it would be silly to pass it to+   the worker.  Hence the isAbsDmd case.  This case must come+   first because a demand like <S,A> or <B,A> is possible.+   E.g. <B,A> comes from a function like+       f x = error "urk"+   and <S,A> can come from Note [Add demands for strict constructors]++2. If the argument is evaluated strictly, and we can split the+   product demand (splitProdDmd_maybe), then unbox it and w/w its+   pieces.  For example++    f :: (Int, Int) -> Int+    f p = (case p of (a,b) -> a) + 1+  is split to+    f :: (Int, Int) -> Int+    f p = case p of (a,b) -> $wf a++    $wf :: Int -> Int+    $wf a = a + 1++  and+    g :: Bool -> (Int, Int) -> Int+    g c p = case p of (a,b) ->+               if c then a else b+  is split to+   g c p = case p of (a,b) -> $gw c a b+   $gw c a b = if c then a else b++2a But do /not/ split if the components are not used; that is, the+   usage is just 'Used' rather than 'UProd'. In this case+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing+   a massive tuple which is barely used.  Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++   Here, f does not take 'pr' apart, and it's stupid to do so.+   Imagine that it had millions of fields. This actually happened+   in GHC itself where the tuple was DynFlags++3. A plain 'seqDmd', which is head-strict with usage UHead, can't+   be split by splitProdDmd_maybe.  But we want it to behave just+   like U(AAAA) for suitable number of absent demands. So we have+   a special case for it, with arity coming from the data constructor.++Note [Worker-wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]+ Note [Record evaluated-ness in worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -913,97 +1065,8 @@          Type scrutiny that is specific to demand analysis *                                                                      * ************************************************************************--Note [Do not unpack class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   f :: Ord a => [a] -> Int -> a-   {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like-   fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get-   fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is #6056.--But in any other situation a dictionary is just an ordinary value,-and can be unpacked.  So we track the INLINABLE pragma, and switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time. -} --- | The result of 'splitArgType_maybe' and 'splitResultType_maybe'.------ Both splits---   * Take a type `ty`---   * Succeed with (DataConPatContext dc tys co)---     iff co :: T tys ~ ty---     and `dc` is the appropriate DataCon of `T`---     and `T` is suitable for the kind of split---     (differs for strictness and CPR, see Note [Which types are unboxed?])-data DataConPatContext-  = DataConPatContext-  { dcpc_dc        :: !DataCon-  , dcpc_tc_args   :: ![Type]-  , dcpc_co        :: !Coercion-  }---- | If @splitArgType_maybe ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.------ See Note [Which types are unboxed?].-splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext-splitArgType_maybe fam_envs ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- tyConSingleAlgDataCon_maybe tc-  = Just DataConPatContext { dcpc_dc      = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co      = co }-splitArgType_maybe _ _ = Nothing---- | If @splitResultType_maybe n ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.--- @dc@ is the @n@th data constructor of @tc@.------ See Note [Which types are unboxed?].-splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext-splitResultType_maybe fam_envs con_tag ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!-  , let cons = tyConDataCons tc-  , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-boot file (#8743)-  , let con = cons `getNth` (con_tag - fIRST_TAG)-  , null (dataConExTyCoVars con) -- no existentials;-                                 -- See Note [Which types are unboxed?]-                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt-                                 -- where we also check this.-  , all isLinear (dataConInstArgTys con tc_args)-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear-  -- arguments, for the moment, because they require unboxed tuple with variable-  -- multiplicity fields.-  = Just DataConPatContext { dcpc_dc = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co = co }-splitResultType_maybe _ _ _ = Nothing--isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =-  case w of-    One -> True-    _ -> False- findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand@@ -1062,43 +1125,7 @@     subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs     arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc) -{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Worker/wrapper will unbox--  1. A strict data type argument, that-       * is an algebraic data type (not a newtype)-       * has a single constructor (thus is a "product")-       * that may bind existentials-     We can transform-     > f (D @ex a b) = e-     to-     > $wf @ex a b = e-     via 'mkWWstr'.--  2. The constructed result of a function, if-       * its type is an algebraic data type (not a newtype)-       * (might have multiple constructors, in contrast to (1))-       * the applied data constructor *does not* bind existentials-     We can transform-     > f x y = let ... in D a b-     to-     > $wf x y = let ... in (# a, b #)-     via 'mkWWcpr'.--     NB: We don't allow existentials for CPR W/W, because we don't have unboxed-     dependent tuples (yet?). Otherwise, we could transform-     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)-     to-     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)--The respective tests are in 'splitArgType_maybe' and-'splitResultType_maybe', respectively.--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.-+{- ************************************************************************ *                                                                      * \subsection{CPR stuff}@@ -1118,7 +1145,7 @@ mkWWcpr :: Bool         -> FamInstEnvs         -> Type                              -- function body type-        -> CprResult                         -- CPR analysis results+        -> Cpr                               -- CPR analysis results         -> UniqSM (Bool,                     -- Is w/w'ing useful?                    CoreExpr -> CoreExpr,     -- New wrapper                    CoreExpr -> CoreExpr,     -- New worker@@ -1131,12 +1158,13 @@   | otherwise   = case asConCpr cpr of        Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just con_tag | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty-                    -> mkWWcpr_help dcpc-                    |  otherwise-                       -- See Note [non-algebraic or open body type warning]-                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )-                       return (False, id, id, body_ty)+       Just (con_tag, _cprs)+         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty+         -> mkWWcpr_help dcpc+         |  otherwise+         -- See Note [non-algebraic or open body type warning]+         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )+            return (False, id, id, body_ty)  mkWWcpr_help :: DataConPatContext              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)@@ -1253,70 +1281,74 @@ *                                                                      * ************************************************************************ -Note [Absent errors]-~~~~~~~~~~~~~~~~~~~~+Note [Absent fillers]+~~~~~~~~~~~~~~~~~~~~~ Consider-  data T = MkT [Int] [Int] ![Int]-  f :: T -> Int# -> blah-  f ps w = case ps of MkT xs _ _ -> <body mentioning xs>-Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus: -$wf :: [Int] -> blah-$wf xs = case ps of MkT xs _ _ -> <body mentioning xs>-  where-    ys = absentError "ys :: [Int]"-    zs = LitRubbish True-    ps = MkT xs ys zs-    w  = 0#+  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict+  f :: T -> Int# -> blah+  f ps w = case ps of MkT xs ys zs -> <body mentioning xs> -We make a let-binding for Absent arguments, such as ys and w, that are not even-passed to the worker. They should, of course, never be used. We distinguish four-cases:+Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus: -1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids-   that are marked absent, thus-      let ys = absentError "ys :: [Int]"-   The idea is that this binding will never be used; but if it-   buggily is used we'll get a runtime error message.+  $wf :: [Int] -> blah+  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+    where+      ys = absentError "ys :: [Int]"+      zs = RUBBISH[LiftedRep] @[Int]+      ps = MkT xs ys zs+      w  = RUBBISH[IntRep] @Int# -2. Boxed, lifted types, with a strict demand, like 'zs'.  You may ask: how the-   demand be both absent and strict?  That's exactly what happens for 'zs': it-   is not used, so its demand is Absent, but then during w/w, in-   addDataConStrictness, we strictify the demand.  So it gets cardinality C_10,-   the empty interval.+The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.+And neither should they! They are never used, their value is irrelevant (hence+they are *dead code*) and they are probably discarded after the next run of the+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up+with "filler" values that we bind the absent arg Ids to. -   We don't want to use an error-thunk for 'zs' because MkT's third argument has-   a bang, and hence should be always evaluated. This turned out to be-   important when fixing #16970, which establishes the invariant that strict-   constructor arguments are always evaluated. So we use LitRubbish instead-   of an error thunk -- see #19133.+That is exactly what Note [Rubbish values] are for: A convenient way to+conjure filler values at any type (and any representation or levity!). -   These first two cases are distinguished by isStrictDmd in lifted_rhs.+Needless to say, there are some wrinkles: -3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence-   for unboxed types is important; see, for example, #4306 and #15627.  We-   simply find a suitable literal, using Literal.absentLiteralOf.  We don't have-   literals for every primitive type, so the function is partial.+  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+     instead. If absence analysis was wrong (e.g., #11126) and the binding+     in fact is used, then we get a nice panic message instead of undefined+     runtime behavior (See Modes of failure from Note [Rubbish values]). -4. Boxed, unlifted types, like (Array# t).  We can't use absentError because-   unlifted bindings ares strict.  So we use LitRubbish, which we need to apply-   to the required type.+     Obviously, we can't use an error-thunk if the value is of unlifted rep+     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. -Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish-literals] in GHC.Types.Literal.  We could do that in case (1) as well, but we-get slightly better self-checking with an error thunk.+  2. We also mustn't put an error-thunk (that fills in for an absent value of+     lifted rep) in a strict field, because #16970 establishes the invariant+     that strict fields are always evaluated, by (re-)evaluating what is put in+     a strict field. That's the reason why 'zs' binds a rubbish literal instead+     of an error-thunk, see #19133. -Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"-value is used after all.  Then in case (2) we could get a seg-fault, because we-may have replaced, say, a [Either Int Bool] by (), and that will fail if we do-case analysis on it.  Similarly with boxed unlifted types, case (4).+     How do we detect when we are about to put an error-thunk in a strict field?+     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but+     it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.+     So we rather look out for a necessary condition for strict fields:+     Note [Add demands for strict constructors] makes it so that the demand on+     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty+     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees+     we never fill in an error-thunk for an absent strict field.+     But that also means we emit a rubbish lit for other args that have+     cardinality 'C_10' (say, the arg to a bottoming function) where we could've+     used an error-thunk, but that's a small price to pay for simplicity. -In case (3), if absence analysis is wrong we could conceivably get an exception,-from a divide-by-zero with the absent value.  But it's very unlikely.+  3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.+     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+     Why? Because if we don't know its representation (e.g. size in memory,+     register class), we don't know what or how much rubbish to emit in codegen.+     'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall+     back to passing the original parameter to the worker. -Only in case (1) can we guarantee a civilised runtime error.  Not much we can do-about this; we really rely on absence analysis to be correct.+     Note that currently this case should not occur, because binders always+     have to be representation monomorphic. But in the future, we might allow+     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. +While (1) and (2) are simply an optimisation in terms of compiler debugging+experience, (3) should be irrelevant in most programs, if not all.  Historical note: I did try the experiment of using an error thunk for unlifted things too, relying on the simplifier to drop it as dead code.  But this is@@ -1340,66 +1372,46 @@ -- -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found (currently only happens for bindings of 'VecRep' representation).-mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags fam_envs arg dmd--  -- The lifted case: Bind 'absentError'-  -- See Note [Absent errors]-  | not (isUnliftedType arg_ty)-  = Just (Let (NonRec lifted_arg lifted_rhs))-  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@-  -- See Note [Absent errors]--  | [UnliftedRep] <- typePrimRep arg_ty-  = Just (Let (NonRec arg unlifted_rhs))--  -- The monomorphic unlifted cases: Bind to some literal, if possible-  -- See Note [Absent errors]-  | Just tc <- tyConAppTyCon_maybe nty-  , Just lit <- absentLiteralOf tc-  = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))+-- found.+mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags arg dmd+  -- The lifted case: Bind 'absentError' for a nice panic message if we are+  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+  | Just [LiftedRep] <- mb_mono_prim_reps+  , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]+  = Just (Let (NonRec arg panic_rhs)) -  | nty `eqType` unboxedUnitTy-  = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))+  -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@+  -- See Note [Absent fillers], the main part+  | Just prim_reps <- mb_mono_prim_reps+  = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty])) -  | otherwise+  -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.+  -- See (3) in Note [Absent fillers]+  | Nothing <- mb_mono_prim_reps   = WARN( True, text "No absent value for" <+> ppr arg_ty )-    Nothing -- Can happen for 'State#' and things of 'VecRep'+    Nothing   where-    lifted_arg   = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr-              -- Note in strictness signature that this is bottoming-              -- (for the sake of the "empty case scrutinee not known to-              -- diverge for sure lint" warning)--    lifted_rhs | isStrictDmd dmd = mkTyApps (Lit (rubbishLit True))  [arg_ty]-               | otherwise       = mkAbsentErrorApp arg_ty msg-    unlifted_rhs = mkTyApps (Lit (rubbishLit False)) [arg_ty]--    arg_ty       = idType arg+    arg_ty            = idType arg+    mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty -    -- Normalise the type to have best chance of finding an absent literal-    -- e.g. (#17852)   data unlifted N = MkN Int#-    --                 f :: N -> a -> a-    --                 f _ x = x-    (co, nty)    = topNormaliseType_maybe fam_envs arg_ty-                   `orElse` (mkRepReflCo arg_ty, arg_ty)+    panic_rhs = mkAbsentErrorApp arg_ty msg -    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)-                            (vcat-                              [ text "Arg:" <+> ppr arg-                              , text "Type:" <+> ppr arg_ty-                              , file_msg-                              ])-    file_msg     = case outputFile dflags of-                     Nothing -> empty-                     Just f  -> text "In output file " <+> quotes (text f)+    msg       = showSDoc (gopt_set dflags Opt_SuppressUniques)+                         (vcat+                           [ text "Arg:" <+> ppr arg+                           , text "Type:" <+> ppr arg_ty+                           , file_msg+                           ])               -- We need to suppress uniques here because otherwise they'd               -- end up in the generated code as strings. This is bad for               -- determinism, because with different uniques the strings               -- will have different lengths and hence different costs for               -- the inliner leading to different inlining.               -- See also Note [Unique Determinism] in GHC.Types.Unique+    file_msg  = case outputFile dflags of+                  Nothing -> empty+                  Just f  -> text "In output file " <+> quotes (text f)  ww_prefix :: FastString ww_prefix = fsLit "ww"

@@ -58,6 +58,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Unique.FM+import GHC.Types.Tickish import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )

@@ -30,6 +30,7 @@ import GHC.Types.Unique.FM import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Data.Maybe import Data.List (mapAccumL) @@ -88,8 +89,9 @@     (Alt con vs (tidyExpr env' rhs))  ------------  Tickish  ---------------tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id-tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids)+tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish+tidyTickish env (Breakpoint ext ix ids)+  = Breakpoint ext ix (map (tidyVarOcc env) ids) tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------@@ -206,7 +208,7 @@         new_info = vanillaIdInfo                     `setOccInfo`        occInfo old_info                     `setArityInfo`      arityInfo old_info-                    `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)+                    `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)                     `setDemandInfo`     demandInfo old_info                     `setInlinePragInfo` inlinePragInfo old_info                     `setUnfoldingInfo`  new_unf

@@ -1,2116 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards            #-}--{-# OPTIONS_GHC -fprof-auto-top #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-------  (c) The University of Glasgow 2002-2006------- | GHC.CoreToByteCode: Generate bytecode from Core-module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Driver.Session-import GHC.Driver.Env--import GHC.ByteCode.Instr-import GHC.ByteCode.Asm-import GHC.ByteCode.Types--import GHC.Platform-import GHC.Platform.Profile--import GHC.Runtime.Interpreter-import GHCi.FFI-import GHCi.RemoteTypes-import GHC.Types.Basic-import GHC.Utils.Outputable-import GHC.Types.Name-import GHC.Types.Id.Make-import GHC.Types.Id-import GHC.Types.ForeignCall-import GHC.Core.Utils-import GHC.Core-import GHC.Core.Ppr-import GHC.Types.Literal-import GHC.Builtin.PrimOps-import GHC.Core.FVs-import GHC.Core.Type-import GHC.Types.RepType-import GHC.Core.DataCon-import GHC.Core.TyCon-import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Types.Var.Set-import GHC.Builtin.Types ( unboxedUnitTy )-import GHC.Builtin.Types.Prim-import GHC.Core.TyCo.Ppr ( pprType )-import GHC.Utils.Error-import GHC.Types.Unique-import GHC.Builtin.Uniques-import GHC.Data.FastString-import GHC.Utils.Panic-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )-import GHC.StgToCmm.Layout-import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)-import GHC.Data.Bitmap-import GHC.Data.OrdList-import GHC.Data.Maybe-import GHC.Types.Var.Env-import GHC.Builtin.Names ( unsafeEqualityProofName )--import Data.List ( genericReplicate, genericLength, intersperse-                 , partition, scanl', sort, sortBy, zip4, zip6, nub )-import Foreign-import Control.Monad-import Data.Char--import GHC.Types.Unique.Supply-import GHC.Unit.Module--import Control.Exception-import Data.Array-import Data.Coerce (coerce)-import Data.ByteString (ByteString)-import Data.Map (Map)-import Data.IntMap (IntMap)-import qualified Data.Map as Map-import qualified Data.IntMap as IntMap-import qualified GHC.Data.FiniteMap as Map-import Data.Ord-import GHC.Stack.CCS-import Data.Either ( partitionEithers )---- -------------------------------------------------------------------------------- Generating byte code for a complete module--byteCodeGen :: HscEnv-            -> Module-            -> CoreProgram-            -> [TyCon]-            -> Maybe ModBreaks-            -> IO CompiledByteCode-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks-   = withTiming logger dflags-                (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))-                (const ()) $ do-        -- Split top-level binds into strings and others.-        -- See Note [generating code for top-level string literal bindings].-        let (strings, flatBinds) = partitionEithers $ do  -- list monad-                (bndr, rhs) <- flattenBinds binds-                return $ case exprIsTickedString_maybe rhs of-                    Just str -> Left (bndr, str)-                    _ -> Right (bndr, simpleFreeVars rhs)-        stringPtrs <- allocateTopStrings hsc_env strings--        us <- mkSplitUniqSupply 'y'-        (BcM_State{..}, proto_bcos) <--           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $-             mapM schemeTopBind flatBinds--        when (notNull ffis)-             (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?")--        dumpIfSet_dyn logger dflags Opt_D_dump_BCOs-           "Proto-BCOs" FormatByteCode-           (vcat (intersperse (char ' ') (map ppr proto_bcos)))--        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)-          (case modBreaks of-             Nothing -> Nothing-             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })--        -- Squash space leaks in the CompiledByteCode.  This is really-        -- important, because when loading a set of modules into GHCi-        -- we don't touch the CompiledByteCode until the end when we-        -- do linking.  Forcing out the thunks here reduces space-        -- usage by more than 50% when loading a large number of-        -- modules.-        evaluate (seqCompiledByteCode cbc)--        return cbc--  where dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env--allocateTopStrings-  :: HscEnv-  -> [(Id, ByteString)]-  -> IO [(Var, RemotePtr ())]-allocateTopStrings hsc_env topStrings = do-  let !(bndrs, strings) = unzip topStrings-  ptrs <- iservCmd hsc_env $ MallocStrings strings-  return $ zip bndrs ptrs--{--Note [generating code for top-level string literal bindings]--Here is a summary on how the byte code generator deals with top-level string-literals:--1. Top-level string literal bindings are separated from the rest of the module.--2. The strings are allocated via iservCmd, in allocateTopStrings--3. The mapping from binders to allocated strings (topStrings) are maintained in-   BcM and used when generating code for variable references.--}---- -------------------------------------------------------------------------------- Generating byte code for an expression---- Returns: the root BCO for this expression-coreExprToBCOs :: HscEnv-               -> Module-               -> CoreExpr-               -> IO UnlinkedBCO-coreExprToBCOs hsc_env this_mod expr- = withTiming logger dflags-              (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))-              (const ()) $ do-      -- create a totally bogus name for the top-level BCO; this-      -- should be harmless, since it's never used for anything-      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")--      -- the uniques are needed to generate fresh variables when we introduce new-      -- let bindings for ticked expressions-      us <- mkSplitUniqSupply 'y'-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)-         <- runBc hsc_env us this_mod Nothing emptyVarEnv $-              schemeR [] (invented_name, simpleFreeVars expr)--      when (notNull mallocd)-           (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?")--      dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode-         (ppr proto_bco)--      assembleOneBCO hsc_env proto_bco-  where dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env---- The regular freeVars function gives more information than is useful to--- us here. We need only the free variables, not everything in an FVAnn.--- Historical note: At one point FVAnn was more sophisticated than just--- a set. Now it isn't. So this function is much simpler. Keeping it around--- so that if someone changes FVAnn, they will get a nice type error right--- here.-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet-simpleFreeVars = freeVars---- -------------------------------------------------------------------------------- Compilation schema for the bytecode generator--type BCInstrList = OrdList BCInstr--newtype ByteOff = ByteOff Int-    deriving (Enum, Eq, Integral, Num, Ord, Real)--newtype WordOff = WordOff Int-    deriving (Enum, Eq, Integral, Num, Ord, Real)--wordsToBytes :: Platform -> WordOff -> ByteOff-wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral---- Used when we know we have a whole number of words-bytesToWords :: Platform -> ByteOff -> WordOff-bytesToWords platform (ByteOff bytes) =-    let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)-    in if r == 0-           then fromIntegral q-           else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes--wordSize :: Platform -> ByteOff-wordSize platform = ByteOff (platformWordSizeInBytes platform)--type Sequel = ByteOff -- back off to this depth before ENTER--type StackDepth = ByteOff---- | Maps Ids to their stack depth. This allows us to avoid having to mess with--- it after each push/pop.-type BCEnv = Map Id StackDepth -- To find vars on the stack--{--ppBCEnv :: BCEnv -> SDoc-ppBCEnv p-   = text "begin-env"-     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))-     $$ text "end-env"-     where-        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)-        cmp_snd x y = compare (snd x) (snd y)--}---- Create a BCO and do a spot of peephole optimisation on the insns--- at the same time.-mkProtoBCO-   :: Platform-   -> name-   -> BCInstrList-   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)-        -- ^ original expression; for debugging only-   -> Int-   -> Word16-   -> [StgWord]-   -> Bool      -- True <=> is a return point, rather than a function-   -> [FFIInfo]-   -> ProtoBCO name-mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis-   = ProtoBCO {-        protoBCOName = nm,-        protoBCOInstrs = maybe_with_stack_check,-        protoBCOBitmap = bitmap,-        protoBCOBitmapSize = bitmap_size,-        protoBCOArity = arity,-        protoBCOExpr = origin,-        protoBCOFFIs = ffis-      }-     where-        -- Overestimate the stack usage (in words) of this BCO,-        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit-        -- stack check.  (The interpreter always does a stack check-        -- for iNTERP_STACK_CHECK_THRESH words at the start of each-        -- BCO anyway, so we only need to add an explicit one in the-        -- (hopefully rare) cases when the (overestimated) stack use-        -- exceeds iNTERP_STACK_CHECK_THRESH.-        maybe_with_stack_check-           | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d-                -- don't do stack checks at return points,-                -- everything is aggregated up to the top BCO-                -- (which must be a function).-                -- That is, unless the stack usage is >= AP_STACK_SPLIM,-                -- see bug #1466.-           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH-           = STKCHECK stack_usage : peep_d-           | otherwise-           = peep_d     -- the supposedly common case--        -- We assume that this sum doesn't wrap-        stack_usage = sum (map bciStackUse peep_d)--        -- Merge local pushes-        peep_d = peep (fromOL instrs_ordlist)--        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)-           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest-        peep (PUSH_L off1 : PUSH_L off2 : rest)-           = PUSH_LL off1 (off2-1) : peep rest-        peep (i:rest)-           = i : peep rest-        peep []-           = []--argBits :: Platform -> [ArgRep] -> [Bool]-argBits _        [] = []-argBits platform (rep : args)-  | isFollowableArg rep  = False : argBits platform args-  | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args---- -------------------------------------------------------------------------------- schemeTopBind---- Compile code for the right-hand side of a top-level binding--schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)-schemeTopBind (id, rhs)-  | Just data_con <- isDataConWorkId_maybe id,-    isNullaryRepDataCon data_con = do-    platform <- profilePlatform <$> getProfile-        -- Special case for the worker of a nullary data con.-        -- It'll look like this:        Nil = /\a -> Nil a-        -- If we feed it into schemeR, we'll get-        --      Nil = Nil-        -- because mkConAppCode treats nullary constructor applications-        -- by just re-using the single top-level definition.  So-        -- for the worker itself, we must allocate it directly.-    -- ioToBc (putStrLn $ "top level BCO")-    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, ENTER])-                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})--  | otherwise-  = schemeR [{- No free variables -}] (getName id, rhs)----- -------------------------------------------------------------------------------- schemeR---- Compile code for a right-hand side, to give a BCO that,--- when executed with the free variables and arguments on top of the stack,--- will return with a pointer to the result on top of the stack, after--- removing the free variables and arguments.------ Park the resulting BCO in the monad.  Also requires the--- name of the variable to which this value was bound,--- so as to give the resulting BCO a name.--schemeR :: [Id]                 -- Free vars of the RHS, ordered as they-                                -- will appear in the thunk.  Empty for-                                -- top-level things, which have no free vars.-        -> (Name, AnnExpr Id DVarSet)-        -> BcM (ProtoBCO Name)-schemeR fvs (nm, rhs)-{--   | trace (showSDoc (-              (char ' '-               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs-               $$ pprCoreExpr (deAnnotate rhs)-               $$ char ' '-              ))) False-   = undefined-   | otherwise--}-   = schemeR_wrk fvs nm rhs (collect rhs)---- If an expression is a lambda (after apply bcView), return the--- list of arguments to the lambda (in R-to-L order) and the--- underlying expression-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)-collect (_, e) = go [] e-  where-    go xs e | Just e' <- bcView e = go xs e'-    go xs (AnnLam x (_,e))-      | typePrimRep (idType x) `lengthExceeds` 1-      = multiValException-      | otherwise-      = go (x:xs) e-    go xs not_lambda = (reverse xs, not_lambda)--schemeR_wrk-    :: [Id]-    -> Name-    -> AnnExpr Id DVarSet             -- expression e, for debugging only-    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e-    -> BcM (ProtoBCO Name)-schemeR_wrk fvs nm original_body (args, body)-   = do-     profile <- getProfile-     let-         platform  = profilePlatform profile-         all_args  = reverse args ++ fvs-         arity     = length all_args-         -- all_args are the args in reverse order.  We're compiling a function-         -- \fv1..fvn x1..xn -> e-         -- i.e. the fvs come first--         -- Stack arguments always take a whole number of words, we never pack-         -- them unlike constructor fields.-         szsb_args = map (wordsToBytes platform . idSizeW platform) all_args-         sum_szsb_args  = sum szsb_args-         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))--         -- make the arg bitmap-         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--     emitBc (mkProtoBCO platform nm body_code (Right original_body)-                 arity bitmap_size bitmap False{-not alts-})---- introduce break instructions for ticked expressions-schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-schemeER_wrk d p rhs-  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs-  = do  code <- schemeE d 0 p newRhs-        cc_arr <- getCCArray-        this_mod <- moduleName <$> getCurrentModule-        platform <- profilePlatform <$> getProfile-        let idOffSets = getVarOffSets platform d p fvs-        let breakInfo = CgBreakInfo-                        { cgb_vars = idOffSets-                        , cgb_resty = exprType (deAnnotate' newRhs)-                        }-        newBreakInfo tick_no breakInfo-        hsc_env <- getHscEnv-        let cc | Just interp <- hsc_interp hsc_env-               , interpreterProfiled interp-               = cc_arr ! tick_no-               | otherwise = toRemotePtr nullPtr-        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc-        return $ breakInstr `consOL` code-   | otherwise = schemeE d 0 p rhs--getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]-getVarOffSets platform depth env = map getOffSet-  where-    getOffSet id = case lookupBCEnv_maybe id env of-        Nothing     -> Nothing-        Just offset ->-            -- michalt: I'm not entirely sure why we need the stack-            -- adjustment by 2 here. I initially thought that there's-            -- something off with getIdValFromApStack (the only user of this-            -- value), but it looks ok to me. My current hypothesis is that-            -- this "adjustment" is needed due to stack manipulation for-            -- BRK_FUN in Interpreter.c In any case, this is used only when-            -- we trigger a breakpoint.-            let !var_depth_ws =-                    trunc16W $ bytesToWords platform (depth - offset) + 2-            in Just (id, var_depth_ws)--truncIntegral16 :: Integral a => a -> Word16-truncIntegral16 w-    | w > fromIntegral (maxBound :: Word16)-    = panic "stack depth overflow"-    | otherwise-    = fromIntegral w--trunc16B :: ByteOff -> Word16-trunc16B = truncIntegral16--trunc16W :: WordOff -> Word16-trunc16W = truncIntegral16--fvsToEnv :: BCEnv -> DVarSet -> [Id]--- Takes the free variables of a right-hand side, and--- delivers an ordered list of the local variables that will--- be captured in the thunk for the RHS--- The BCEnv argument tells which variables are in the local--- environment: these are the ones that should be captured------ The code that constructs the thunk, and the code that executes--- it, have to agree about this layout-fvsToEnv p fvs = [v | v <- dVarSetElems fvs,-                      isId v,           -- Could be a type variable-                      v `Map.member` p]---- -------------------------------------------------------------------------------- schemeE--returnUnboxedAtom-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr' Id DVarSet-    -> ArgRep-    -> BcM BCInstrList--- Returning an unlifted value.--- Heave it on the stack, SLIDE, and RETURN.-returnUnboxedAtom d s p e e_rep = do-    dflags <- getDynFlags-    let platform = targetPlatform dflags-    (push, szb) <- pushAtom d p e-    return (push                                  -- value onto stack-           `appOL`  mkSlideB platform szb (d - s) -- clear to sequel-           `snocOL` RETURN_UBX e_rep)             -- go---- Compile code to apply the given expression to the remaining args--- on the stack, returning a HNF.-schemeE-    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-schemeE d s p e-   | Just e' <- bcView e-   = schemeE d s p e'---- Delegate tail-calls to schemeT.-schemeE d s p e@(AnnApp _ _) = schemeT d s p e--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) = 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))-   | (AnnVar v, args_r_to_l) <- splitApp rhs,-     Just data_con <- isDataConWorkId_maybe v,-     dataConRepArity data_con == length args_r_to_l-   = do -- Special case for a non-recursive let whose RHS is a-        -- saturated constructor application.-        -- Just allocate the constructor and carry on-        alloc_code <- mkConAppCode d s p data_con args_r_to_l-        platform <- targetPlatform <$> getDynFlags-        let !d2 = d + wordSize platform-        body_code <- schemeE d2 s (Map.insert x d2 p) body-        return (alloc_code `appOL` body_code)---- General case for let.  Generates correct, if inefficient, code in--- all situations.-schemeE d s p (AnnLet binds (_,body)) = do-     platform <- targetPlatform <$> getDynFlags-     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])-                                   AnnRec xs_n_rhss -> unzip xs_n_rhss-         n_binds = genericLength xs--         fvss  = map (fvsToEnv p' . fst) rhss--           -- See Note [Not-necessarily-lifted join points], step 2.-         (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss--         -- Sizes of free vars-         size_w = trunc16W . idSizeW platform-         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss--         -- the arity of each rhs-         arities = map (genericLength . fst . collect) rhss'--         -- This p', d' defn is safe because all the items being pushed-         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack-         -- after the closures have been allocated in the heap (but not-         -- filled in), and pointers to them parked on the stack.-         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))-         p' = Map.insertList (zipE xs' offsets) p-         d' = d + wordsToBytes platform n_binds-         zipE = zipEqual "schemeE"--         -- ToDo: don't build thunks for things with no free variables-         build_thunk-             :: StackDepth-             -> [Id]-             -> Word16-             -> ProtoBCO Name-             -> Word16-             -> Word16-             -> BcM BCInstrList-         build_thunk _ [] size bco off arity-            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))-           where-                mkap | arity == 0 = MKAP-                     | otherwise  = MKPAP-         build_thunk dd (fv:fvs) size bco off arity = do-              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)-              more_push_code <--                  build_thunk (dd + pushed_szb) fvs size bco off arity-              return (push_code `appOL` more_push_code)--         alloc_code = toOL (zipWith mkAlloc sizes arities)-           where mkAlloc sz 0-                    | is_tick     = ALLOC_AP_NOUPD sz-                    | otherwise   = ALLOC_AP sz-                 mkAlloc sz arity = ALLOC_PAP arity sz--         is_tick = case binds of-                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS-                     _other -> False--         compile_bind d' fvs x rhs size arity off = do-                bco <- schemeR fvs (getName x,rhs)-                build_thunk d' fvs size bco off arity--         compile_binds =-            [ compile_bind d' fvs x rhs size arity (trunc16W n)-            | (fvs, x, rhs, size, arity, n) <--                zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]-            ]-     body_code <- schemeE d' s p' body-     thunk_codes <- sequence compile_binds-     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)---- Introduce a let binding for a ticked case expression. This rule--- *should* only fire when the expression was not already let-bound--- (the code gen for let bindings should take care of that).  Todo: we--- call exprFreeVars on a deAnnotated expression, this may not be the--- best way to calculate the free vars but it seemed like the least--- intrusive thing to do-schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)-   | isLiftedTypeKind (typeKind ty)-   = do   id <- newId ty-          -- Todo: is emptyVarSet correct on the next line?-          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)-          schemeE d s p letExp--   | otherwise-   = do   -- If the result type is not definitely lifted, then we must generate-          --   let f = \s . tick<n> e-          --   in  f realWorld#-          -- When we stop at the breakpoint, _result will have an unlifted-          -- type and hence won't be bound in the environment, but the-          -- breakpoint will otherwise work fine.-          ---          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where-          --    r :: RuntimeRep is a variable. This can happen in the-          --    continuations for a pattern-synonym matcher-          --    match = /\(r::RuntimeRep) /\(a::TYPE r).-          --            \(k :: Int -> a) \(v::T).-          --            case v of MkV n -> k n-          -- Here (k n) :: a :: TYPE r, so we don't know if it's lifted-          -- or not; but that should be fine provided we add that void arg.--          id <- newId (mkVisFunTyMany realWorldStatePrimTy ty)-          st <- newId realWorldStatePrimTy-          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))-                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)-                                                    (emptyDVarSet, AnnVar realWorldPrimId)))-          schemeE d s p letExp--   where-     exp' = deAnnotate' exp-     fvs  = exprFreeVarsDSet exp'-     ty   = exprType exp'---- ignore other kinds of tick-schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs---- no alts: scrut is guaranteed to diverge-schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut---- handle pairs with one void argument (e.g. state token)-schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1, bind2] rhs])-   | isUnboxedTupleDataCon dc-        -- Convert-        --      case .... of x { (# V'd-thing, a #) -> ... }-        -- to-        --      case .... of a { DEFAULT -> ... }-        -- because the return convention for both are identical.-        ---        -- Note that it does not matter losing the void-rep thing from the-        -- envt (it won't be bound now) because we never look such things up.-   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of-                   ([], [_])-                     -> Just $ doCase d s p scrut bind2 [AnnAlt DEFAULT [] rhs] (Just bndr)-                   ([_], [])-                     -> Just $ doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr)-                   _ -> Nothing-   = res---- handle unit tuples-schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1] rhs])-   | isUnboxedTupleDataCon dc-   , typePrimRep (idType bndr) `lengthAtMost` 1-   = doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr)---- handle nullary tuples-schemeE d s p (AnnCase scrut bndr _ alt@[AnnAlt DEFAULT [] _])-   | isUnboxedTupleType (idType bndr)-   , Just ty <- case typePrimRep (idType bndr) of-       [_]  -> Just (unwrapType (idType bndr))-       []   -> Just unboxedUnitTy-       _    -> Nothing-       -- handles any pattern with a single non-void binder; in particular I/O-       -- monad returns (# RealWorld#, a #)-   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)--schemeE d s p (AnnCase scrut bndr _ alts)-   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}--schemeE _ _ _ expr-   = pprPanic "GHC.CoreToByteCode.schemeE: unhandled case"-               (pprCoreExpr (deAnnotate' expr))---- Is this Id a not-necessarily-lifted join point?--- See Note [Not-necessarily-lifted join points], step 1-isNNLJoinPoint :: Id -> Bool-isNNLJoinPoint x = isJoinId x &&-                   Just True /= isLiftedType_maybe (idType x)---- If necessary, modify this Id and body to protect not-necessarily-lifted join points.--- See Note [Not-necessarily-lifted join points], step 2.-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)-protectNNLJoinPointBind x rhs@(fvs, _)-  | isNNLJoinPoint x-  = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))--  | otherwise-  = (x, rhs)---- Update an Id's type to take a Void# argument.--- Precondition: the Id is a not-necessarily-lifted join point.--- See Note [Not-necessarily-lifted join points]-protectNNLJoinPointId :: Id -> Id-protectNNLJoinPointId x-  = ASSERT( isNNLJoinPoint x )-    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x--{--   Ticked Expressions-   --------------------  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on-  the code. When we find such a thing, we pull out the useful information,-  and then compile the code as if it was just the expression E.--Note [Not-necessarily-lifted join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A join point variable is essentially a goto-label: it is, for example,-never used as an argument to another function, and it is called only-in tail position. See Note [Join points] and Note [Invariants on join points],-both in GHC.Core. Because join points do not compile to true, red-blooded-variables (with, e.g., registers allocated to them), they are allowed-to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]-in GHC.Core.)--However, in this byte-code generator, join points *are* treated just as-ordinary variables. There is no check whether a binding is for a join point-or not; they are all treated uniformly. (Perhaps there is a missed optimization-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)--We thus must have *some* strategy for dealing with levity-polymorphic and-unlifted join points. Levity-polymorphic variables are generally not allowed-(though levity-polymorphic join points *are*; see Note [Invariants on join points]-in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.-The questionable join points are *not-necessarily-lifted join points*-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:--1. Detect NNLJPs. This is done in isNNLJoinPoint.--2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the-   type to tack on a `(# #) ->`.-   Note that functions are never levity-polymorphic, so this transformation-   changes an NNLJP to a non-levity-polymorphic join point. This is done-   in protectNNLJoinPointBind, called from the AnnLet case of schemeE.--3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),-   being careful to note the new type of the NNLJP. This is done in the AnnVar-   case of schemeE, with help from protectNNLJoinPointId.--Here is an example. Suppose we have--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      join j :: a-           j = error @r @a "bloop"-      in case x of-           A -> j-           B -> j-           C -> error @r @a "blurp"--Our plan is to behave is if the code was--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      let j :: (Void# -> a)-          j = \ _ -> error @r @a "bloop"-      in case x of-           A -> j void#-           B -> j void#-           C -> error @r @a "blurp"--It's a bit hacky, but it works well in practice and is local. I suspect the-Right Fix is to take advantage of join points as goto-labels.---}---- Compile code to do a tail call.  Specifically, push the fn,--- slide the on-stack app back down to the sequel depth,--- and enter.  Four cases:------ 0.  (Nasty hack).---     An application "GHC.Prim.tagToEnum# <type> unboxed-int".---     The int will be on the stack.  Generate a code sequence---     to convert it to the relevant constructor, SLIDE and ENTER.------ 1.  The fn denotes a ccall.  Defer to generateCCall.------ 2.  (Another nasty hack).  Spot (# a::V, b #) and treat---     it simply as  b  -- since the representations are identical---     (the V takes up zero stack space).  Also, spot---     (# b #) and treat it as  b.------ 3.  Application of a constructor, by defn saturated.---     Split the args into ptrs and non-ptrs, and push the nonptrs,---     then the ptrs, and then do PACK and RETURN.------ 4.  Otherwise, it must be a function call.  Push the args---     right to left, SLIDE and ENTER.--schemeT :: StackDepth   -- Stack depth-        -> Sequel       -- Sequel depth-        -> BCEnv        -- stack env-        -> AnnExpr' Id DVarSet-        -> BcM BCInstrList--schemeT d s p app--   -- Case 0-   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app-   = implement_tagToId d s p arg constr_names--   -- Case 1-   | Just (CCall ccall_spec) <- isFCallId_maybe fn-   = if isSupportedCConv ccall_spec-      then generateCCall d s p ccall_spec fn args_r_to_l-      else unsupportedCConvException---   -- Case 2: Constructor application-   | Just con <- maybe_saturated_dcon-   , isUnboxedTupleDataCon con-   = do-     platform <- profilePlatform <$> getProfile-     case args_r_to_l of-        [arg1,arg2] | isVAtom platform arg1 ->-                  unboxedTupleReturn d s p 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-        platform <- profilePlatform <$> getProfile-        return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`-                ENTER)--   -- Case 4: Tail call of function-   | otherwise-   = doTailCall d s p fn args_r_to_l--   where-        -- Extract the args (R->L) and fn-        -- The function will necessarily be a variable,-        -- because we are compiling a tail call-      (AnnVar fn, args_r_to_l) = splitApp app--      -- Only consider this to be a constructor application iff it is-      -- saturated.  Otherwise, we'll call the constructor wrapper.-      n_args = length args_r_to_l-      maybe_saturated_dcon-        = case isDataConWorkId_maybe fn of-                Just con | dataConRepArity con == n_args -> Just con-                _ -> Nothing---- -------------------------------------------------------------------------------- Generate code to build a constructor application,--- leaving it on top of the stack--mkConAppCode-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> DataCon                  -- The data constructor-    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order-    -> BcM BCInstrList-mkConAppCode _ _ _ con []       -- Nullary constructor-  = ASSERT( isNullaryRepDataCon con )-    return (unitOL (PUSH_G (getName (dataConWorkId con))))-        -- Instead of doing a PACK, which would allocate a fresh-        -- copy of this constructor, use the single shared version.--mkConAppCode orig_d _ p con args_r_to_l =-    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code-  where-    app_code = do-        profile <- getProfile-        let platform = profilePlatform profile--        -- The args are initially in reverse order, but mkVirtHeapOffsets-        -- expects them to be left-to-right.-        let non_voids =-                [ NonVoid (prim_rep, arg)-                | arg <- reverse args_r_to_l-                , let prim_rep = atomPrimRep arg-                , not (isVoidRep prim_rep)-                ]-            (_, _, args_offsets) =-                mkVirtHeapOffsetsWithPadding profile StdHeader non_voids--            do_pushery !d (arg : args) = do-                (push, arg_bytes) <- case arg of-                    (Padding l _) -> return $! pushPadding l-                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)-                more_push_code <- do_pushery (d + arg_bytes) args-                return (push `appOL` more_push_code)-            do_pushery !d [] = do-                let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)-                return (unitOL (PACK con n_arg_words))--        -- Push on the stack in the reverse order.-        do_pushery orig_d (reverse args_offsets)----- -------------------------------------------------------------------------------- Returning an unboxed tuple with one non-void component (the only--- case we can handle).------ Remember, we don't want to *evaluate* the component that is being--- returned, even if it is a pointed type.  We always just return.--unboxedTupleReturn-    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-unboxedTupleReturn d s p arg = do-   platform <- profilePlatform <$> getProfile-   returnUnboxedAtom d s p arg (atomRep platform arg)---- -------------------------------------------------------------------------------- Generate code for a tail-call--doTailCall-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> Id-    -> [AnnExpr' Id DVarSet]-    -> BcM BCInstrList-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)-        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))-  do_pushes !d args reps = do-      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-      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))--  push_seq d [] = return (d, nilOL)-  push_seq d (arg:args) = do-    (push_code, sz) <- pushAtom d p arg-    (final_d, more_push_code) <- push_seq (d + sz) args-    return (final_d, push_code `appOL` more_push_code)---- v. similar to CgStackery.findMatch, ToDo: merge-findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])-findPushSeq (P: P: P: P: P: P: rest)-  = (PUSH_APPLY_PPPPPP, 6, rest)-findPushSeq (P: P: P: P: P: rest)-  = (PUSH_APPLY_PPPPP, 5, rest)-findPushSeq (P: P: P: P: rest)-  = (PUSH_APPLY_PPPP, 4, rest)-findPushSeq (P: P: P: rest)-  = (PUSH_APPLY_PPP, 3, rest)-findPushSeq (P: P: rest)-  = (PUSH_APPLY_PP, 2, rest)-findPushSeq (P: rest)-  = (PUSH_APPLY_P, 1, rest)-findPushSeq (V: rest)-  = (PUSH_APPLY_V, 1, rest)-findPushSeq (N: rest)-  = (PUSH_APPLY_N, 1, rest)-findPushSeq (F: rest)-  = (PUSH_APPLY_F, 1, rest)-findPushSeq (D: rest)-  = (PUSH_APPLY_D, 1, rest)-findPushSeq (L: rest)-  = (PUSH_APPLY_L, 1, rest)-findPushSeq _-  = panic "GHC.CoreToByteCode.findPushSeq"---- -------------------------------------------------------------------------------- Case expressions--doCase-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr Id DVarSet-    -> Id-    -> [AnnAlt Id DVarSet]-    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,-                 -- don't enter the result-    -> BcM BCInstrList-doCase d s p (_,scrut) bndr alts is_unboxed_tuple-  | typePrimRep (idType bndr) `lengthExceeds` 1-  = multiValException--  | otherwise-  = do-     profile <- getProfile-     hsc_env <- getHscEnv-     let-        platform = profilePlatform profile--        profiling-          | Just interp <- hsc_interp hsc_env-          = interpreterProfiled interp-          | otherwise = False--        -- Top of stack is the return itbl, as usual.-        -- underneath it is the pointer to the alt_code BCO.-        -- When an alt is entered, it assumes the returned value is-        -- on top of the itbl.-        ret_frame_size_b :: StackDepth-        ret_frame_size_b = 2 * wordSize platform--        -- The extra frame we push to save/restore the CCCS when profiling-        save_ccs_size_b | profiling = 2 * wordSize platform-                        | otherwise = 0--        -- An unlifted value gets an extra info table pushed on top-        -- when it is returned.-        unlifted_itbl_size_b :: StackDepth-        unlifted_itbl_size_b | isAlgCase = 0-                             | otherwise = wordSize platform--        -- depth of stack after the return value has been pushed-        d_bndr =-            d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)--        -- depth of stack after the extra info table for an unboxed return-        -- has been pushed, if any.  This is the stack depth at the-        -- continuation.-        d_alts = d_bndr + unlifted_itbl_size_b--        -- Env in which to compile the alts, not including-        -- any vars bound by the alts themselves-        p_alts0 = Map.insert bndr d_bndr p--        p_alts = case is_unboxed_tuple of-                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0-                   Nothing       -> p_alts0--        bndr_ty = idType bndr-        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple--        -- given an alt, return a discr and code for it.-        codeAlt (AnnAlt DEFAULT _ (_,rhs))-           = do rhs_code <- schemeE d_alts s p_alts rhs-                return (NoDiscr, rhs_code)--        codeAlt alt@(AnnAlt _ bndrs (_,rhs))-           -- primitive or nullary constructor alt: no need to UNPACK-           | null real_bndrs = do-                rhs_code <- schemeE d_alts s p_alts rhs-                return (my_discr alt, rhs_code)-           -- If an alt attempts to match on an unboxed tuple or sum, we must-           -- bail out, as the bytecode compiler can't handle them.-           -- (See #14608.)-           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs-           = multiValException-           -- algebraic alt with some binders-           | otherwise =-             let (tot_wds, _ptrs_wds, args_offsets) =-                     mkVirtHeapOffsets profile NoHeader-                         [ NonVoid (bcIdPrimRep id, id)-                         | NonVoid id <- nonVoidIds real_bndrs-                         ]-                 size = WordOff tot_wds--                 stack_bot = d_alts + wordsToBytes platform size--                 -- convert offsets from Sp into offsets into the virtual stack-                 p' = Map.insertList-                        [ (arg, stack_bot - ByteOff offset)-                        | (NonVoid arg, offset) <- args_offsets ]-                        p_alts-             in do-             MASSERT(isAlgCase)-             rhs_code <- schemeE stack_bot s p' rhs-             return (my_discr alt,-                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)-           where-             real_bndrs = filterOut isTyVar bndrs--        my_discr (AnnAlt DEFAULT _ _) = NoDiscr {-shouldn't really happen-}-        my_discr (AnnAlt (DataAlt dc) _ _)-           | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc-           = multiValException-           | otherwise-           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))-        my_discr (AnnAlt (LitAlt l) _ _)-           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)-                       LitNumber LitNumWord w -> DiscrW (fromInteger w)-                       LitFloat r   -> DiscrF (fromRational r)-                       LitDouble r  -> DiscrD (fromRational r)-                       LitChar i    -> DiscrI (ord i)-                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)--        maybe_ncons-           | not isAlgCase = Nothing-           | otherwise-           = case [dc | AnnAlt (DataAlt dc) _ _ <- alts] of-                []     -> Nothing-                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))--        -- the bitmap is relative to stack depth d, i.e. before the-        -- BCO, info table and return value are pushed on.-        -- This bit of code is v. similar to buildLivenessMask in CgBindery,-        -- except that here we build the bitmap from the known bindings of-        -- things that are pointers, whereas in CgBindery the code builds the-        -- bitmap from the free slots and unboxed bindings.-        -- (ToDo: merge?)-        ---        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.-        -- The bitmap must cover the portion of the stack up to the sequel only.-        -- Previously we were building a bitmap for the whole depth (d), but we-        -- really want a bitmap up to depth (d-s).  This affects compilation of-        -- case-of-case expressions, which is the only time we can be compiling a-        -- case expression with s /= 0.-        bitmap_size = trunc16W $ bytesToWords platform (d - s)-        bitmap_size' :: Int-        bitmap_size' = fromIntegral bitmap_size-        bitmap = intsToReverseBitmap platform bitmap_size'{-size-}-                        (sort (filter (< bitmap_size') rel_slots))-          where-          binds = Map.toList p-          -- 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 platform id) = [ rel_offset ]-                              | otherwise                                = []-                where rel_offset = trunc16W $ bytesToWords platform (d - offset)--     alt_stuff <- mapM codeAlt alts-     alt_final <- mkMultiBranch maybe_ncons alt_stuff--     let-         alt_bco_name = getName bndr-         alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)-                       0{-no arity-} bitmap_size bitmap True{-is alts-}---     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++---            "\n      bitmap = " ++ show bitmap) $ do--     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)-                           (d + ret_frame_size_b + save_ccs_size_b)-                           p scrut-     alt_bco' <- emitBc alt_bco-     let push_alts-            | isAlgCase = PUSH_ALTS alt_bco'-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)-     return (push_alts `consOL` scrut_code)----- -------------------------------------------------------------------------------- Deal with a CCall.---- Taggedly push the args onto the stack R->L,--- deferencing ForeignObj#s and adjusting addrs to point to--- payloads in Ptr/Byte arrays.  Then, generate the marshalling--- (machine) code for the ccall, and create bytecodes to call that and--- then return in the right way.--generateCCall-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> CCallSpec               -- where to call-    -> Id                      -- of target, for type info-    -> [AnnExpr' Id DVarSet]   -- args (atoms)-    -> BcM BCInstrList-generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l- = do-     profile <- getProfile--     let-         platform = profilePlatform profile-         -- useful constants-         addr_size_b :: ByteOff-         addr_size_b = wordSize platform--         -- Get the args on the stack, with tags and suitably-         -- dereferenced for the CCall.  For each arg, return the-         -- depth to the first word of the bits for that arg, and the-         -- ArgRep of what was actually pushed.--         pargs-             :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]-         pargs _ [] = return []-         pargs d (a:az)-            = let arg_ty = unwrapType (exprType (deAnnotate' a))--              in case tyConAppTyCon_maybe arg_ty of-                    -- Don't push the FO; instead push the Addr# it-                    -- contains.-                    Just t-                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize profile)) d p a-                             return ((code,AddrRep):rest)--                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize profile)) d p a-                             return ((code,AddrRep):rest)--                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize profile)) d p a-                             return ((code,AddrRep):rest)--                    -- Default case: push taggedly, but otherwise intact.-                    _-                       -> do (code_a, sz_a) <- pushAtom d p a-                             rest <- pargs (d + sz_a) az-                             return ((code_a, atomPrimRep a) : rest)--         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on-         -- the stack but then advance it over the headers, so as to-         -- point to the payload.-         parg_ArrayishRep-             :: Word16-             -> StackDepth-             -> BCEnv-             -> AnnExpr' Id DVarSet-             -> BcM BCInstrList-         parg_ArrayishRep hdrSize d p a-            = do (push_fo, _) <- pushAtom d p a-                 -- The ptr points at the header.  Advance it over the-                 -- header and then pretend this is an Addr#.-                 return (push_fo `snocOL` SWIZZLE 0 hdrSize)--     code_n_reps <- pargs d0 args_r_to_l-     let-         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps-         a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)--         push_args    = concatOL pushs_arg-         !d_after_args = d0 + wordsToBytes platform a_reps_sizeW-         a_reps_pushed_RAW-            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))-            = panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?"-            | otherwise-            = reverse (tail a_reps_pushed_r_to_l)--         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.-         -- push_args is the code to do that.-         -- d_after_args is the stack depth once the args are on.--         -- Get the result rep.-         (returns_void, r_rep)-            = case maybe_getCCallReturnRep (idType fn) of-                 Nothing -> (True,  VoidRep)-                 Just rr -> (False, rr)-         {--         Because the Haskell stack grows down, the a_reps refer to-         lowest to highest addresses in that order.  The args for the call-         are on the stack.  Now push an unboxed Addr# indicating-         the C function to call.  Then push a dummy placeholder for the-         result.  Finally, emit a CCALL insn with an offset pointing to the-         Addr# just pushed, and a literal field holding the mallocville-         address of the piece of marshalling code we generate.-         So, just prior to the CCALL insn, the stack looks like this-         (growing down, as usual):--            <arg_n>-            ...-            <arg_1>-            Addr# address_of_C_fn-            <placeholder-for-result#> (must be an unboxed type)--         The interpreter then calls the marshall code mentioned-         in the CCALL insn, passing it (& <placeholder-for-result#>),-         that is, the addr of the topmost word in the stack.-         When this returns, the placeholder will have been-         filled in.  The placeholder is slid down to the sequel-         depth, and we RETURN.--         This arrangement makes it simple to do f-i-dynamic since the Addr#-         value is the first arg anyway.--         The marshalling code is generated specifically for this-         call site, and so knows exactly the (Haskell) stack-         offsets of the args, fn address and placeholder.  It-         copies the args to the C stack, calls the stacked addr,-         and parks the result back in the placeholder.  The interpreter-         calls it as a normal C call, assuming it has a signature-            void marshall_code ( StgWord* ptr_to_top_of_stack )-         -}-         -- resolve static address-         maybe_static_target :: Maybe Literal-         maybe_static_target =-             case target of-                 DynamicTarget -> Nothing-                 StaticTarget _ _ _ False ->-                   panic "generateCCall: unexpected FFI value import"-                 StaticTarget _ target _ True ->-                   Just (LitLabel target mb_size IsFunction)-                   where-                      mb_size-                          | OSMinGW32 <- platformOS platform-                          , StdCallConv <- cconv-                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)-                          | otherwise-                          = Nothing--     let-         is_static = isJust maybe_static_target--         -- Get the arg reps, zapping the leading Addr# in the dynamic case-         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"-                | is_static = a_reps_pushed_RAW-                | otherwise = if null a_reps_pushed_RAW-                              then panic "GHC.CoreToByteCode.generateCCall: dyn with no args"-                              else tail a_reps_pushed_RAW--         -- push the Addr#-         (push_Addr, d_after_Addr)-            | Just machlabel <- maybe_static_target-            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)-            | otherwise -- is already on the stack-            = (nilOL, d_after_args)--         -- Push the return placeholder.  For a call returning nothing,-         -- this is a V (tag).-         r_sizeW   = repSizeWords platform r_rep-         d_after_r = d_after_Addr + wordsToBytes platform r_sizeW-         push_r =-             if returns_void-                then nilOL-                else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))--         -- generate the marshalling code we're going to call--         -- Offset of the next stack frame down the stack.  The CCALL-         -- instruction needs to describe the chunk of stack containing-         -- the ccall args to the GC, so it needs to know how large it-         -- is.  See comment in Interpreter.c with the CCALL instruction.-         stk_offset   = trunc16W $ bytesToWords platform (d_after_r - s)--         conv = case cconv of-           CCallConv -> FFICCall-           StdCallConv -> FFIStdCall-           _ -> panic "GHC.CoreToByteCode: unexpected calling convention"--     -- the only difference in libffi mode is that we prepare a cif-     -- describing the call type by calling libffi, and we attach the-     -- address of this to the CCALL instruction.---     let ffires = primRepToFFIType platform r_rep-         ffiargs = map (primRepToFFIType platform) a_reps-     hsc_env <- getHscEnv-     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)-     recordFFIBc token--     let-         -- do the call-         do_call      = unitOL (CCALL stk_offset token flags)-           where flags = case safety of-                           PlaySafe          -> 0x0-                           PlayInterruptible -> 0x1-                           PlayRisky         -> 0x2--         -- 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 platform r_rep)-         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $-     return (-         push_args `appOL`-         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup-         )--primRepToFFIType :: Platform -> PrimRep -> FFIType-primRepToFFIType platform r-  = case r of-     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-     FloatRep    -> FFIFloat-     DoubleRep   -> FFIDouble-     _           -> panic "primRepToFFIType"-  where-    (signed_word, unsigned_word) = case platformWordSize platform of-       PW4 -> (FFISInt32, FFIUInt32)-       PW8 -> (FFISInt64, FFIUInt64)---- Make a dummy literal, to be used as a placeholder for FFI return--- values on the stack.-mkDummyLiteral :: Platform -> PrimRep -> Literal-mkDummyLiteral platform pr-   = 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-        DoubleRep -> LitDouble 0-        FloatRep  -> LitFloat 0-        _         -> pprPanic "mkDummyLiteral" (ppr pr)----- Convert (eg)---     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld---                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)------ to  Just IntRep--- and check that an unboxed pair is returned wherein the first arg is V'd.------ Alternatively, for call-targets returning nothing, convert------     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld---                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)------ to  Nothing--maybe_getCCallReturnRep :: Type -> Maybe PrimRep-maybe_getCCallReturnRep fn_ty-   = let-       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)-       r_reps = typePrimRepArgs r_ty--       blargh :: a -- Used at more than one type-       blargh = pprPanic "maybe_getCCallReturn: can't handle:"-                         (pprType fn_ty)-     in-       case r_reps of-         []            -> panic "empty typePrimRepArgs"-         [VoidRep]     -> Nothing-         [rep]-           | isGcPtrRep rep -> blargh-           | otherwise      -> Just rep--                 -- if it was, it would be impossible to create a-                 -- valid return value placeholder on the stack-         _             -> blargh--maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])--- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call app-  | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app-  , Just TagToEnumOp <- isPrimOpId_maybe v-  = Just (snd arg, extract_constr_Names t)-  | otherwise-  = Nothing-  where-    extract_constr_Names ty-           | rep_ty <- unwrapType ty-           , Just tyc <- tyConAppTyCon_maybe rep_ty-           , isDataTyCon tyc-           = map (getName . dataConWorkId) (tyConDataCons tyc)-           -- NOTE: use the worker name, not the source name of-           -- the DataCon.  See "GHC.Core.DataCon" for details.-           | otherwise-           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)--{- ------------------------------------------------------------------------------Note [Implementing tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(implement_tagToId arg names) compiles code which takes an argument-'arg', (call it i), and enters the i'th closure in the supplied list-as a consequence.  The [Name] is a list of the constructors of this-(enumeration) type.--The code we generate is this:-                push arg-                push bogus-word--                TESTEQ_I 0 L1-                  PUSH_G <lbl for first data con>-                  JMP L_Exit--        L1:     TESTEQ_I 1 L2-                  PUSH_G <lbl for second data con>-                  JMP L_Exit-        ...etc...-        Ln:     TESTEQ_I n L_fail-                  PUSH_G <lbl for last data con>-                  JMP L_Exit--        L_fail: CASEFAIL--        L_exit: SLIDE 1 n-                ENTER--The 'bogus-word' push is because TESTEQ_I expects the top of the stack-to have an info-table, and the next word to have the value to be-tested.  This is very weird, but it's the way it is right now.  See-Interpreter.c.  We don't actually need an info-table here; we just-need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See #8383.--}---implement_tagToId-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr' Id DVarSet-    -> [Name]-    -> BcM BCInstrList--- See Note [Implementing tagToEnum#]-implement_tagToId d s p arg names-  = ASSERT( notNull names )-    do (push_arg, arg_bytes) <- pushAtom d p arg-       labels <- getLabelsBc (genericLength names)-       label_fail <- getLabelBc-       label_exit <- getLabelBc-       dflags <- getDynFlags-       let infos = zip4 labels (tail labels ++ [label_fail])-                               [0 ..] names-           platform = targetPlatform dflags-           steps = map (mkStep label_exit) infos-           slide_ws = bytesToWords platform (d - s + arg_bytes)--       return (push_arg-               `appOL` unitOL (PUSH_UBX LitNullAddr 1)-                   -- Push bogus word (see Note [Implementing tagToEnum#])-               `appOL` concatOL steps-               `appOL` toOL [ LABEL label_fail, CASEFAIL,-                              LABEL label_exit ]-               `appOL` mkSlideW 1 (slide_ws + 1)-                   -- "+1" to account for bogus word-                   --      (see Note [Implementing tagToEnum#])-               `appOL` unitOL ENTER)-  where-        mkStep l_exit (my_label, next_label, n, name_for_n)-           = toOL [LABEL my_label,-                   TESTEQ_I n next_label,-                   PUSH_G name_for_n,-                   JMP l_exit]----- -------------------------------------------------------------------------------- pushAtom---- Push an atom onto the stack, returning suitable code & number of--- stack words used.------ The env p must map each variable to the highest- numbered stack--- slot for it.  For example, if the stack has depth 4 and we--- tagged-ly push (v :: Int#) on it, the value will be in stack[4],--- the tag in stack[5], the stack will have depth 6, and p must map v--- to 5 and not to 4.  Stack locations are numbered from zero, so a--- depth 6 stack has valid words 0 .. 5.--pushAtom-    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)-pushAtom d p e-   | Just e' <- bcView e-   = pushAtom d p e'--pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,-   = return (nilOL, 0)          -- treated just like a variable V---- See Note [Empty case alternatives] in GHC.Core--- and Note [Bottoming expressions] in GHC.Core.Utils:--- The scrutinee of an empty case evaluates to bottom-pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128-   = pushAtom d p a--pushAtom d p (AnnVar var)-   | [] <- typePrimRep (idType var)-   = return (nilOL, 0)--   | isFCallId var-   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)--   | Just primop <- isPrimOpId_maybe var-   = do-       platform <- targetPlatform <$> getDynFlags-       return (unitOL (PUSH_PRIMOP primop), wordSize platform)--   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable-   = do platform <- targetPlatform <$> getDynFlags--        let !szb = idSizeCon platform var-            with_instr instr = do-                let !off_b = trunc16B $ d - d_v-                return (unitOL (instr off_b), wordSize platform)--        case szb of-            1 -> with_instr PUSH8_W-            2 -> with_instr PUSH16_W-            4 -> with_instr PUSH32_W-            _ -> do-                let !szw = bytesToWords platform szb-                    !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1-                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)-        -- d - d_v           offset from TOS to the first slot of the object-        ---        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object-        ---        -- Having found the last slot, we proceed to copy the right number of-        -- slots on to the top of the stack.--   | otherwise  -- var must be a global variable-   = do topStrings <- getTopStrings-        platform <- targetPlatform <$> getDynFlags-        case lookupVarEnv topStrings var of-            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $-              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr-            Nothing -> do-                let sz = idSizeCon platform var-                MASSERT( sz == wordSize platform )-                return (unitOL (PUSH_G (getName var)), sz)---pushAtom _ _ (AnnLit lit) = do-     platform <- targetPlatform <$> getDynFlags-     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 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 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.-          LitNumInteger -> panic "pushAtom: LitInteger"-          LitNumNatural -> panic "pushAtom: LitNatural"--pushAtom _ _ expr-   = pprPanic "GHC.CoreToByteCode.pushAtom"-              (pprCoreExpr (deAnnotate' expr))----- | Push an atom for constructor (i.e., PACK instruction) onto the stack.--- This is slightly different to @pushAtom@ due to the fact that we allow--- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.-pushConstrAtom-    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)--pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =-    return (unitOL (PUSH_UBX32 lit), 4)--pushConstrAtom d p (AnnVar v)-    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable-        platform <- targetPlatform <$> getDynFlags-        let !szb = idSizeCon platform v-            done instr = do-                let !off = trunc16B $ d - d_v-                return (unitOL (instr off), szb)-        case szb of-            1 -> done PUSH8-            2 -> done PUSH16-            4 -> done PUSH32-            _ -> pushAtom d p (AnnVar v)--pushConstrAtom d p expr = pushAtom d p expr--pushPadding :: Int -> (BCInstrList, ByteOff)-pushPadding !n = go n (nilOL, 0)-  where-    go n acc@(!instrs, !off) = case n of-        0 -> acc-        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)-        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)-        3 -> go 1 (go 2 acc)-        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)-        _ -> go (n - 4) (go 4 acc)---- -------------------------------------------------------------------------------- Given a bunch of alts code and their discrs, do the donkey work--- of making a multiway branch using a switch tree.--- What a load of hassle!--mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt-                                -- a hint; generates better code-                                -- Nothing is always safe-              -> [(Discr, BCInstrList)]-              -> BcM BCInstrList-mkMultiBranch maybe_ncons raw_ways = do-     lbl_default <- getLabelBc--     let-         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList-         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))-             -- shouldn't happen?--         mkTree [val] range_lo range_hi-            | range_lo == range_hi-            = return (snd val)-            | null defaults -- Note [CASEFAIL]-            = do lbl <- getLabelBc-                 return (testEQ (fst val) lbl-                            `consOL` (snd val-                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))-            | otherwise-            = return (testEQ (fst val) lbl_default `consOL` snd val)--            -- Note [CASEFAIL] It may be that this case has no default-            -- branch, but the alternatives are not exhaustive - this-            -- happens for GADT cases for example, where the types-            -- prove that certain branches are impossible.  We could-            -- just assume that the other cases won't occur, but if-            -- this assumption was wrong (because of a bug in GHC)-            -- then the result would be a segfault.  So instead we-            -- emit an explicit test and a CASEFAIL instruction that-            -- causes the interpreter to barf() if it is ever-            -- executed.--         mkTree vals range_lo range_hi-            = let n = length vals `div` 2-                  vals_lo = take n vals-                  vals_hi = drop n vals-                  v_mid = fst (head vals_hi)-              in do-              label_geq <- getLabelBc-              code_lo <- mkTree vals_lo range_lo (dec v_mid)-              code_hi <- mkTree vals_hi v_mid range_hi-              return (testLT v_mid label_geq-                      `consOL` (code_lo-                      `appOL`   unitOL (LABEL label_geq)-                      `appOL`   code_hi))--         the_default-            = case defaults of-                []         -> nilOL-                [(_, def)] -> LABEL lbl_default `consOL` def-                _          -> panic "mkMultiBranch/the_default"-     instrs <- mkTree notd_ways init_lo init_hi-     return (instrs `appOL` the_default)-  where-         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways-         notd_ways = sortBy (comparing fst) not_defaults--         testLT (DiscrI i) fail_label = TESTLT_I i fail_label-         testLT (DiscrW i) fail_label = TESTLT_W i fail_label-         testLT (DiscrF i) fail_label = TESTLT_F i fail_label-         testLT (DiscrD i) fail_label = TESTLT_D i fail_label-         testLT (DiscrP i) fail_label = TESTLT_P i fail_label-         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"--         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label-         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label-         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label-         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label-         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label-         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"--         -- None of these will be needed if there are no non-default alts-         (init_lo, init_hi)-            | null notd_ways-            = panic "mkMultiBranch: awesome foursome"-            | otherwise-            = case fst (head notd_ways) of-                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )-                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )-                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )-                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )-                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )-                NoDiscr -> panic "mkMultiBranch NoDiscr"--         (algMinBound, algMaxBound)-            = case maybe_ncons of-                 -- XXX What happens when n == 0?-                 Just n  -> (0, fromIntegral n - 1)-                 Nothing -> (minBound, maxBound)--         isNoDiscr NoDiscr = True-         isNoDiscr _       = False--         dec (DiscrI i) = DiscrI (i-1)-         dec (DiscrW w) = DiscrW (w-1)-         dec (DiscrP i) = DiscrP (i-1)-         dec other      = other         -- not really right, but if you-                -- do cases on floating values, you'll get what you deserve--         -- same snotty comment applies to the following-         minF, maxF :: Float-         minD, maxD :: Double-         minF = -1.0e37-         maxF =  1.0e37-         minD = -1.0e308-         maxD =  1.0e308----- -------------------------------------------------------------------------------- Supporting junk for the compilation schemes---- Describes case alts-data Discr-   = DiscrI Int-   | DiscrW Word-   | DiscrF Float-   | DiscrD Double-   | DiscrP Word16-   | NoDiscr-    deriving (Eq, Ord)--instance Outputable Discr where-   ppr (DiscrI i) = int i-   ppr (DiscrW w) = text (show w)-   ppr (DiscrF f) = text (show f)-   ppr (DiscrD d) = text (show d)-   ppr (DiscrP i) = ppr i-   ppr NoDiscr    = text "DEF"---lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff-lookupBCEnv_maybe = Map.lookup--idSizeW :: Platform -> Id -> WordOff-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform--idSizeCon :: Platform -> Id -> ByteOff-idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep--bcIdArgRep :: Platform -> Id -> ArgRep-bcIdArgRep platform = toArgRep platform . bcIdPrimRep--bcIdPrimRep :: Id -> PrimRep-bcIdPrimRep id-  | [rep] <- typePrimRepArgs (idType id)-  = rep-  | otherwise-  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))--repSizeWords :: Platform -> PrimRep -> WordOff-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)--isFollowableArg :: ArgRep -> Bool-isFollowableArg P = True-isFollowableArg _ = False--isVoidArg :: ArgRep -> Bool-isVoidArg V = True-isVoidArg _ = False---- See bug #1257-multiValException :: a-multiValException = throwGhcException (ProgramError-  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++-   "  Possibly due to foreign import/export decls in source.\n"++-   "  Workaround: use -fobject-code, or compile this module to .o separately."))---- | Indicate if the calling convention is supported-isSupportedCConv :: CCallSpec -> Bool-isSupportedCConv (CCallSpec _ cconv _) = case cconv of-   CCallConv            -> True     -- we explicitly pattern match on every-   StdCallConv          -> True     -- convention to ensure that a warning-   PrimCallConv         -> False    -- is triggered when a new one is added-   JavaScriptCallConv   -> False-   CApiConv             -> False---- See bug #10462-unsupportedCConvException :: a-unsupportedCConvException = throwGhcException (ProgramError-  ("Error: bytecode compiler can't handle some foreign calling conventions\n"++-   "  Workaround: use -fobject-code, or compile this module to .o separately."))--mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr-mkSlideB platform !nb !db = mkSlideW n d-  where-    !n = trunc16W $ bytesToWords platform nb-    !d = bytesToWords platform db--mkSlideW :: Word16 -> WordOff -> OrdList BCInstr-mkSlideW !n !ws-    | ws > fromIntegral limit-    -- If the amount to slide doesn't fit in a Word16, generate multiple slide-    -- instructions-    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)-    | ws == 0-    = nilOL-    | otherwise-    = unitOL (SLIDE n $ fromIntegral ws)-  where-    limit :: Word16-    limit = maxBound--splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])-        -- The arguments are returned in *right-to-left* order-splitApp e | Just e' <- bcView e = splitApp e'-splitApp (AnnApp (_,f) (_,a))    = case splitApp f of-                                      (f', as) -> (f', a:as)-splitApp e                       = (e, [])---bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)--- The "bytecode view" of a term discards---  a) type abstractions---  b) type applications---  c) casts---  d) ticks (but not breakpoints)---  e) case unsafeEqualityProof of UnsafeRefl -> e  ==> e--- Type lambdas *can* occur in random expressions,--- whereas value lambdas cannot; that is why they are nuked here-bcView (AnnCast (_,e) _)             = Just e-bcView (AnnLam v (_,e)) | isTyVar v  = Just e-bcView (AnnApp (_,e) (_, AnnType _)) = Just e-bcView (AnnTick Breakpoint{} _)      = Nothing-bcView (AnnTick _other_tick (_,e))   = Just e-bcView (AnnCase (_,e) _ _ alts)  -- Handle unsafe equality proof-  | AnnVar id <- bcViewLoop e-  , idName id == unsafeEqualityProofName-  , [AnnAlt _ _ (_, rhs)] <- alts-  = Just rhs-bcView _                             = Nothing--bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann-bcViewLoop e =-    case bcView e of-      Nothing -> e-      Just e' -> bcViewLoop e'--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'-atomPrimRep (AnnVar v)              = bcIdPrimRep v-atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)---- #12128:--- A case expression can be an atom because empty cases evaluate to bottom.--- See Note [Empty case alternatives] in GHC.Core-atomPrimRep (AnnCase _ _ ty _)      =-  ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep-atomPrimRep (AnnCoercion {})        = VoidRep-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))--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--- environment should map these items to.-mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]-mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)--typeArgRep :: Platform -> Type -> ArgRep-typeArgRep platform = toArgRep platform . typePrimRep1---- -------------------------------------------------------------------------------- The bytecode generator's monad--data BcM_State-   = BcM_State-        { bcm_hsc_env :: HscEnv-        , uniqSupply  :: UniqSupply      -- for generating fresh variable names-        , thisModule  :: Module          -- current module (for breakpoints)-        , nextlabel   :: Word32          -- for generating local labels-        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later-                                         -- Should be free()d when it is GCd-        , modBreaks   :: Maybe ModBreaks -- info about breakpoints-        , breakInfo   :: IntMap CgBreakInfo-        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals-          -- See Note [generating code for top-level string literal bindings].-        }--newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)--ioToBc :: IO a -> BcM a-ioToBc io = BcM $ \st -> do-  x <- io-  return (st, x)--runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks-      -> IdEnv (RemotePtr ())-      -> BcM r-      -> IO (BcM_State, r)-runBc hsc_env us this_mod modBreaks topStrings (BcM m)-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)--thenBc :: BcM a -> (a -> BcM b) -> BcM b-thenBc (BcM expr) cont = BcM $ \st0 -> do-  (st1, q) <- expr st0-  let BcM k = cont q-  (st2, r) <- k st1-  return (st2, r)--thenBc_ :: BcM a -> BcM b -> BcM b-thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do-  (st1, _) <- expr st0-  (st2, r) <- cont st1-  return (st2, r)--returnBc :: a -> BcM a-returnBc result = BcM $ \st -> (return (st, result))--instance Applicative BcM where-    pure = returnBc-    (<*>) = ap-    (*>) = thenBc_--instance Monad BcM where-  (>>=) = thenBc-  (>>)  = (*>)--instance HasDynFlags BcM where-    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))--getHscEnv :: BcM HscEnv-getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)--getProfile :: BcM Profile-getProfile = targetProfile <$> getDynFlags--emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)-emitBc bco-  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))--recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()-recordFFIBc a-  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())--getLabelBc :: BcM LocalLabel-getLabelBc-  = BcM $ \st -> do let nl = nextlabel st-                    when (nl == maxBound) $-                        panic "getLabelBc: Ran out of labels"-                    return (st{nextlabel = nl + 1}, LocalLabel nl)--getLabelsBc :: Word32 -> BcM [LocalLabel]-getLabelsBc n-  = BcM $ \st -> let ctr = nextlabel st-                 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])--getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))-getCCArray = BcM $ \st ->-  let breaks = expectJust "GHC.CoreToByteCode.getCCArray" $ modBreaks st in-  return (st, modBreaks_ccs breaks)---newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()-newBreakInfo ix info = BcM $ \st ->-  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())--newUnique :: BcM Unique-newUnique = BcM $-   \st -> case takeUniqFromSupply (uniqSupply st) of-             (uniq, us) -> let newState = st { uniqSupply = us }-                           in  return (newState, uniq)--getCurrentModule :: BcM Module-getCurrentModule = BcM $ \st -> return (st, thisModule st)--getTopStrings :: BcM (IdEnv (RemotePtr ()))-getTopStrings = BcM $ \st -> return (st, topStrings st)--newId :: Type -> BcM Id-newId ty = do-    uniq <- newUnique-    return $ mkSysLocal tickFS uniq Many ty--tickFS :: FastString-tickFS = fsLit "ticked"