ghc-lib 0.20200801 → 0.20200901
raw patch · 240 files changed
+4241/−3400 lines, 240 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +20/−14
- compiler/GHC/Builtin/Names/TH.hs +1/−0
- compiler/GHC/Builtin/Utils.hs +1/−3
- compiler/GHC/ByteCode/Asm.hs +1/−0
- compiler/GHC/Cmm/CallConv.hs +1/−0
- compiler/GHC/Cmm/CommonBlockElim.hs +1/−0
- compiler/GHC/Cmm/DebugBlock.hs +4/−0
- compiler/GHC/Cmm/Info/Build.hs +3/−2
- compiler/GHC/Cmm/LayoutStack.hs +1/−0
- compiler/GHC/Cmm/Lint.hs +35/−5
- compiler/GHC/Cmm/Liveness.hs +1/−0
- compiler/GHC/Cmm/Opt.hs +1/−1
- compiler/GHC/Cmm/Parser.y +3/−1
- compiler/GHC/Cmm/Ppr/Decl.hs +1/−0
- compiler/GHC/Cmm/Ppr/Expr.hs +3/−1
- compiler/GHC/Cmm/ProcPoint.hs +1/−0
- compiler/GHC/Cmm/Sink.hs +1/−0
- compiler/GHC/Cmm/Utils.hs +1/−0
- compiler/GHC/CmmToAsm.hs +171/−225
- compiler/GHC/CmmToAsm/BlockLayout.hs +30/−23
- compiler/GHC/CmmToAsm/CFG.hs +25/−26
- compiler/GHC/CmmToAsm/CFG/Dominators.hs +563/−597
- compiler/GHC/CmmToAsm/CPrim.hs +1/−0
- compiler/GHC/CmmToAsm/Dwarf.hs +16/−17
- compiler/GHC/CmmToAsm/Format.hs +1/−0
- compiler/GHC/CmmToAsm/Instr.hs +10/−57
- compiler/GHC/CmmToAsm/Monad.hs +15/−63
- compiler/GHC/CmmToAsm/PIC.hs +2/−1
- compiler/GHC/CmmToAsm/PPC.hs +61/−0
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +2/−1
- compiler/GHC/CmmToAsm/PPC/Instr.hs +59/−63
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +14/−21
- compiler/GHC/CmmToAsm/PPC/Regs.hs +1/−0
- compiler/GHC/CmmToAsm/Ppr.hs +5/−20
- compiler/GHC/CmmToAsm/Reg/Graph.hs +5/−4
- compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +1/−0
- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +1/−0
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +2/−0
- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +3/−2
- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +8/−5
- compiler/GHC/CmmToAsm/Reg/Linear.hs +11/−6
- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +7/−5
- compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +1/−0
- compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +1/−0
- compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +2/−1
- compiler/GHC/CmmToAsm/Reg/Liveness.hs +36/−10
- compiler/GHC/CmmToAsm/Reg/Target.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC.hs +75/−0
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +2/−2
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +3/−2
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +1/−2
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +2/−1
- compiler/GHC/CmmToAsm/SPARC/Imm.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC/Instr.hs +52/−61
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs +25/−2
- compiler/GHC/CmmToAsm/SPARC/Regs.hs +1/−0
- compiler/GHC/CmmToAsm/SPARC/Stack.hs +1/−0
- compiler/GHC/CmmToAsm/Types.hs +32/−0
- compiler/GHC/CmmToAsm/Utils.hs +33/−0
- compiler/GHC/CmmToAsm/X86.hs +65/−0
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +98/−12
- compiler/GHC/CmmToAsm/X86/Instr.hs +67/−61
- compiler/GHC/CmmToAsm/X86/Ppr.hs +17/−29
- compiler/GHC/CmmToAsm/X86/RegInfo.hs +1/−0
- compiler/GHC/CmmToAsm/X86/Regs.hs +1/−0
- compiler/GHC/CmmToC.hs +2/−0
- compiler/GHC/CmmToLlvm.hs +1/−0
- compiler/GHC/CmmToLlvm/Base.hs +1/−1
- compiler/GHC/CmmToLlvm/CodeGen.hs +9/−6
- compiler/GHC/CmmToLlvm/Data.hs +1/−1
- compiler/GHC/CmmToLlvm/Ppr.hs +2/−0
- compiler/GHC/CmmToLlvm/Regs.hs +1/−1
- compiler/GHC/Core/Opt/CSE.hs +1/−0
- compiler/GHC/Core/Opt/DmdAnal.hs +1/−0
- compiler/GHC/Core/Opt/Driver.hs +0/−1041
- compiler/GHC/Core/Opt/Exitify.hs +1/−1
- compiler/GHC/Core/Opt/FloatIn.hs +1/−1
- compiler/GHC/Core/Opt/FloatOut.hs +1/−0
- compiler/GHC/Core/Opt/Pipeline.hs +1046/−0
- compiler/GHC/Core/Opt/SetLevels.hs +3/−0
- compiler/GHC/Core/Opt/Simplify.hs +6/−2
- compiler/GHC/Core/Opt/Simplify/Env.hs +2/−0
- compiler/GHC/Core/Opt/Simplify/Monad.hs +1/−1
- compiler/GHC/Core/Opt/Simplify/Utils.hs +2/−0
- compiler/GHC/Core/Opt/SpecConstr.hs +2/−0
- compiler/GHC/Core/Opt/Specialise.hs +2/−0
- compiler/GHC/Core/Opt/StaticArgs.hs +1/−0
- compiler/GHC/Core/Opt/WorkWrap.hs +2/−0
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +1/−0
- compiler/GHC/Core/Ppr/TyThing.hs +1/−0
- compiler/GHC/Core/Rules.hs +2/−0
- compiler/GHC/CoreToByteCode.hs +1/−0
- compiler/GHC/CoreToStg.hs +2/−0
- compiler/GHC/CoreToStg/Prep.hs +98/−35
- compiler/GHC/Data/Graph/Color.hs +1/−0
- compiler/GHC/Data/Graph/Ops.hs +1/−0
- compiler/GHC/Driver/Backpack.hs +37/−31
- compiler/GHC/Driver/CodeOutput.hs +3/−18
- compiler/GHC/Driver/Finder.hs +30/−27
- compiler/GHC/Driver/Main.hs +33/−27
- compiler/GHC/Driver/Make.hs +9/−8
- compiler/GHC/Driver/MakeFile.hs +1/−0
- compiler/GHC/Driver/Pipeline.hs +74/−48
- compiler/GHC/Hs/Stats.hs +3/−1
- compiler/GHC/HsToCore.hs +10/−5
- compiler/GHC/HsToCore/Arrows.hs +1/−0
- compiler/GHC/HsToCore/Binds.hs +6/−5
- compiler/GHC/HsToCore/Coverage.hs +2/−0
- compiler/GHC/HsToCore/Expr.hs +9/−35
- compiler/GHC/HsToCore/Expr.hs-boot +2/−4
- compiler/GHC/HsToCore/Foreign/Call.hs +1/−0
- compiler/GHC/HsToCore/Foreign/Decl.hs +2/−0
- compiler/GHC/HsToCore/GuardedRHSs.hs +35/−30
- compiler/GHC/HsToCore/ListComp.hs +3/−2
- compiler/GHC/HsToCore/Match.hs +29/−29
- compiler/GHC/HsToCore/Match/Constructor.hs +2/−1
- compiler/GHC/HsToCore/Match/Literal.hs +1/−0
- compiler/GHC/HsToCore/Monad.hs +7/−2
- compiler/GHC/HsToCore/PmCheck.hs +225/−115
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +4/−2
- compiler/GHC/HsToCore/PmCheck/Ppr.hs +1/−0
- compiler/GHC/HsToCore/Quote.hs +4/−3
- compiler/GHC/HsToCore/Usage.hs +6/−5
- compiler/GHC/HsToCore/Utils.hs +30/−2
- compiler/GHC/Iface/Ext/Ast.hs +1/−1
- compiler/GHC/Iface/Ext/Binary.hs +1/−0
- compiler/GHC/Iface/Ext/Types.hs +1/−0
- compiler/GHC/Iface/Ext/Utils.hs +2/−1
- compiler/GHC/Iface/Load.hs +35/−24
- compiler/GHC/Iface/Make.hs +11/−7
- compiler/GHC/Iface/Recomp.hs +17/−11
- compiler/GHC/Iface/Recomp/Flags.hs +1/−1
- compiler/GHC/Iface/Rename.hs +3/−1
- compiler/GHC/Iface/Tidy.hs +6/−1
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs +1/−0
- compiler/GHC/Iface/UpdateIdInfos.hs +1/−0
- compiler/GHC/IfaceToCore.hs +1/−0
- compiler/GHC/Llvm/Ppr.hs +1/−0
- compiler/GHC/Llvm/Types.hs +1/−0
- compiler/GHC/Plugins.hs +4/−0
- compiler/GHC/Rename/Bind.hs +1/−0
- compiler/GHC/Rename/Env.hs +1/−0
- compiler/GHC/Rename/Expr.hs +1/−0
- compiler/GHC/Rename/Fixity.hs +1/−0
- compiler/GHC/Rename/HsType.hs +1/−0
- compiler/GHC/Rename/Module.hs +10/−45
- compiler/GHC/Rename/Names.hs +28/−5
- compiler/GHC/Rename/Pat.hs +1/−0
- compiler/GHC/Rename/Splice.hs +1/−0
- compiler/GHC/Rename/Unbound.hs +1/−0
- compiler/GHC/Rename/Utils.hs +1/−0
- compiler/GHC/Runtime/Debugger.hs +1/−0
- compiler/GHC/Runtime/Eval.hs +4/−3
- compiler/GHC/Runtime/Heap/Inspect.hs +2/−0
- compiler/GHC/Runtime/Interpreter.hs +3/−2
- compiler/GHC/Runtime/Linker.hs +5/−3
- compiler/GHC/Runtime/Loader.hs +1/−0
- compiler/GHC/Settings/IO.hs +5/−1
- compiler/GHC/Stg/CSE.hs +1/−0
- compiler/GHC/Stg/DepAnal.hs +1/−0
- compiler/GHC/Stg/FVs.hs +1/−0
- compiler/GHC/Stg/Lift.hs +1/−0
- compiler/GHC/Stg/Lift/Analysis.hs +1/−0
- compiler/GHC/Stg/Lift/Monad.hs +1/−0
- compiler/GHC/Stg/Pipeline.hs +3/−1
- compiler/GHC/Stg/Subst.hs +4/−0
- compiler/GHC/Stg/Unarise.hs +1/−0
- compiler/GHC/StgToCmm.hs +1/−0
- compiler/GHC/StgToCmm/Bind.hs +2/−0
- compiler/GHC/StgToCmm/CgUtils.hs +1/−1
- compiler/GHC/StgToCmm/Closure.hs +1/−0
- compiler/GHC/StgToCmm/DataCon.hs +1/−1
- compiler/GHC/StgToCmm/Env.hs +7/−3
- compiler/GHC/StgToCmm/Expr.hs +1/−0
- compiler/GHC/StgToCmm/Foreign.hs +2/−2
- compiler/GHC/StgToCmm/Layout.hs +4/−1
- compiler/GHC/StgToCmm/Monad.hs +1/−0
- compiler/GHC/StgToCmm/Prim.hs +10/−13
- compiler/GHC/StgToCmm/Prof.hs +4/−1
- compiler/GHC/StgToCmm/Ticky.hs +2/−0
- compiler/GHC/StgToCmm/Utils.hs +2/−1
- compiler/GHC/SysTools.hs +18/−5
- compiler/GHC/SysTools/ExtraObj.hs +5/−1
- compiler/GHC/SysTools/Process.hs +18/−3
- compiler/GHC/SysTools/Tasks.hs +15/−0
- compiler/GHC/Tc/Deriv.hs +1/−0
- compiler/GHC/Tc/Deriv/Functor.hs +1/−1
- compiler/GHC/Tc/Deriv/Generate.hs +1/−0
- compiler/GHC/Tc/Deriv/Generics.hs +1/−0
- compiler/GHC/Tc/Deriv/Infer.hs +1/−0
- compiler/GHC/Tc/Deriv/Utils.hs +1/−0
- compiler/GHC/Tc/Errors.hs +2/−0
- compiler/GHC/Tc/Errors/Hole.hs +4/−0
- compiler/GHC/Tc/Gen/Arrow.hs +1/−0
- compiler/GHC/Tc/Gen/Bind.hs +100/−27
- compiler/GHC/Tc/Gen/Default.hs +1/−0
- compiler/GHC/Tc/Gen/Export.hs +1/−0
- compiler/GHC/Tc/Gen/Expr.hs +1/−0
- compiler/GHC/Tc/Gen/Foreign.hs +1/−0
- compiler/GHC/Tc/Gen/HsType.hs +3/−0
- compiler/GHC/Tc/Gen/Match.hs +10/−2
- compiler/GHC/Tc/Gen/Match.hs-boot +2/−2
- compiler/GHC/Tc/Gen/Pat.hs +1/−0
- compiler/GHC/Tc/Gen/Rule.hs +1/−0
- compiler/GHC/Tc/Gen/Sig.hs +9/−3
- compiler/GHC/Tc/Instance/Class.hs +1/−0
- compiler/GHC/Tc/Instance/FunDeps.hs +4/−2
- compiler/GHC/Tc/Instance/Typeable.hs +1/−0
- compiler/GHC/Tc/Module.hs +9/−8
- compiler/GHC/Tc/Solver.hs +1/−0
- compiler/GHC/Tc/Solver/Canonical.hs +1/−0
- compiler/GHC/Tc/Solver/Flatten.hs +1/−0
- compiler/GHC/Tc/Solver/Interact.hs +1/−0
- compiler/GHC/Tc/Solver/Monad.hs +1/−0
- compiler/GHC/Tc/TyCl.hs +29/−16
- compiler/GHC/Tc/TyCl/Build.hs +1/−0
- compiler/GHC/Tc/TyCl/Class.hs +1/−0
- compiler/GHC/Tc/TyCl/Instance.hs +2/−0
- compiler/GHC/Tc/TyCl/PatSyn.hs +1/−1
- compiler/GHC/Tc/TyCl/Utils.hs +2/−1
- compiler/GHC/Tc/Utils/Backpack.hs +37/−36
- compiler/GHC/Tc/Utils/Env.hs +4/−1
- compiler/GHC/Tc/Utils/Instantiate.hs +6/−3
- compiler/GHC/Tc/Utils/Monad.hs +18/−7
- compiler/GHC/Tc/Utils/TcMType.hs +2/−0
- compiler/GHC/Tc/Utils/Unify.hs +1/−0
- compiler/GHC/Tc/Utils/Zonk.hs +7/−8
- compiler/GHC/Tc/Validity.hs +2/−1
- compiler/GHC/ThToHs.hs +1/−8
- compiler/GHC/Types/Name/Shape.hs +1/−0
- ghc-lib.cabal +15/−4
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +5/−2
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +289/−289
- ghc-lib/stage0/lib/ghcversion.h +2/−2
- ghc-lib/stage0/lib/llvm-targets +3/−0
- ghc-lib/stage0/lib/settings +2/−0
- includes/stg/MachRegs.h +2/−0
compiler/GHC.hs view
@@ -248,7 +248,7 @@ srcSpanStartCol, srcSpanEndCol, -- ** Located- GenLocated(..), Located,+ GenLocated(..), Located, RealLocated, -- *** Constructing Located noLoc, mkGeneralLocated,@@ -274,7 +274,7 @@ parser, -- * API Annotations- ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),+ ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey, getAnnotation, getAndRemoveAnnotation, getAnnotationComments, getAndRemoveAnnotationComments, unicodeAnn,@@ -312,7 +312,7 @@ import GHC.Iface.Load ( loadSysInterface ) import GHC.Tc.Types import GHC.Core.Predicate-import GHC.Unit.State+import GHC.Unit import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs@@ -338,10 +338,10 @@ import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Platform.Ways+import GHC.Driver.Ppr import GHC.SysTools import GHC.SysTools.BaseDir import GHC.Types.Annotations-import GHC.Unit.Module import GHC.Utils.Panic import GHC.Platform import GHC.Data.Bag ( listToBag )@@ -1164,8 +1164,12 @@ return $ ic_instances (hsc_IC hsc_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified-getPrintUnqual = withSession $ \hsc_env ->- return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))+getPrintUnqual = withSession $ \hsc_env -> do+ let dflags = hsc_dflags hsc_env+ return $ icPrintUnqual+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo {@@ -1260,7 +1264,11 @@ ModuleInfo -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do- return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))+ let dflags = hsc_dflags hsc_env+ mk_print_unqual = mkPrintUnqualified+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ return (fmap mk_print_unqual (minf_rdr_env minf)) modInfoLookupName :: GhcMonad m => ModuleInfo -> Name@@ -1493,12 +1501,10 @@ -- 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- this_pkg = homeUnit dflags- --+ let dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags case maybe_pkg of- Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do+ Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m@@ -1510,7 +1516,7 @@ Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of- Found loc m | moduleUnit m /= this_pkg -> return m+ Found loc m | not (isHomeModule home_unit m) -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1676,7 +1682,7 @@ return dflags Just envfile -> do content <- readFile envfile- compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)+ compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile) let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags return dflags'
compiler/GHC/Builtin/Names/TH.hs view
@@ -14,6 +14,7 @@ import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Data.FastString -- To add a name, do three things
compiler/GHC/Builtin/Utils.hs view
@@ -72,6 +72,7 @@ import GHC.Core.TyCon import GHC.Types.Unique.FM import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Hs.Doc @@ -256,9 +257,6 @@ Export lists for pseudo-modules (GHC.Prim) * * ************************************************************************--GHC.Prim "exports" all the primops and primitive types, some-wired-in Ids. -} ghcPrimExports :: [IfaceExport]
compiler/GHC/ByteCode/Asm.hs view
@@ -33,6 +33,7 @@ import GHC.Runtime.Heap.Layout import GHC.Driver.Session import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Misc import GHC.Types.Unique
compiler/GHC/Cmm/CallConv.hs view
@@ -16,6 +16,7 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Utils.Outputable+import GHC.Utils.Panic -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention.
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -24,6 +24,7 @@ import Data.Word import qualified Data.Map as M import GHC.Utils.Outputable+import GHC.Utils.Panic import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique
compiler/GHC/Cmm/DebugBlock.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} @@ -36,6 +37,7 @@ 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.Utils.Misc ( seqList )@@ -109,7 +111,9 @@ -- recover by copying ticks below. scp' | SubScope _ scp' <- scp = scp' | CombinedScope scp' _ <- scp = scp'+#if __GLASGOW_HASKELL__ <= 810 | otherwise = panic "findP impossible"+#endif scopeMap = foldr (uncurry insertMulti) Map.empty childScopes
compiler/GHC/Cmm/Info/Build.hs view
@@ -29,11 +29,12 @@ import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap-import GHC.CmmToAsm.Monad+import GHC.CmmToAsm import Control.Monad import Data.Map.Strict (Map)@@ -932,7 +933,7 @@ topSRT <- get let- config = initConfig dflags+ config = initNCGConfig dflags profile = targetProfile dflags platform = profilePlatform profile srtMap = moduleSRTMap topSRT
compiler/GHC/Cmm/LayoutStack.hs view
@@ -35,6 +35,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty )+import GHC.Utils.Panic import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array
compiler/GHC/Cmm/Lint.hs view
@@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module GHC.Cmm.Lint ( cmmLint, cmmLintGraph@@ -14,6 +15,7 @@ import GHC.Prelude import GHC.Platform+import GHC.Platform.Regs (callerSaves) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph@@ -26,7 +28,7 @@ import GHC.Utils.Outputable import GHC.Driver.Session -import Control.Monad (ap)+import Control.Monad (ap, unless) -- Things to check: -- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)@@ -160,9 +162,15 @@ CmmUnsafeForeignCall target _formals actuals -> do lintTarget target- mapM_ lintCmmExpr actuals+ let lintArg expr = do+ -- Arguments can't mention caller-saved+ -- registers. See Note [Register parameter passing].+ mayNotMentionCallerSavedRegs (text "foreign call argument") expr+ lintCmmExpr expr + mapM_ lintArg actuals + lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () lintCmmLast labels node = case node of CmmBranch id -> checkTarget id@@ -188,18 +196,40 @@ CmmForeignCall tgt _ args succ _ _ _ -> do lintTarget tgt- mapM_ lintCmmExpr args+ let lintArg expr = do+ -- Arguments can't mention caller-saved+ -- registers. See Note [Register+ -- parameter passing].+ -- N.B. This won't catch local registers+ -- which the NCG's register allocator later+ -- places in caller-saved registers.+ mayNotMentionCallerSavedRegs (text "foreign call argument") expr+ lintCmmExpr expr+ mapM_ lintArg args checkTarget succ where checkTarget id | setMember id labels = return () | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) - lintTarget :: ForeignTarget -> CmmLint ()-lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()+lintTarget (ForeignTarget e _) = do+ mayNotMentionCallerSavedRegs (text "foreign target") e+ _ <- lintCmmExpr e+ return () lintTarget (PrimTarget {}) = return () +-- | As noted in Note [Register parameter passing], the arguments and+-- 'ForeignTarget' of a foreign call mustn't mention+-- caller-saved registers.+mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)+ => SDoc -> a -> CmmLint ()+mayNotMentionCallerSavedRegs what thing = do+ dflags <- getDynFlags+ let badRegs = filter (callerSaves (targetPlatform dflags))+ $ foldRegsUsed dflags (flip (:)) [] thing+ unless (null badRegs)+ $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing) checkCond :: Platform -> CmmExpr -> CmmLint () checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
compiler/GHC/Cmm/Liveness.hs view
@@ -25,6 +25,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block
compiler/GHC/Cmm/Opt.hs view
@@ -19,7 +19,7 @@ import GHC.Cmm import GHC.Utils.Misc -import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.Bits
compiler/GHC/Cmm/Parser.y view
@@ -203,6 +203,7 @@ module GHC.Cmm.Parser ( parseCmmFile ) where import GHC.Prelude+import qualified Prelude -- for happy-generated code import GHC.Platform import GHC.Platform.Profile@@ -247,6 +248,7 @@ import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString@@ -1047,7 +1049,7 @@ args' = init args align = case last args of CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger- e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)+ e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (ppr e) -- The alignment of memcpy-ish operations must be a -- compile-time constant. We verify this here, passing it around -- in the MO_* constructor. In order to do this, however, we
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -46,6 +46,7 @@ import GHC.Cmm.Ppr.Expr import GHC.Cmm +import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Data.FastString
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -41,8 +41,10 @@ import GHC.Prelude -import GHC.Platform import GHC.Driver.Session (targetPlatform)+import GHC.Driver.Ppr++import GHC.Platform import GHC.Cmm.Expr import GHC.Utils.Outputable
compiler/GHC/Cmm/ProcPoint.hs view
@@ -24,6 +24,7 @@ import GHC.Data.Maybe import Control.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block
compiler/GHC/Cmm/Sink.hs view
@@ -772,6 +772,7 @@ {- Note [Inline GlobalRegs?]+~~~~~~~~~~~~~~~~~~~~~~~~~ Should we freely inline GlobalRegs?
compiler/GHC/Cmm/Utils.hs view
@@ -79,6 +79,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Platform.Regs
compiler/GHC/CmmToAsm.hs view
@@ -2,7 +2,6 @@ -- -- (c) The University of Glasgow 1993-2004 ----- This is the top-level module in the native code generator. -- -- ----------------------------------------------------------------------------- @@ -15,40 +14,75 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module GHC.CmmToAsm (- -- * Module entry point- nativeCodeGen+-- | Native code generator+--+-- The native-code generator has machine-independent and+-- machine-dependent modules.+--+-- This module ("GHC.CmmToAsm") is the top-level machine-independent+-- module. Before entering machine-dependent land, we do some+-- machine-independent optimisations (defined below) on the+-- 'CmmStmts's.+--+-- We convert to the machine-specific 'Instr' datatype with+-- 'cmmCodeGen', assuming an infinite supply of registers. We then use+-- a machine-independent register allocator ('regAlloc') to rejoin+-- reality. Obviously, 'regAlloc' has machine-specific helper+-- functions (see about "RegAllocInfo" below).+--+-- Finally, we order the basic blocks of the function so as to minimise+-- the number of jumps between blocks, by utilising fallthrough wherever+-- possible.+--+-- The machine-dependent bits break down as follows:+--+-- * ["MachRegs"] Everything about the target platform's machine+-- registers (and immediate operands, and addresses, which tend to+-- intermingle/interact with registers).+--+-- * ["MachInstrs"] Includes the 'Instr' datatype (possibly should+-- have a module of its own), plus a miscellany of other things+-- (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)+--+-- * ["MachCodeGen"] is where 'Cmm' stuff turns into+-- machine instructions.+--+-- * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+-- a 'SDoc').+--+-- * ["RegAllocInfo"] In the register allocator, we manipulate+-- 'MRegsState's, which are 'BitSet's, one bit per machine register.+-- When we want to say something about a specific machine register+-- (e.g., ``it gets clobbered by this instruction''), we set/unset+-- its bit. Obviously, we do this 'BitSet' thing for efficiency+-- reasons.+--+-- The 'RegAllocInfo' module collects together the machine-specific+-- info needed to do register allocation.+--+-- * ["RegisterAlloc"] The (machine-independent) register allocator.+-- -}+--+module GHC.CmmToAsm+ ( nativeCodeGen - -- * Test-only exports: see trac #12744- -- used by testGraphNoSpills, which needs to access- -- the register allocator intermediate data structures- -- cmmNativeGen emits- , cmmNativeGen- , NcgImpl(..)- , x86NcgImpl- ) where+ -- * Test-only exports: see trac #12744+ -- used by testGraphNoSpills, which needs to access+ -- the register allocator intermediate data structures+ -- cmmNativeGen emits+ , cmmNativeGen+ , NcgImpl(..)+ , initNCGConfig+ )+where #include "GhclibHsVersions.h" import GHC.Prelude -import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen-import qualified GHC.CmmToAsm.X86.Regs as X86.Regs-import qualified GHC.CmmToAsm.X86.Instr as X86.Instr-import qualified GHC.CmmToAsm.X86.Ppr as X86.Ppr--import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC.CodeGen-import qualified GHC.CmmToAsm.SPARC.Regs as SPARC.Regs-import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr-import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC.Ppr-import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC.ShortcutJump-import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC.CodeGen.Expand--import qualified GHC.CmmToAsm.PPC.CodeGen as PPC.CodeGen-import qualified GHC.CmmToAsm.PPC.Regs as PPC.Regs-import qualified GHC.CmmToAsm.PPC.RegInfo as PPC.RegInfo-import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr-import qualified GHC.CmmToAsm.PPC.Ppr as PPC.Ppr+import qualified GHC.CmmToAsm.X86 as X86+import qualified GHC.CmmToAsm.PPC as PPC+import qualified GHC.CmmToAsm.SPARC as SPARC import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear@@ -71,6 +105,7 @@ import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Dwarf import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock import GHC.Cmm.BlockId@@ -87,12 +122,13 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Misc -import GHC.Types.Basic ( Alignment ) import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.Set import GHC.Utils.Error@@ -100,9 +136,6 @@ import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream --- DEBUGGING ONLY---import GHC.Data.OrdList- import Data.List import Data.Maybe import Data.Ord ( comparing )@@ -110,170 +143,33 @@ import Control.Monad import System.IO -{--The native-code generator has machine-independent and-machine-dependent modules.--This module ("AsmCodeGen") is the top-level machine-independent-module. Before entering machine-dependent land, we do some-machine-independent optimisations (defined below) on the-'CmmStmts's.--We convert to the machine-specific 'Instr' datatype with-'cmmCodeGen', assuming an infinite supply of registers. We then use-a machine-independent register allocator ('regAlloc') to rejoin-reality. Obviously, 'regAlloc' has machine-specific helper-functions (see about "RegAllocInfo" below).--Finally, we order the basic blocks of the function so as to minimise-the number of jumps between blocks, by utilising fallthrough wherever-possible.--The machine-dependent bits break down as follows:-- * ["MachRegs"] Everything about the target platform's machine- registers (and immediate operands, and addresses, which tend to- intermingle/interact with registers).-- * ["MachInstrs"] Includes the 'Instr' datatype (possibly should- have a module of its own), plus a miscellany of other things- (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)-- * ["MachCodeGen"] is where 'Cmm' stuff turns into- machine instructions.-- * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really- a 'SDoc').-- * ["RegAllocInfo"] In the register allocator, we manipulate- 'MRegsState's, which are 'BitSet's, one bit per machine register.- When we want to say something about a specific machine register- (e.g., ``it gets clobbered by this instruction''), we set/unset- its bit. Obviously, we do this 'BitSet' thing for efficiency- reasons.-- The 'RegAllocInfo' module collects together the machine-specific- info needed to do register allocation.-- * ["RegisterAlloc"] The (machine-independent) register allocator.--}- -------------------- nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a nativeCodeGen dflags this_mod modLoc h us cmms- = let config = initConfig dflags+ = let config = initNCGConfig dflags platform = ncgPlatform config- nCG' :: ( Outputable statics, Outputable instr- , Outputable jumpDest, Instruction instr)+ nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a- nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+ nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms in case platformArch platform of- ArchX86 -> nCG' (x86NcgImpl config)- ArchX86_64 -> nCG' (x86_64NcgImpl config)- ArchPPC -> nCG' (ppcNcgImpl config)- ArchS390X -> panic "nativeCodeGen: No NCG for S390X"- ArchSPARC -> nCG' (sparcNcgImpl config)+ ArchX86 -> nCG' (X86.ncgX86 config)+ ArchX86_64 -> nCG' (X86.ncgX86_64 config)+ ArchPPC -> nCG' (PPC.ncgPPC config)+ ArchPPC_64 _ -> nCG' (PPC.ncgPPC config)+ ArchSPARC -> nCG' (SPARC.ncgSPARC config) ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64"+ ArchS390X -> panic "nativeCodeGen: No NCG for S390X" ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64"- ArchPPC_64 _ -> nCG' (ppcNcgImpl config) ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" -x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)- X86.Instr.Instr X86.Instr.JumpDest-x86NcgImpl config- = (x86_64NcgImpl config) -x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)- X86.Instr.Instr X86.Instr.JumpDest-x86_64NcgImpl config- = NcgImpl {- ncgConfig = config- ,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen- ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config- ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId- ,canShortcut = X86.Instr.canShortcut- ,shortcutStatics = X86.Instr.shortcutStatics- ,shortcutJump = X86.Instr.shortcutJump- ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config- ,maxSpillSlots = X86.Instr.maxSpillSlots config- ,allocatableRegs = X86.Regs.allocatableRegs platform- ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform- ,ncgExpandTop = id- ,ncgMakeFarBranches = const id- ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints- ,invertCondBranches = X86.CodeGen.invertCondBranches- }- where- platform = ncgPlatform config--ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest-ppcNcgImpl config- = NcgImpl {- ncgConfig = config- ,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen- ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config- ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId- ,canShortcut = PPC.RegInfo.canShortcut- ,shortcutStatics = PPC.RegInfo.shortcutStatics- ,shortcutJump = PPC.RegInfo.shortcutJump- ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config- ,maxSpillSlots = PPC.Instr.maxSpillSlots config- ,allocatableRegs = PPC.Regs.allocatableRegs platform- ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform- ,ncgExpandTop = id- ,ncgMakeFarBranches = PPC.Instr.makeFarBranches- ,extractUnwindPoints = const []- ,invertCondBranches = \_ _ -> id- }- where- platform = ncgPlatform config--sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest-sparcNcgImpl config- = NcgImpl {- ncgConfig = config- ,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen- ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform- ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId- ,canShortcut = SPARC.ShortcutJump.canShortcut- ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics- ,shortcutJump = SPARC.ShortcutJump.shortcutJump- ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config- ,maxSpillSlots = SPARC.Instr.maxSpillSlots config- ,allocatableRegs = SPARC.Regs.allocatableRegs- ,ncgAllocMoreStack = noAllocMoreStack- ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop- ,ncgMakeFarBranches = const id- ,extractUnwindPoints = const []- ,invertCondBranches = \_ _ -> id- }- where- platform = ncgPlatform config------- Allocating more stack space for spilling is currently only--- supported for the linear register allocator on x86/x86_64, the rest--- default to the panic below. To support allocating extra stack on--- more platforms provide a definition of ncgAllocMoreStack.----noAllocMoreStack :: Int -> NatCmmDecl statics instr- -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)])-noAllocMoreStack amount _- = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"- ++ " If you are trying to compile SHA1.hs from the crypto library then this\n"- ++ " is a known limitation in the linear allocator.\n"- ++ "\n"- ++ " Try enabling the graph colouring allocator with -fregs-graph instead."- ++ " You can still file a bug report if you like.\n"-- -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation. data NativeGenAcc statics instr@@ -318,42 +214,44 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} -nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,- Instruction instr)+nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr) => DynFlags+ -> NCGConfig -> Module -> ModLocation -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a-nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms = do -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty- (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+ (ngs, us', a) <- cmmNativeGenStream dflags config this_mod modLoc ncgImpl bufh us cmms ngs0- _ <- finishNativeGen dflags modLoc bufh us' ngs+ _ <- finishNativeGen dflags config modLoc bufh us' ngs return a finishNativeGen :: Instruction instr => DynFlags+ -> NCGConfig -> ModLocation -> BufHandle -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply-finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs+finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs = withTimingSilent dflags (text "NCG") (`seq` ()) $ do -- Write debug data and finish- let emitDw = debugLevel dflags > 0- us' <- if not emitDw then return us else do- (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)- emitNativeCode dflags bufh dwarf- return us'+ us' <- if not (ncgDwarfEnabled config)+ then return us+ else do+ (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)+ emitNativeCode dflags config bufh dwarf+ return us' bFlush bufh -- dump global NCG stats for graph coloring allocator@@ -368,7 +266,7 @@ dump_stats (Color.pprStats stats graphGlobal) - let platform = targetPlatform dflags+ let platform = ncgPlatform config dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" FormatText@@ -386,7 +284,7 @@ dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) -- write out the imports- let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)+ let ctx = ncgAsmContext config printSDocLn ctx Pretty.LeftMode h $ makeImportsDoc dflags (concat (ngs_imports ngs)) return us'@@ -395,9 +293,9 @@ (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" FormatText -cmmNativeGenStream :: (Outputable statics, Outputable instr- ,Outputable jumpDest, Instruction instr)+cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr) => DynFlags+ -> NCGConfig -> Module -> ModLocation -> NcgImpl statics instr jumpDest -> BufHandle@@ -406,7 +304,7 @@ -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs+cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs = do r <- Stream.runStream cmm_stream case r of Left a ->@@ -423,13 +321,12 @@ dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information- let debugFlag = debugLevel dflags > 0- !ndbgs | debugFlag = cmmDebugGen modLoc cmms- | otherwise = []+ let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms+ | otherwise = [] dbgMap = debugToMap ndbgs -- Generate native code- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h+ (ngs',us') <- cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap us cmms ngs 0 -- Link native code information into debug blocks@@ -443,7 +340,7 @@ let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } return (us', ngs'') - cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'+ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us' cmm_stream' ngs'' where ncglabel = text "NCG"@@ -451,9 +348,9 @@ -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest.- (Outputable statics, Outputable instr- ,Outputable jumpDest, Instruction instr)+ (Outputable statics, Outputable jumpDest, Instruction instr) => DynFlags+ -> NCGConfig -> Module -> ModLocation -> NcgImpl statics instr jumpDest -> BufHandle@@ -464,7 +361,7 @@ -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go+cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int@@ -489,14 +386,14 @@ pprDecl (f,n) = text "\t.file " <> ppr n <+> pprFilePathString (unpackFS f) - emitNativeCode dflags h $ vcat $+ emitNativeCode dflags config h $ vcat $ map pprDecl newFileIds ++ map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) () - let !labels' = if debugLevel dflags > 0+ let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else [] !natives' = if dopt Opt_D_dump_asm_stats dflags then native : ngs_natives ngs else []@@ -513,10 +410,10 @@ go us' cmms ngs' (count + 1) -emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()-emitNativeCode dflags h sdoc = do+emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()+emitNativeCode dflags config h sdoc = do - let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)+ let ctx = ncgAsmContext config {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code@@ -528,8 +425,7 @@ -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen- :: forall statics instr jumpDest. (Instruction instr,- Outputable statics, Outputable instr, Outputable jumpDest)+ :: forall statics instr jumpDest. (Instruction instr, Outputable statics, Outputable jumpDest) => DynFlags -> Module -> ModLocation -> NcgImpl statics instr jumpDest@@ -551,6 +447,7 @@ = do let config = ncgConfig ncgImpl let platform = ncgPlatform config+ let weights = ncgCfgWeights config let proc_name = case cmm of (CmmProc _ entry_label _ _) -> ppr entry_label@@ -571,12 +468,12 @@ (pprCmmGroup [opt_cmm]) let cmmCfg = {-# SCC "getCFG" #-}- getCfgProc (cfgWeightInfo dflags) opt_cmm+ getCfgProc weights opt_cmm -- generate native code from cmm let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = {-# SCC "genMachCode" #-}- initUs us $ genMachCode dflags this_mod modLoc+ initUs us $ genMachCode config this_mod modLoc (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg @@ -600,7 +497,7 @@ dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" FormatCMM- (vcat $ map ppr withLiveness)+ (vcat $ map (pprLiveCmmDecl platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-@@ -648,7 +545,7 @@ (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage- $$ ppr stats)+ $$ ppr (fmap (pprInstr platform) stats)) $ zip [0..] regAllocStats) let mPprStats =@@ -703,11 +600,11 @@ cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats) let cfgWithFixupBlks =- (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg+ (\cfg -> addNodesBetween weights cfg cfgRegAllocUpdates) <$> livenessCfg -- Insert stack update blocks let postRegCFG =- pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))+ pure (foldl' (\m (from,to) -> addImmediateSuccessor weights from to m )) <*> cfgWithFixupBlks <*> pure stack_updt_blks @@ -729,7 +626,7 @@ let optimizedCFG :: Maybe CFG optimizedCFG =- optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG+ optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name @@ -751,7 +648,6 @@ checkLayout shorted $ {-# SCC "sequenceBlocks" #-} map (BlockLayout.sequenceTop- dflags ncgImpl optimizedCFG) shorted @@ -877,7 +773,7 @@ else Outputable.empty) where- config = initConfig dflags+ config = initNCGConfig dflags platform = ncgPlatform config -- Generate "symbol stubs" for all external symbols that might@@ -899,10 +795,9 @@ | otherwise = Outputable.empty - doPpr lbl = (lbl, renderWithStyle- (initSDocContext dflags astyle)+ doPpr lbl = (lbl, renderWithContext+ (ncgAsmContext config) (pprCLabel_NCG platform lbl))- astyle = mkCodeStyle AsmStyle -- ----------------------------------------------------------------------------- -- Generate jump tables@@ -1013,7 +908,7 @@ -- Unique supply breaks abstraction. Is that bad? genMachCode- :: DynFlags+ :: NCGConfig -> Module -> ModLocation -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) -> DwarfFiles@@ -1027,9 +922,9 @@ , CFG ) -genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg+genMachCode config this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg = do { initial_us <- getUniqueSupplyM- ; let initial_st = mkNatM_State initial_us 0 dflags this_mod+ ; let initial_st = mkNatM_State initial_us 0 config this_mod modLoc fileIds dbgMap cmm_cfg (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) final_delta = natm_delta final_st@@ -1243,3 +1138,54 @@ other -> return other++-- | Initialize the native code generator configuration from the DynFlags+initNCGConfig :: DynFlags -> NCGConfig+initNCGConfig dflags = NCGConfig+ { ncgPlatform = targetPlatform dflags+ , ncgAsmContext = initSDocContext dflags (mkCodeStyle AsmStyle)+ , ncgProcAlignment = cmmProcAlignment dflags+ , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+ , ncgPIC = positionIndependent dflags+ , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags+ , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags+ , ncgSplitSections = gopt Opt_SplitSections dflags+ , ncgRegsIterative = gopt Opt_RegsIterative dflags+ , ncgAsmLinting = gopt Opt_DoAsmLinting dflags+ , ncgCfgWeights = cfgWeights dflags+ , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags+ , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags++ -- With -O1 and greater, the cmmSink pass does constant-folding, so+ -- we don't need to do it again in the native code generator.+ , ncgDoConstantFolding = optLevel dflags < 1++ , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags+ , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags+ , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags+ , ncgBmiVersion = case platformArch (targetPlatform dflags) of+ ArchX86_64 -> bmiVersion dflags+ ArchX86 -> bmiVersion dflags+ _ -> Nothing++ -- We Assume SSE1 and SSE2 operations are available on both+ -- x86 and x86_64. Historically we didn't default to SSE2 and+ -- SSE1 on x86, which results in defacto nondeterminism for how+ -- rounding behaves in the associated x87 floating point instructions+ -- because variations in the spill/fpu stack placement of arguments for+ -- operations would change the precision and final result of what+ -- would otherwise be the same expressions with respect to single or+ -- double precision IEEE floating point computations.+ , ncgSseVersion =+ let v | sseVersion dflags < Just SSE2 = Just SSE2+ | otherwise = sseVersion dflags+ in case platformArch (targetPlatform dflags) of+ ArchX86_64 -> v+ ArchX86 -> v+ _ -> Nothing++ , ncgDwarfEnabled = debugLevel dflags > 0+ , ncgDwarfUnwindings = debugLevel dflags >= 1+ , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.+ }+
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} module GHC.CmmToAsm.BlockLayout ( sequenceTop, backendMaintainsCfg)@@ -16,9 +17,13 @@ #include "GhclibHsVersions.h" import GHC.Prelude +import GHC.Driver.Ppr (pprTrace)+ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Config import GHC.Cmm.BlockId import GHC.Cmm@@ -26,12 +31,12 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform-import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Types.Unique.FM import GHC.Utils.Misc import GHC.Data.Graph.Directed import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Maybe -- DEBUGGING ONLY@@ -665,7 +670,7 @@ -- | Place basic blocks based on the given CFG. -- See Note [Chain based CFG serialization]-sequenceChain :: forall a i. (Instruction i, Outputable i)+sequenceChain :: forall a i. Instruction i => LabelMap a -- ^ Keys indicate an info table on the block. -> CFG -- ^ Control flow graph and some meta data. -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.@@ -812,31 +817,33 @@ -- fallthroughs. sequenceTop- :: (Instruction instr, Outputable instr)- => DynFlags -- Determine which layout algo to use- -> NcgImpl statics instr jumpDest+ :: Instruction instr+ => NcgImpl statics instr jumpDest -> Maybe CFG -- ^ CFG if we have one. -> NatCmmDecl statics instr -- ^ Function to serialize -> NatCmmDecl statics instr -sequenceTop _ _ _ top@(CmmData _ _) = top-sequenceTop dflags ncgImpl edgeWeights- (CmmProc info lbl live (ListGraph blocks))- | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)- --Use chain based algorithm- , Just cfg <- edgeWeights- = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $- {-# SCC layoutBlocks #-}- sequenceChain info cfg blocks )- | otherwise- --Use old algorithm- = let cfg = if dontUseCfg then Nothing else edgeWeights- in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $- {-# SCC layoutBlocks #-}- sequenceBlocks cfg info blocks)- where- dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||- (not $ backendMaintainsCfg (targetPlatform dflags))+sequenceTop _ _ top@(CmmData _ _) = top+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))+ = let+ config = ncgConfig ncgImpl+ platform = ncgPlatform config++ in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $+ if -- Chain based algorithm+ | ncgCfgBlockLayout config+ , backendMaintainsCfg platform+ , Just cfg <- edgeWeights+ -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks++ -- Old algorithm without edge weights+ | ncgCfgWeightlessLayout config+ || not (backendMaintainsCfg platform)+ -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks++ -- Old algorithm with edge weights (if any)+ | otherwise+ -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks -- The old algorithm: -- It is very simple (and stupid): We make a graph out of
compiler/GHC/CmmToAsm/CFG.hs view
@@ -62,6 +62,7 @@ import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom+import GHC.CmmToAsm.CFG.Weight import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) @@ -73,12 +74,12 @@ import Data.Bifunctor import GHC.Utils.Outputable+import GHC.Utils.Panic -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace import GHC.Cmm.Ppr () -- For Outputable instances-import qualified GHC.Driver.Session as D import Data.List (sort, nub, partition) import Data.STRef.Strict@@ -328,12 +329,11 @@ -- \ \ -- -> C => -> C ---addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG-addImmediateSuccessor dflags node follower cfg- = updateEdges . addWeightEdge node follower uncondWeight $ cfg+addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG+addImmediateSuccessor weights node follower cfg+ = updateEdges . addWeightEdge node follower weight $ cfg where- uncondWeight = fromIntegral . D.uncondWeight .- D.cfgWeightInfo $ dflags+ weight = fromIntegral (uncondWeight weights) targets = getSuccessorEdges cfg node successors = map fst targets :: [BlockId] updateEdges = addNewSuccs . remOldSuccs@@ -508,13 +508,12 @@ -- these cases. -- We assign the old edge info to the edge A -> B and assign B -> C the -- weight of an unconditional jump.-addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG-addNodesBetween dflags m updates =+addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG+addNodesBetween weights m updates = foldl' updateWeight m . weightUpdates $ updates where- weight = fromIntegral . D.uncondWeight .- D.cfgWeightInfo $ dflags+ weight = fromIntegral (uncondWeight weights) -- We might add two blocks for different jumps along a single -- edge. So we end up with edges: A -> B -> C , A -> D -> C -- in this case after applying the first update the weight for A -> C@@ -584,24 +583,24 @@ -} -- | Generate weights for a Cmm proc based on some simple heuristics.-getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG+getCfgProc :: Weights -> RawCmmDecl -> CFG getCfgProc _ (CmmData {}) = mapEmpty getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph -getCfg :: D.CfgWeights -> CmmGraph -> CFG+getCfg :: Weights -> CmmGraph -> CFG getCfg weights graph = foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks where- D.CFGWeights- { D.uncondWeight = uncondWeight- , D.condBranchWeight = condBranchWeight- , D.switchWeight = switchWeight- , D.callWeight = callWeight- , D.likelyCondWeight = likelyCondWeight- , D.unlikelyCondWeight = unlikelyCondWeight+ Weights+ { uncondWeight = uncondWeight+ , condBranchWeight = condBranchWeight+ , switchWeight = switchWeight+ , callWeight = callWeight+ , likelyCondWeight = likelyCondWeight+ , unlikelyCondWeight = unlikelyCondWeight -- Last two are used in other places- --, D.infoTablePenalty = infoTablePenalty- --, D.backEdgeBonus = backEdgeBonus+ --, infoTablePenalty = infoTablePenalty+ --, backEdgeBonus = backEdgeBonus } = weights -- Explicitly add all nodes to the cfg to ensure they are part of the -- CFG.@@ -630,7 +629,7 @@ mkEdge target weight = ((bid,target), mkEdgeInfo weight) branchInfo = foldRegsUsed- (panic "foldRegsDynFlags")+ (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed") (\info r -> if r == SpLim || r == HpLim || r == BaseReg then HeapStackCheck else info) NoInfo cond@@ -670,7 +669,7 @@ typedEdges = classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] -optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG optimizeCFG _ _ (CmmData {}) cfg = cfg optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg = (if doStaticPred then staticPredCfg (g_entry graph) else id) $@@ -681,7 +680,7 @@ -- performance. -- -- Most importantly we penalize jumps across info tables.-optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG optHsPatterns _ (CmmData {}) cfg = cfg optHsPatterns weights (CmmProc info _lab _live graph) cfg = {-# SCC optHsPatterns #-}@@ -703,7 +702,7 @@ --Keep irrelevant edges irrelevant | weight <= 0 = 0 | otherwise- = weight + fromIntegral (D.backEdgeBonus weights)+ = weight + fromIntegral (backEdgeBonus weights) in foldl' (\cfg edge -> updateEdgeWeight update edge cfg) cfg backedges @@ -715,7 +714,7 @@ fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight fupdate _ to weight | mapMember to info- = weight - (fromIntegral $ D.infoTablePenalty weights)+ = weight - (fromIntegral $ infoTablePenalty weights) | otherwise = weight -- | If a block has two successors, favour the one with fewer
compiler/GHC/CmmToAsm/CFG/Dominators.hs view
@@ -1,597 +1,563 @@-{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} - -{- | - Module : Dominators - Copyright : (c) Matt Morrow 2009 - License : BSD3 - Maintainer : <morrow@moonpatio.com> - Stability : experimental - Portability : portable - - Taken from the dom-lt package. - - The Lengauer-Tarjan graph dominators algorithm. - - \[1\] Lengauer, Tarjan, - /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979. - - \[2\] Muchnick, - /Advanced Compiler Design and Implementation/, 1997. - - \[3\] Brisk, Sarrafzadeh, - /Interference Graphs for Procedures in Static Single/ - /Information Form are Interval Graphs/, 2007. - - Originally taken from the dom-lt package. --} - -module GHC.CmmToAsm.CFG.Dominators ( - Node,Path,Edge - ,Graph,Rooted - ,idom,ipdom - ,domTree,pdomTree - ,dom,pdom - ,pddfs,rpddfs - ,fromAdj,fromEdges - ,toAdj,toEdges - ,asTree,asGraph - ,parents,ancestors -) where - -import GHC.Prelude - -import Data.Bifunctor -import Data.Tuple (swap) - -import Data.Tree -import Data.IntMap(IntMap) -import Data.IntSet(IntSet) -import qualified Data.IntMap.Strict as IM -import qualified Data.IntSet as IS - -import Control.Monad -import Control.Monad.ST.Strict - -import Data.Array.ST -import Data.Array.Base hiding ((!)) - -- (unsafeNewArray_ - -- ,unsafeWrite,unsafeRead - -- ,readArray,writeArray) - -import GHC.Utils.Misc (debugIsOn) - ------------------------------------------------------------------------------ - -type Node = Int -type Path = [Node] -type Edge = (Node,Node) -type Graph = IntMap IntSet -type Rooted = (Node, Graph) - ------------------------------------------------------------------------------ - --- | /Dominators/. --- Complexity as for @idom@ -dom :: Rooted -> [(Node, Path)] -dom = ancestors . domTree - --- | /Post-dominators/. --- Complexity as for @idom@. -pdom :: Rooted -> [(Node, Path)] -pdom = ancestors . pdomTree - --- | /Dominator tree/. --- Complexity as for @idom@. -domTree :: Rooted -> Tree Node -domTree a@(r,_) = - let is = filter ((/=r).fst) (idom a) - tg = fromEdges (fmap swap is) - in asTree (r,tg) - --- | /Post-dominator tree/. --- Complexity as for @idom@. -pdomTree :: Rooted -> Tree Node -pdomTree a@(r,_) = - let is = filter ((/=r).fst) (ipdom a) - tg = fromEdges (fmap swap is) - in asTree (r,tg) - --- | /Immediate dominators/. --- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is --- \"a functional inverse of Ackermann's function\". --- --- This Complexity bound assumes /O(1)/ indexing. Since we're --- using @IntMap@, it has an additional /lg |V|/ factor --- somewhere in there. I'm not sure where. -idom :: Rooted -> [(Node,Node)] -idom rg = runST (evalS idomM =<< initEnv (pruneReach rg)) - --- | /Immediate post-dominators/. --- Complexity as for @idom@. -ipdom :: Rooted -> [(Node,Node)] -ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) - ------------------------------------------------------------------------------ - --- | /Post-dominated depth-first search/. -pddfs :: Rooted -> [Node] -pddfs = reverse . rpddfs - --- | /Reverse post-dominated depth-first search/. -rpddfs :: Rooted -> [Node] -rpddfs = concat . levels . pdomTree - ------------------------------------------------------------------------------ - -type Dom s a = S s (Env s) a -type NodeSet = IntSet -type NodeMap a = IntMap a -data Env s = Env - {succE :: !Graph - ,predE :: !Graph - ,bucketE :: !Graph - ,dfsE :: {-# UNPACK #-}!Int - ,zeroE :: {-# UNPACK #-}!Node - ,rootE :: {-# UNPACK #-}!Node - ,labelE :: {-# UNPACK #-}!(Arr s Node) - ,parentE :: {-# UNPACK #-}!(Arr s Node) - ,ancestorE :: {-# UNPACK #-}!(Arr s Node) - ,childE :: {-# UNPACK #-}!(Arr s Node) - ,ndfsE :: {-# UNPACK #-}!(Arr s Node) - ,dfnE :: {-# UNPACK #-}!(Arr s Int) - ,sdnoE :: {-# UNPACK #-}!(Arr s Int) - ,sizeE :: {-# UNPACK #-}!(Arr s Int) - ,domE :: {-# UNPACK #-}!(Arr s Node) - ,rnE :: {-# UNPACK #-}!(Arr s Node)} - ------------------------------------------------------------------------------ - -idomM :: Dom s [(Node,Node)] -idomM = do - dfsDom =<< rootM - n <- gets dfsE - forM_ [n,n-1..1] (\i-> do - w <- ndfsM i - sw <- sdnoM w - ps <- predsM w - forM_ ps (\v-> do - u <- eval v - su <- sdnoM u - when (su < sw) - (store sdnoE w su)) - z <- ndfsM =<< sdnoM w - modify(\e->e{bucketE=IM.adjust - (w`IS.insert`) - z (bucketE e)}) - pw <- parentM w - link pw w - bps <- bucketM pw - forM_ bps (\v-> do - u <- eval v - su <- sdnoM u - sv <- sdnoM v - let dv = case su < sv of - True-> u - False-> pw - store domE v dv)) - forM_ [1..n] (\i-> do - w <- ndfsM i - j <- sdnoM w - z <- ndfsM j - dw <- domM w - when (dw /= z) - (do ddw <- domM dw - store domE w ddw)) - fromEnv - ------------------------------------------------------------------------------ - -eval :: Node -> Dom s Node -eval v = do - n0 <- zeroM - a <- ancestorM v - case a==n0 of - True-> labelM v - False-> do - compress v - a <- ancestorM v - l <- labelM v - la <- labelM a - sl <- sdnoM l - sla <- sdnoM la - case sl <= sla of - True-> return l - False-> return la - -compress :: Node -> Dom s () -compress v = do - n0 <- zeroM - a <- ancestorM v - aa <- ancestorM a - when (aa /= n0) (do - compress a - a <- ancestorM v - aa <- ancestorM a - l <- labelM v - la <- labelM a - sl <- sdnoM l - sla <- sdnoM la - when (sla < sl) - (store labelE v la) - store ancestorE v aa) - ------------------------------------------------------------------------------ - -link :: Node -> Node -> Dom s () -link v w = do - n0 <- zeroM - lw <- labelM w - slw <- sdnoM lw - let balance s = do - c <- childM s - lc <- labelM c - slc <- sdnoM lc - case slw < slc of - False-> return s - True-> do - zs <- sizeM s - zc <- sizeM c - cc <- childM c - zcc <- sizeM cc - case 2*zc <= zs+zcc of - True-> do - store ancestorE c s - store childE s cc - balance s - False-> do - store sizeE c zs - store ancestorE s c - balance c - s <- balance w - lw <- labelM w - zw <- sizeM w - store labelE s lw - store sizeE v . (+zw) =<< sizeM v - let follow s = do - when (s /= n0) (do - store ancestorE s v - follow =<< childM s) - zv <- sizeM v - follow =<< case zv < 2*zw of - False-> return s - True-> do - cv <- childM v - store childE v s - return cv - ------------------------------------------------------------------------------ - -dfsDom :: Node -> Dom s () -dfsDom i = do - _ <- go i - n0 <- zeroM - r <- rootM - store parentE r n0 - where go i = do - n <- nextM - store dfnE i n - store sdnoE i n - store ndfsE n i - store labelE i i - ss <- succsM i - forM_ ss (\j-> do - s <- sdnoM j - case s==0 of - False-> return() - True-> do - store parentE j i - go j) - ------------------------------------------------------------------------------ - -initEnv :: Rooted -> ST s (Env s) -initEnv (r0,g0) = do - let (g,rnmap) = renum 1 g0 - pred = predG g - r = rnmap IM.! r0 - n = IM.size g - ns = [0..n] - m = n+1 - - let bucket = IM.fromList - (zip ns (repeat mempty)) - - rna <- newI m - writes rna (fmap swap - (IM.toList rnmap)) - - doms <- newI m - sdno <- newI m - size <- newI m - parent <- newI m - ancestor <- newI m - child <- newI m - label <- newI m - ndfs <- newI m - dfn <- newI m - - forM_ [0..n] (doms.=0) - forM_ [0..n] (sdno.=0) - forM_ [1..n] (size.=1) - forM_ [0..n] (ancestor.=0) - forM_ [0..n] (child.=0) - - (doms.=r) r - (size.=0) 0 - (label.=0) 0 - - return (Env - {rnE = rna - ,dfsE = 0 - ,zeroE = 0 - ,rootE = r - ,labelE = label - ,parentE = parent - ,ancestorE = ancestor - ,childE = child - ,ndfsE = ndfs - ,dfnE = dfn - ,sdnoE = sdno - ,sizeE = size - ,succE = g - ,predE = pred - ,bucketE = bucket - ,domE = doms}) - -fromEnv :: Dom s [(Node,Node)] -fromEnv = do - dom <- gets domE - rn <- gets rnE - -- r <- gets rootE - (_,n) <- st (getBounds dom) - forM [1..n] (\i-> do - j <- st(rn!:i) - d <- st(dom!:i) - k <- st(rn!:d) - return (j,k)) - ------------------------------------------------------------------------------ - -zeroM :: Dom s Node -zeroM = gets zeroE -domM :: Node -> Dom s Node -domM = fetch domE -rootM :: Dom s Node -rootM = gets rootE -succsM :: Node -> Dom s [Node] -succsM i = gets (IS.toList . (! i) . succE) -predsM :: Node -> Dom s [Node] -predsM i = gets (IS.toList . (! i) . predE) -bucketM :: Node -> Dom s [Node] -bucketM i = gets (IS.toList . (! i) . bucketE) -sizeM :: Node -> Dom s Int -sizeM = fetch sizeE -sdnoM :: Node -> Dom s Int -sdnoM = fetch sdnoE --- dfnM :: Node -> Dom s Int --- dfnM = fetch dfnE -ndfsM :: Int -> Dom s Node -ndfsM = fetch ndfsE -childM :: Node -> Dom s Node -childM = fetch childE -ancestorM :: Node -> Dom s Node -ancestorM = fetch ancestorE -parentM :: Node -> Dom s Node -parentM = fetch parentE -labelM :: Node -> Dom s Node -labelM = fetch labelE -nextM :: Dom s Int -nextM = do - n <- gets dfsE - let n' = n+1 - modify(\e->e{dfsE=n'}) - return n' - ------------------------------------------------------------------------------ - -type A = STUArray -type Arr s a = A s Int a - -infixl 9 !: -infixr 2 .= - -(.=) :: (MArray (A s) a (ST s)) - => Arr s a -> a -> Int -> ST s () -(v .= x) i - | debugIsOn = writeArray v i x - | otherwise = unsafeWrite v i x - -(!:) :: (MArray (A s) a (ST s)) - => A s Int a -> Int -> ST s a -a !: i - | debugIsOn = do - o <- readArray a i - return $! o - | otherwise = do - o <- unsafeRead a i - return $! o - -new :: (MArray (A s) a (ST s)) - => Int -> ST s (Arr s a) -new n = unsafeNewArray_ (0,n-1) - -newI :: Int -> ST s (Arr s Int) -newI = new - --- newD :: Int -> ST s (Arr s Double) --- newD = new - --- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] --- dump a = do --- (m,n) <- getBounds a --- forM [m..n] (\i -> a!:i) - -writes :: (MArray (A s) a (ST s)) - => Arr s a -> [(Int,a)] -> ST s () -writes a xs = forM_ xs (\(i,x) -> (a.=x) i) - --- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) --- arr xs = do --- let n = length xs --- a <- new n --- go a n 0 xs --- return a --- where go _ _ _ [] = return () --- go a n i (x:xs) --- | i <= n = (a.=x) i >> go a n (i+1) xs --- | otherwise = return () - ------------------------------------------------------------------------------ - -(!) :: Monoid a => IntMap a -> Int -> a -(!) g n = maybe mempty id (IM.lookup n g) - -fromAdj :: [(Node, [Node])] -> Graph -fromAdj = IM.fromList . fmap (second IS.fromList) - -fromEdges :: [Edge] -> Graph -fromEdges = collectI IS.union fst (IS.singleton . snd) - -toAdj :: Graph -> [(Node, [Node])] -toAdj = fmap (second IS.toList) . IM.toList - -toEdges :: Graph -> [Edge] -toEdges = concatMap (uncurry (fmap . (,))) . toAdj - -predG :: Graph -> Graph -predG g = IM.unionWith IS.union (go g) g0 - where g0 = fmap (const mempty) g - f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet - f m i a = foldl' (\m p -> IM.insertWith mappend p - (IS.singleton i) m) - m - (IS.toList a) - go :: IntMap IntSet -> IntMap IntSet - go = flip IM.foldlWithKey' mempty f - -pruneReach :: Rooted -> Rooted -pruneReach (r,g) = (r,g2) - where is = reachable - (maybe mempty id - . flip IM.lookup g) $ r - g2 = IM.fromList - . fmap (second (IS.filter (`IS.member`is))) - . filter ((`IS.member`is) . fst) - . IM.toList $ g - -tip :: Tree a -> (a, [Tree a]) -tip (Node a ts) = (a, ts) - -parents :: Tree a -> [(a, a)] -parents (Node i xs) = p i xs - ++ concatMap parents xs - where p i = fmap (flip (,) i . rootLabel) - -ancestors :: Tree a -> [(a, [a])] -ancestors = go [] - where go acc (Node i xs) - = let acc' = i:acc - in p acc' xs ++ concatMap (go acc') xs - p is = fmap (flip (,) is . rootLabel) - -asGraph :: Tree Node -> Rooted -asGraph t@(Node a _) = let g = go t in (a, fromAdj g) - where go (Node a ts) = let as = (fst . unzip . fmap tip) ts - in (a, as) : concatMap go ts - -asTree :: Rooted -> Tree Node -asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) - f = (g !) - in go r - -reachable :: (Node -> NodeSet) -> (Node -> NodeSet) -reachable f a = go (IS.singleton a) a - where go seen a = let s = f a - as = IS.toList (s `IS.difference` seen) - in foldl' go (s `IS.union` seen) as - -collectI :: (c -> c -> c) - -> (a -> Int) -> (a -> c) -> [a] -> IntMap c -collectI (<>) f g - = foldl' (\m a -> IM.insertWith (<>) - (f a) - (g a) m) mempty - --- collect :: (Ord b) => (c -> c -> c) --- -> (a -> b) -> (a -> c) -> [a] -> Map b c --- collect (<>) f g --- = foldl' (\m a -> SM.insertWith (<>) --- (f a) --- (g a) m) mempty - --- (renamed, old -> new) -renum :: Int -> Graph -> (Graph, NodeMap Node) -renum from = (\(_,m,g)->(g,m)) - . IM.foldlWithKey' - f (from,mempty,mempty) - where - f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet - -> (Int, NodeMap Node, IntMap IntSet) - f (!n,!env,!new) i ss = - let (j,n2,env2) = go n env i - (n3,env3,ss2) = IS.fold - (\k (!n,!env,!new)-> - case go n env k of - (l,n2,env2)-> (n2,env2,l `IS.insert` new)) - (n2,env2,mempty) ss - new2 = IM.insertWith IS.union j ss2 new - in (n3,env3,new2) - go :: Int - -> NodeMap Node - -> Node - -> (Node,Int,NodeMap Node) - go !n !env i = - case IM.lookup i env of - Just j -> (j,n,env) - Nothing -> (n,n+1,IM.insert i n env) - ------------------------------------------------------------------------------ - -newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} -instance Functor (S z s) where - fmap f (S g) = S (\k -> g (k . f)) -instance Monad (S z s) where - return = pure - S g >>= f = S (\k -> g (\a -> unS (f a) k)) -instance Applicative (S z s) where - pure a = S (\k -> k a) - (<*>) = ap --- get :: S z s s --- get = S (\k s -> k s s) -gets :: (s -> a) -> S z s a -gets f = S (\k s -> k (f s) s) --- set :: s -> S z s () --- set s = S (\k _ -> k () s) -modify :: (s -> s) -> S z s () -modify f = S (\k -> k () . f) --- runS :: S z s a -> s -> ST z (a, s) --- runS (S g) = g (\a s -> return (a,s)) -evalS :: S z s a -> s -> ST z a -evalS (S g) = g ((return .) . const) --- execS :: S z s a -> s -> ST z s --- execS (S g) = g ((return .) . flip const) -st :: ST z a -> S z s a -st m = S (\k s-> do - a <- m - k a s) -store :: (MArray (A z) a (ST z)) - => (s -> Arr z a) -> Int -> a -> S z s () -store f i x = do - a <- gets f - st ((a.=x) i) -fetch :: (MArray (A z) a (ST z)) - => (s -> Arr z a) -> Int -> S z s a -fetch f i = do - a <- gets f - st (a!:i) - +{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}++{- |+ Module : GHC.CmmToAsm.CFG.Dominators+ Copyright : (c) Matt Morrow 2009+ License : BSD3+ Maintainer : <klebinger.andreas@gmx.at>+ Stability : stable+ Portability : portable++ The Lengauer-Tarjan graph dominators algorithm.++ \[1\] Lengauer, Tarjan,+ /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.++ \[2\] Muchnick,+ /Advanced Compiler Design and Implementation/, 1997.++ \[3\] Brisk, Sarrafzadeh,+ /Interference Graphs for Procedures in Static Single/+ /Information Form are Interval Graphs/, 2007.++ * Strictness++ Unless stated otherwise all exposed functions might fully evaluate their input+ but are not guaranteed to do so.++-}++module GHC.CmmToAsm.CFG.Dominators (+ Node,Path,Edge+ ,Graph,Rooted+ ,idom,ipdom+ ,domTree,pdomTree+ ,dom,pdom+ ,pddfs,rpddfs+ ,fromAdj,fromEdges+ ,toAdj,toEdges+ ,asTree,asGraph+ ,parents,ancestors+) where++import GHC.Prelude+import Data.Bifunctor+import Data.Tuple (swap)++import Data.Tree+import Data.IntMap(IntMap)+import Data.IntSet(IntSet)+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS++import Control.Monad+import Control.Monad.ST.Strict++import Data.Array.ST+import Data.Array.Base+ (unsafeNewArray_+ ,unsafeWrite,unsafeRead)++-----------------------------------------------------------------------------++type Node = Int+type Path = [Node]+type Edge = (Node,Node)+type Graph = IntMap IntSet+type Rooted = (Node, Graph)++-----------------------------------------------------------------------------++-- | /Dominators/.+-- Complexity as for @idom@+dom :: Rooted -> [(Node, Path)]+dom = ancestors . domTree++-- | /Post-dominators/.+-- Complexity as for @idom@.+pdom :: Rooted -> [(Node, Path)]+pdom = ancestors . pdomTree++-- | /Dominator tree/.+-- Complexity as for @idom@.+domTree :: Rooted -> Tree Node+domTree a@(r,_) =+ let is = filter ((/=r).fst) (idom a)+ tg = fromEdges (fmap swap is)+ in asTree (r,tg)++-- | /Post-dominator tree/.+-- Complexity as for @idom@.+pdomTree :: Rooted -> Tree Node+pdomTree a@(r,_) =+ let is = filter ((/=r).fst) (ipdom a)+ tg = fromEdges (fmap swap is)+ in asTree (r,tg)++-- | /Immediate dominators/.+-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is+-- \"a functional inverse of Ackermann's function\".+--+-- This Complexity bound assumes /O(1)/ indexing. Since we're+-- using @IntMap@, it has an additional /lg |V|/ factor+-- somewhere in there. I'm not sure where.+idom :: Rooted -> [(Node,Node)]+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))++-- | /Immediate post-dominators/.+-- Complexity as for @idom@.+ipdom :: Rooted -> [(Node,Node)]+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))++-----------------------------------------------------------------------------++-- | /Post-dominated depth-first search/.+pddfs :: Rooted -> [Node]+pddfs = reverse . rpddfs++-- | /Reverse post-dominated depth-first search/.+rpddfs :: Rooted -> [Node]+rpddfs = concat . levels . pdomTree++-----------------------------------------------------------------------------++type Dom s a = S s (Env s) a+type NodeSet = IntSet+type NodeMap a = IntMap a+data Env s = Env+ {succE :: !Graph+ ,predE :: !Graph+ ,bucketE :: !Graph+ ,dfsE :: {-# UNPACK #-}!Int+ ,zeroE :: {-# UNPACK #-}!Node+ ,rootE :: {-# UNPACK #-}!Node+ ,labelE :: {-# UNPACK #-}!(Arr s Node)+ ,parentE :: {-# UNPACK #-}!(Arr s Node)+ ,ancestorE :: {-# UNPACK #-}!(Arr s Node)+ ,childE :: {-# UNPACK #-}!(Arr s Node)+ ,ndfsE :: {-# UNPACK #-}!(Arr s Node)+ ,dfnE :: {-# UNPACK #-}!(Arr s Int)+ ,sdnoE :: {-# UNPACK #-}!(Arr s Int)+ ,sizeE :: {-# UNPACK #-}!(Arr s Int)+ ,domE :: {-# UNPACK #-}!(Arr s Node)+ ,rnE :: {-# UNPACK #-}!(Arr s Node)}++-----------------------------------------------------------------------------++idomM :: Dom s [(Node,Node)]+idomM = do+ dfsDom =<< rootM+ n <- gets dfsE+ forM_ [n,n-1..1] (\i-> do+ w <- ndfsM i+ ps <- predsM w+ forM_ ps (\v-> do+ sw <- sdnoM w+ u <- eval v+ su <- sdnoM u+ when (su < sw)+ (store sdnoE w su))+ z <- ndfsM =<< sdnoM w+ modify(\e->e{bucketE=IM.adjust+ (w`IS.insert`)+ z (bucketE e)})+ pw <- parentM w+ link pw w+ bps <- bucketM pw+ forM_ bps (\v-> do+ u <- eval v+ su <- sdnoM u+ sv <- sdnoM v+ let dv = case su < sv of+ True-> u+ False-> pw+ store domE v dv))+ forM_ [1..n] (\i-> do+ w <- ndfsM i+ j <- sdnoM w+ z <- ndfsM j+ dw <- domM w+ when (dw /= z)+ (do ddw <- domM dw+ store domE w ddw))+ fromEnv++-----------------------------------------------------------------------------++eval :: Node -> Dom s Node+eval v = do+ n0 <- zeroM+ a <- ancestorM v+ case a==n0 of+ True-> labelM v+ False-> do+ compress v+ a <- ancestorM v+ l <- labelM v+ la <- labelM a+ sl <- sdnoM l+ sla <- sdnoM la+ case sl <= sla of+ True-> return l+ False-> return la++compress :: Node -> Dom s ()+compress v = do+ n0 <- zeroM+ a <- ancestorM v+ aa <- ancestorM a+ when (aa /= n0) (do+ compress a+ a <- ancestorM v+ aa <- ancestorM a+ l <- labelM v+ la <- labelM a+ sl <- sdnoM l+ sla <- sdnoM la+ when (sla < sl)+ (store labelE v la)+ store ancestorE v aa)++-----------------------------------------------------------------------------++link :: Node -> Node -> Dom s ()+link v w = do+ n0 <- zeroM+ lw <- labelM w+ slw <- sdnoM lw+ let balance s = do+ c <- childM s+ lc <- labelM c+ slc <- sdnoM lc+ case slw < slc of+ False-> return s+ True-> do+ zs <- sizeM s+ zc <- sizeM c+ cc <- childM c+ zcc <- sizeM cc+ case 2*zc <= zs+zcc of+ True-> do+ store ancestorE c s+ store childE s cc+ balance s+ False-> do+ store sizeE c zs+ store ancestorE s c+ balance c+ s <- balance w+ lw <- labelM w+ zw <- sizeM w+ store labelE s lw+ store sizeE v . (+zw) =<< sizeM v+ let follow s = do+ when (s /= n0) (do+ store ancestorE s v+ follow =<< childM s)+ zv <- sizeM v+ follow =<< case zv < 2*zw of+ False-> return s+ True-> do+ cv <- childM v+ store childE v s+ return cv++-----------------------------------------------------------------------------++dfsDom :: Node -> Dom s ()+dfsDom i = do+ _ <- go i+ n0 <- zeroM+ r <- rootM+ store parentE r n0+ where go i = do+ n <- nextM+ store dfnE i n+ store sdnoE i n+ store ndfsE n i+ store labelE i i+ ss <- succsM i+ forM_ ss (\j-> do+ s <- sdnoM j+ case s==0 of+ False-> return()+ True-> do+ store parentE j i+ go j)++-----------------------------------------------------------------------------++initEnv :: Rooted -> ST s (Env s)+initEnv (r0,g0) = do+ -- Graph renumbered to indices from 1 to |V|+ let (g,rnmap) = renum 1 g0+ pred = predG g -- reverse graph+ root = rnmap IM.! r0 -- renamed root+ n = IM.size g+ ns = [0..n]+ m = n+1++ let bucket = IM.fromList+ (zip ns (repeat mempty))++ rna <- newI m+ writes rna (fmap swap+ (IM.toList rnmap))++ doms <- newI m+ sdno <- newI m+ size <- newI m+ parent <- newI m+ ancestor <- newI m+ child <- newI m+ label <- newI m+ ndfs <- newI m+ dfn <- newI m++ -- Initialize all arrays+ forM_ [0..n] (doms.=0)+ forM_ [0..n] (sdno.=0)+ forM_ [1..n] (size.=1)+ forM_ [0..n] (ancestor.=0)+ forM_ [0..n] (child.=0)++ (doms.=root) root+ (size.=0) 0+ (label.=0) 0++ return (Env+ {rnE = rna+ ,dfsE = 0+ ,zeroE = 0+ ,rootE = root+ ,labelE = label+ ,parentE = parent+ ,ancestorE = ancestor+ ,childE = child+ ,ndfsE = ndfs+ ,dfnE = dfn+ ,sdnoE = sdno+ ,sizeE = size+ ,succE = g+ ,predE = pred+ ,bucketE = bucket+ ,domE = doms})++fromEnv :: Dom s [(Node,Node)]+fromEnv = do+ dom <- gets domE+ rn <- gets rnE+ -- r <- gets rootE+ (_,n) <- st (getBounds dom)+ forM [1..n] (\i-> do+ j <- st(rn!:i)+ d <- st(dom!:i)+ k <- st(rn!:d)+ return (j,k))++-----------------------------------------------------------------------------++zeroM :: Dom s Node+zeroM = gets zeroE+domM :: Node -> Dom s Node+domM = fetch domE+rootM :: Dom s Node+rootM = gets rootE+succsM :: Node -> Dom s [Node]+succsM i = gets (IS.toList . (! i) . succE)+predsM :: Node -> Dom s [Node]+predsM i = gets (IS.toList . (! i) . predE)+bucketM :: Node -> Dom s [Node]+bucketM i = gets (IS.toList . (! i) . bucketE)+sizeM :: Node -> Dom s Int+sizeM = fetch sizeE+sdnoM :: Node -> Dom s Int+sdnoM = fetch sdnoE+-- dfnM :: Node -> Dom s Int+-- dfnM = fetch dfnE+ndfsM :: Int -> Dom s Node+ndfsM = fetch ndfsE+childM :: Node -> Dom s Node+childM = fetch childE+ancestorM :: Node -> Dom s Node+ancestorM = fetch ancestorE+parentM :: Node -> Dom s Node+parentM = fetch parentE+labelM :: Node -> Dom s Node+labelM = fetch labelE+nextM :: Dom s Int+nextM = do+ n <- gets dfsE+ let n' = n+1+ modify(\e->e{dfsE=n'})+ return n'++-----------------------------------------------------------------------------++type A = STUArray+type Arr s a = A s Int a++infixl 9 !:+infixr 2 .=++-- | arr .= x idx => write x to index+(.=) :: (MArray (A s) a (ST s))+ => Arr s a -> a -> Int -> ST s ()+(v .= x) i = unsafeWrite v i x++(!:) :: (MArray (A s) a (ST s))+ => A s Int a -> Int -> ST s a+a !: i = do+ o <- unsafeRead a i+ return $! o++new :: (MArray (A s) a (ST s))+ => Int -> ST s (Arr s a)+new n = unsafeNewArray_ (0,n-1)++newI :: Int -> ST s (Arr s Int)+newI = new++writes :: (MArray (A s) a (ST s))+ => Arr s a -> [(Int,a)] -> ST s ()+writes a xs = forM_ xs (\(i,x) -> (a.=x) i)+++(!) :: Monoid a => IntMap a -> Int -> a+(!) g n = maybe mempty id (IM.lookup n g)++fromAdj :: [(Node, [Node])] -> Graph+fromAdj = IM.fromList . fmap (second IS.fromList)++fromEdges :: [Edge] -> Graph+fromEdges = collectI IS.union fst (IS.singleton . snd)++toAdj :: Graph -> [(Node, [Node])]+toAdj = fmap (second IS.toList) . IM.toList++toEdges :: Graph -> [Edge]+toEdges = concatMap (uncurry (fmap . (,))) . toAdj++predG :: Graph -> Graph+predG g = IM.unionWith IS.union (go g) g0+ where g0 = fmap (const mempty) g+ go = flip IM.foldrWithKey mempty (\i a m ->+ foldl' (\m p -> IM.insertWith mappend p+ (IS.singleton i) m)+ m+ (IS.toList a))++pruneReach :: Rooted -> Rooted+pruneReach (r,g) = (r,g2)+ where is = reachable+ (maybe mempty id+ . flip IM.lookup g) $ r+ g2 = IM.fromList+ . fmap (second (IS.filter (`IS.member`is)))+ . filter ((`IS.member`is) . fst)+ . IM.toList $ g++tip :: Tree a -> (a, [Tree a])+tip (Node a ts) = (a, ts)++parents :: Tree a -> [(a, a)]+parents (Node i xs) = p i xs+ ++ concatMap parents xs+ where p i = fmap (flip (,) i . rootLabel)++ancestors :: Tree a -> [(a, [a])]+ancestors = go []+ where go acc (Node i xs)+ = let acc' = i:acc+ in p acc' xs ++ concatMap (go acc') xs+ p is = fmap (flip (,) is . rootLabel)++asGraph :: Tree Node -> Rooted+asGraph t@(Node a _) = let g = go t in (a, fromAdj g)+ where go (Node a ts) = let as = (fst . unzip . fmap tip) ts+ in (a, as) : concatMap go ts++asTree :: Rooted -> Tree Node+asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))+ f = (g !)+ in go r++reachable :: (Node -> NodeSet) -> (Node -> NodeSet)+reachable f a = go (IS.singleton a) a+ where go seen a = let s = f a+ as = IS.toList (s `IS.difference` seen)+ in foldl' go (s `IS.union` seen) as++collectI :: (c -> c -> c)+ -> (a -> Int) -> (a -> c) -> [a] -> IntMap c+collectI (<>) f g+ = foldl' (\m a -> IM.insertWith (<>)+ (f a)+ (g a) m) mempty++-- | renum n g: Rename all nodes+--+-- Gives nodes sequential names starting at n.+-- Returns the new graph and a mapping.+-- (renamed, old -> new)+renum :: Int -> Graph -> (Graph, NodeMap Node)+renum from = (\(_,m,g)->(g,m))+ . IM.foldrWithKey+ (\i ss (!n,!env,!new)->+ let (j,n2,env2) = go n env i+ (n3,env3,ss2) = IS.fold+ (\k (!n,!env,!new)->+ case go n env k of+ (l,n2,env2)-> (n2,env2,l `IS.insert` new))+ (n2,env2,mempty) ss+ new2 = IM.insertWith IS.union j ss2 new+ in (n3,env3,new2)) (from,mempty,mempty)+ where go :: Int+ -> NodeMap Node+ -> Node+ -> (Node,Int,NodeMap Node)+ go !n !env i =+ case IM.lookup i env of+ Just j -> (j,n,env)+ Nothing -> (n,n+1,IM.insert i n env)++-----------------------------------------------------------------------------++-- Nothing better than reinvinting the state monad.+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}+instance Functor (S z s) where+ fmap f (S g) = S (\k -> g (k . f))+instance Monad (S z s) where+ return = pure+ S g >>= f = S (\k -> g (\a -> unS (f a) k))+instance Applicative (S z s) where+ pure a = S (\k -> k a)+ (<*>) = ap+-- get :: S z s s+-- get = S (\k s -> k s s)+gets :: (s -> a) -> S z s a+gets f = S (\k s -> k (f s) s)+-- set :: s -> S z s ()+-- set s = S (\k _ -> k () s)+modify :: (s -> s) -> S z s ()+modify f = S (\k -> k () . f)+-- runS :: S z s a -> s -> ST z (a, s)+-- runS (S g) = g (\a s -> return (a,s))+evalS :: S z s a -> s -> ST z a+evalS (S g) = g ((return .) . const)+-- execS :: S z s a -> s -> ST z s+-- execS (S g) = g ((return .) . flip const)+st :: ST z a -> S z s a+st m = S (\k s-> do+ a <- m+ k a s)+store :: (MArray (A z) a (ST z))+ => (s -> Arr z a) -> Int -> a -> S z s ()+store f i x = do+ a <- gets f+ st ((a.=x) i)+fetch :: (MArray (A z) a (ST z))+ => (s -> Arr z a) -> Int -> S z s a+fetch f i = do+ a <- gets f+ st (a!:i)
compiler/GHC/CmmToAsm/CPrim.hs view
@@ -20,6 +20,7 @@ import GHC.Cmm.Type import GHC.Cmm.MachOp import GHC.Utils.Outputable+import GHC.Utils.Panic popCntLabel :: Width -> String popCntLabel w = "hs_popcnt" ++ pprWidth w
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -9,7 +9,6 @@ import GHC.Settings.Config ( cProjectName, cProjectVersion ) import GHC.Core ( Tickish(..) ) import GHC.Cmm.DebugBlock-import GHC.Driver.Session import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Platform@@ -18,6 +17,7 @@ import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types+import GHC.CmmToAsm.Config import Control.Arrow ( first ) import Control.Monad ( mfilter )@@ -32,23 +32,22 @@ import qualified GHC.Cmm.Dataflow.Collections as H -- | Generate DWARF/debug information-dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]+dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> IO (SDoc, UniqSupply)-dwarfGen _ _ us [] = return (empty, us)-dwarfGen df modLoc us blocks = do- let platform = targetPlatform df+dwarfGen _ _ us [] = return (empty, us)+dwarfGen config modLoc us blocks = do+ let platform = ncgPlatform config -- Convert debug data structures to DWARF info records- -- We strip out block information when running with -g0 or -g1. let procs = debugSplitProcs blocks stripBlocks dbg- | debugLevel df < 2 = dbg { dblBlocks = [] }- | otherwise = dbg+ | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }+ | otherwise = dbg compPath <- getCurrentDirectory let lowLabel = dblCLabel $ head procs highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs dwarfUnit = DwarfCompileUnit- { dwChildren = map (procToDwarf df) (map stripBlocks procs)+ { dwChildren = map (procToDwarf config) (map stripBlocks procs) , dwName = fromMaybe "" (ml_hs_file modLoc) , dwCompDir = addTrailingPathSeparator compPath , dwProducer = cProjectName ++ " " ++ cProjectVersion@@ -89,8 +88,8 @@ pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units- let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs- | otherwise = [DwarfARange lowLabel highLabel]+ let aranges' | ncgSplitSections config = map mkDwarfARange procs+ | otherwise = [DwarfARange lowLabel highLabel] let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')@@ -175,12 +174,12 @@ -} -- | Generate DWARF info for a procedure debug block-procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo-procToDwarf df prc+procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo+procToDwarf config prc = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc) , dwName = case dblSourceTick prc of Just s@SourceNote{} -> sourceName s- _otherwise -> showSDocDump df $ ppr $ dblLabel prc+ _otherwise -> show (dblLabel prc) , dwLabel = dblCLabel prc , dwParent = fmap mkAsmTempDieLabel $ mfilter goodParent@@ -190,9 +189,9 @@ goodParent a | a == dblCLabel prc = False -- Omit parent if it would be self-referential goodParent a | not (externallyVisibleCLabel a)- , debugLevel df < 2 = False- -- We strip block information when running -g0 or -g1, don't- -- refer to blocks in that case. Fixes #14894.+ , ncgDwarfStripBlockInfo config = False+ -- If we strip block information, don't refer to blocks.+ -- Fixes #14894. goodParent _ = True -- | Generate DWARF info for a block
compiler/GHC/CmmToAsm/Format.hs view
@@ -24,6 +24,7 @@ import GHC.Cmm import GHC.Utils.Outputable+import GHC.Utils.Panic -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator. You can change it
compiler/GHC/CmmToAsm/Instr.hs view
@@ -1,28 +1,18 @@ -module GHC.CmmToAsm.Instr (- RegUsage(..),- noUsage,- GenBasicBlock(..), blockId,- ListGraph(..),- NatCmm,- NatCmmDecl,- NatBasicBlock,- topInfoTable,- entryBlocks,- Instruction(..)-)-+module GHC.CmmToAsm.Instr+ ( Instruction(..)+ , RegUsage(..)+ , noUsage+ ) where import GHC.Prelude import GHC.Platform import GHC.Platform.Reg+import GHC.Utils.Outputable (SDoc) import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.Cmm hiding (topInfoTable) import GHC.CmmToAsm.Config @@ -46,51 +36,11 @@ noUsage :: RegUsage noUsage = RU [] [] --- Our flavours of the Cmm types--- Type synonyms for Cmm populated with native code-type NatCmm instr- = GenCmmGroup- RawCmmStatics- (LabelMap RawCmmStatics)- (ListGraph instr)--type NatCmmDecl statics instr- = GenCmmDecl- statics- (LabelMap RawCmmStatics)- (ListGraph instr)---type NatBasicBlock instr- = GenBasicBlock instr----- | Returns the info table associated with the CmmDecl's entry point,--- if any.-topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i-topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))- = mapLookup (blockId b) infos-topInfoTable _- = Nothing---- | Return the list of BlockIds in a CmmDecl that are entry points--- for this proc (i.e. they may be jumped to from outside this proc).-entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]-entryBlocks (CmmProc info _ _ (ListGraph code)) = entries- where- infos = mapKeys info- entries = case code of- [] -> infos- BasicBlock entry _ : _ -- first block is the entry point- | entry `elem` infos -> infos- | otherwise -> entry : infos-entryBlocks _ = []- -- | Common things that we can do with instructions, on all architectures. -- These are used by the shared parts of the native code generator, -- specifically the register allocators. ---class Instruction instr where+class Instruction instr where -- | Get the registers that are being used by this instruction. -- regUsage doesn't need to do any trickery for jumps and such.@@ -204,3 +154,6 @@ :: Platform -> Int -> [instr]++ -- | Pretty-print an instruction+ pprInstr :: Platform -> instr -> SDoc
compiler/GHC/CmmToAsm/Monad.hs view
@@ -16,7 +16,6 @@ NatM, -- instance Monad initNat,- initConfig, addImportNat, addNodeBetweenNat, addImmediateSuccessorNat,@@ -34,7 +33,7 @@ getNewRegPairNat, getPicBaseMaybeNat, getPicBaseNat,- getDynFlags,+ getCfgWeights, getModLoc, getFileId, getDebugBlock,@@ -53,6 +52,7 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -63,15 +63,14 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique )-import GHC.Driver.Session import GHC.Unit.Module import Control.Monad ( ap ) -import GHC.CmmToAsm.Instr-import GHC.Utils.Outputable (SDoc, pprPanic, ppr)-import GHC.Cmm (RawCmmDecl, RawCmmStatics)+import GHC.Utils.Outputable (SDoc, ppr)+import GHC.Utils.Panic (pprPanic) import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.CFG.Weight data NcgImpl statics instr jumpDest = NcgImpl { ncgConfig :: !NCGConfig,@@ -107,7 +106,6 @@ natm_delta :: Int, natm_imports :: [(CLabel)], natm_pic :: Maybe Reg,- natm_dflags :: DynFlags, natm_config :: NCGConfig, natm_this_module :: Module, natm_modloc :: ModLocation,@@ -127,17 +125,16 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->+mkNatM_State :: UniqSupply -> Int -> NCGConfig -> Module -> ModLocation -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State-mkNatM_State us delta dflags this_mod+mkNatM_State us delta config this_mod = \loc dwf dbg cfg -> NatM_State { natm_us = us , natm_delta = delta , natm_imports = [] , natm_pic = Nothing- , natm_dflags = dflags- , natm_config = initConfig dflags+ , natm_config = config , natm_this_module = this_mod , natm_modloc = loc , natm_fileid = dwf@@ -145,49 +142,6 @@ , natm_cfg = cfg } --- | Initialize the native code generator configuration from the DynFlags-initConfig :: DynFlags -> NCGConfig-initConfig dflags = NCGConfig- { ncgPlatform = targetPlatform dflags- , ncgProcAlignment = cmmProcAlignment dflags- , ncgDebugLevel = debugLevel dflags- , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags- , ncgPIC = positionIndependent dflags- , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags- , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags- , ncgSplitSections = gopt Opt_SplitSections dflags- , ncgRegsIterative = gopt Opt_RegsIterative dflags- , ncgAsmLinting = gopt Opt_DoAsmLinting dflags-- -- With -O1 and greater, the cmmSink pass does constant-folding, so- -- we don't need to do it again in the native code generator.- , ncgDoConstantFolding = optLevel dflags < 1-- , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags- , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags- , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags- , ncgBmiVersion = case platformArch (targetPlatform dflags) of- ArchX86_64 -> bmiVersion dflags- ArchX86 -> bmiVersion dflags- _ -> Nothing-- -- We Assume SSE1 and SSE2 operations are available on both- -- x86 and x86_64. Historically we didn't default to SSE2 and- -- SSE1 on x86, which results in defacto nondeterminism for how- -- rounding behaves in the associated x87 floating point instructions- -- because variations in the spill/fpu stack placement of arguments for- -- operations would change the precision and final result of what- -- would otherwise be the same expressions with respect to single or- -- double precision IEEE floating point computations.- , ncgSseVersion =- let v | sseVersion dflags < Just SSE2 = Just SSE2- | otherwise = sseVersion dflags- in case platformArch (targetPlatform dflags) of- ArchX86_64 -> v- ArchX86 -> v- _ -> Nothing- }- initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }@@ -234,13 +188,12 @@ case takeUniqFromSupply $ natm_us st of (uniq, us') -> (uniq, st {natm_us = us'}) -instance HasDynFlags NatM where- getDynFlags = NatM $ \ st -> (natm_dflags st, st)-- getDeltaNat :: NatM Int getDeltaNat = NatM $ \ st -> (natm_delta st, st) +-- | Get CFG edge weights+getCfgWeights :: NatM Weights+getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st) setDeltaNat :: Int -> NatM () setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})@@ -262,9 +215,8 @@ -- | Record that we added a block between `from` and `old`. addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () addNodeBetweenNat from between to- = do df <- getDynFlags- let jmpWeight = fromIntegral . uncondWeight .- cfgWeightInfo $ df+ = do weights <- getCfgWeights+ let jmpWeight = fromIntegral (uncondWeight weights) updateCfgNat (updateCfg jmpWeight from between to) where -- When transforming A -> B to A -> A' -> B@@ -284,8 +236,8 @@ -- block -> X to `succ` -> X addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () addImmediateSuccessorNat block succ = do- dflags <- getDynFlags- updateCfgNat (addImmediateSuccessor dflags block succ)+ weights <- getCfgWeights+ updateCfgNat (addImmediateSuccessor weights block succ) getBlockIdNat :: NatM BlockId getBlockIdNat
compiler/GHC/CmmToAsm/PIC.hs view
@@ -54,10 +54,10 @@ import qualified GHC.CmmToAsm.X86.Instr as X86 import GHC.Platform-import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Cmm.Dataflow.Collections@@ -68,6 +68,7 @@ import GHC.Unit.Module import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString
+ compiler/GHC/CmmToAsm/PPC.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for PPC architectures+module GHC.CmmToAsm.PPC+ ( ncgPPC+ )+where++import GHC.Prelude++import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types++import qualified GHC.CmmToAsm.PPC.Instr as PPC+import qualified GHC.CmmToAsm.PPC.Ppr as PPC+import qualified GHC.CmmToAsm.PPC.CodeGen as PPC+import qualified GHC.CmmToAsm.PPC.Regs as PPC+import qualified GHC.CmmToAsm.PPC.RegInfo as PPC++ncgPPC :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr PPC.JumpDest+ncgPPC config = NcgImpl+ { ncgConfig = config+ , cmmTopCodeGen = PPC.cmmTopCodeGen+ , generateJumpTableForInstr = PPC.generateJumpTableForInstr config+ , getJumpDestBlockId = PPC.getJumpDestBlockId+ , canShortcut = PPC.canShortcut+ , shortcutStatics = PPC.shortcutStatics+ , shortcutJump = PPC.shortcutJump+ , pprNatCmmDecl = PPC.pprNatCmmDecl config+ , maxSpillSlots = PPC.maxSpillSlots config+ , allocatableRegs = PPC.allocatableRegs platform+ , ncgAllocMoreStack = PPC.allocMoreStack platform+ , ncgExpandTop = id+ , ncgMakeFarBranches = PPC.makeFarBranches+ , extractUnwindPoints = const []+ , invertCondBranches = \_ _ -> id+ }+ where+ platform = ncgPlatform config++-- | Instruction instance for powerpc+instance Instruction PPC.Instr where+ regUsageOfInstr = PPC.regUsageOfInstr+ patchRegsOfInstr = PPC.patchRegsOfInstr+ isJumpishInstr = PPC.isJumpishInstr+ jumpDestsOfInstr = PPC.jumpDestsOfInstr+ patchJumpInstr = PPC.patchJumpInstr+ mkSpillInstr = PPC.mkSpillInstr+ mkLoadInstr = PPC.mkLoadInstr+ takeDeltaInstr = PPC.takeDeltaInstr+ isMetaInstr = PPC.isMetaInstr+ mkRegRegMoveInstr _ = PPC.mkRegRegMoveInstr+ takeRegRegMoveInstr = PPC.takeRegRegMoveInstr+ mkJumpInstr = PPC.mkJumpInstr+ mkStackAllocInstr = PPC.mkStackAllocInstr+ mkStackDeallocInstr = PPC.mkStackDeallocInstr+ pprInstr = PPC.pprInstr++
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -30,6 +30,7 @@ import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock ( DebugBlock(..) ) import GHC.CmmToAsm.Monad@@ -38,7 +39,6 @@ , getPicBaseMaybeNat, getPlatform, getConfig , getDebugBlock, getFileId )-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config@@ -62,6 +62,7 @@ -- The rest: import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad ( mapAndUnzipM, when ) import Data.Bits
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -12,23 +12,37 @@ #include "GhclibHsVersions.h" -module GHC.CmmToAsm.PPC.Instr (- archWordFormat,- RI(..),- Instr(..),- stackFrameHeaderSize,- maxSpillSlots,- allocMoreStack,- makeFarBranches-)-+module GHC.CmmToAsm.PPC.Instr+ ( Instr(..)+ , RI(..)+ , archWordFormat+ , stackFrameHeaderSize+ , maxSpillSlots+ , allocMoreStack+ , makeFarBranches+ , mkJumpInstr+ , mkLoadInstr+ , mkSpillInstr+ , patchJumpInstr+ , patchRegsOfInstr+ , jumpDestsOfInstr+ , takeRegRegMoveInstr+ , takeDeltaInstr+ , mkRegRegMoveInstr+ , mkStackAllocInstr+ , mkStackDeallocInstr+ , regUsageOfInstr+ , isJumpishInstr+ , isMetaInstr+ ) where import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config@@ -43,7 +57,7 @@ import GHC.Cmm.Info import GHC.Data.FastString import GHC.Cmm.CLabel-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply@@ -60,34 +74,16 @@ | otherwise = II64 --- | Instruction instance for powerpc-instance Instruction Instr where- regUsageOfInstr = ppc_regUsageOfInstr- patchRegsOfInstr = ppc_patchRegsOfInstr- isJumpishInstr = ppc_isJumpishInstr- jumpDestsOfInstr = ppc_jumpDestsOfInstr- patchJumpInstr = ppc_patchJumpInstr- mkSpillInstr = ppc_mkSpillInstr- mkLoadInstr = ppc_mkLoadInstr- takeDeltaInstr = ppc_takeDeltaInstr- isMetaInstr = ppc_isMetaInstr- mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr- takeRegRegMoveInstr = ppc_takeRegRegMoveInstr- mkJumpInstr = ppc_mkJumpInstr- mkStackAllocInstr = ppc_mkStackAllocInstr- mkStackDeallocInstr = ppc_mkStackDeallocInstr---ppc_mkStackAllocInstr :: Platform -> Int -> [Instr]-ppc_mkStackAllocInstr platform amount- = ppc_mkStackAllocInstr' platform (-amount)+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr platform amount+ = mkStackAllocInstr' platform (-amount) -ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr]-ppc_mkStackDeallocInstr platform amount- = ppc_mkStackAllocInstr' platform amount+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr platform amount+ = mkStackAllocInstr' platform amount -ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr]-ppc_mkStackAllocInstr' platform amount+mkStackAllocInstr' :: Platform -> Int -> [Instr]+mkStackAllocInstr' platform amount | fits16Bits amount = [ LD fmt r0 (AddrRegImm sp zero) , STU fmt r0 (AddrRegImm sp immAmount)@@ -313,8 +309,8 @@ -- The consequences of control flow transfers, as far as register -- allocation goes, are taken care of by the register allocator. ---ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage-ppc_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of LD _ reg addr -> usage (regAddr addr, [reg]) LDFAR _ reg addr -> usage (regAddr addr, [reg])@@ -406,8 +402,8 @@ -- | Apply a given mapping to all the register references in this -- instruction.-ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-ppc_patchRegsOfInstr instr env+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of LD fmt reg addr -> LD fmt (env reg) (fixAddr addr) LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr)@@ -497,8 +493,8 @@ -- | Checks whether this instruction is a jump/branch instruction. -- One that can change the flow of control in a way that the -- register allocator needs to worry about.-ppc_isJumpishInstr :: Instr -> Bool-ppc_isJumpishInstr instr+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of BCC{} -> True BCCFAR{} -> True@@ -512,8 +508,8 @@ -- | Checks whether this instruction is a jump/branch instruction. -- One that can change the flow of control in a way that the -- register allocator needs to worry about.-ppc_jumpDestsOfInstr :: Instr -> [BlockId]-ppc_jumpDestsOfInstr insn+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr insn = case insn of BCC _ id _ -> [id] BCCFAR _ id _ -> [id]@@ -524,8 +520,8 @@ -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join -- points.-ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-ppc_patchJumpInstr insn patchF+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr insn patchF = case insn of BCC cc id p -> BCC cc (patchF id) p BCCFAR cc id p -> BCCFAR cc (patchF id) p@@ -536,14 +532,14 @@ -- ----------------------------------------------------------------------------- -- | An instruction to spill a register into a spill slot.-ppc_mkSpillInstr+mkSpillInstr :: NCGConfig -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr config reg delta slot+mkSpillInstr config reg delta slot = let platform = ncgPlatform config off = spillSlotToOffset platform slot arch = platformArch platform@@ -561,14 +557,14 @@ in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) -ppc_mkLoadInstr+mkLoadInstr :: NCGConfig -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr config reg delta slot+mkLoadInstr config reg delta slot = let platform = ncgPlatform config off = spillSlotToOffset platform slot arch = platformArch platform@@ -629,21 +625,21 @@ -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta-ppc_takeDeltaInstr+takeDeltaInstr :: Instr -> Maybe Int -ppc_takeDeltaInstr instr+takeDeltaInstr instr = case instr of DELTA i -> Just i _ -> Nothing -ppc_isMetaInstr+isMetaInstr :: Instr -> Bool -ppc_isMetaInstr instr+isMetaInstr instr = case instr of COMMENT{} -> True LOCATION{} -> True@@ -655,29 +651,29 @@ -- | Copy the value in a register to another one. -- Must work for all register classes.-ppc_mkRegRegMoveInstr+mkRegRegMoveInstr :: Reg -> Reg -> Instr -ppc_mkRegRegMoveInstr src dst+mkRegRegMoveInstr src dst = MR dst src -- | Make an unconditional jump instruction.-ppc_mkJumpInstr+mkJumpInstr :: BlockId -> [Instr] -ppc_mkJumpInstr id+mkJumpInstr id = [BCC ALWAYS id Nothing] -- | Take the source and destination from this reg -> reg move instruction -- or Nothing if it's not one-ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)-ppc_takeRegRegMoveInstr _ = Nothing+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+takeRegRegMoveInstr (MR dst src) = Just (src,dst)+takeRegRegMoveInstr _ = Nothing -- ----------------------------------------------------------------------------- -- Making far branches
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -6,8 +6,11 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where+module GHC.CmmToAsm.PPC.Ppr+ ( pprNatCmmDecl+ , pprInstr+ )+where import GHC.Prelude @@ -15,12 +18,13 @@ import GHC.CmmToAsm.PPC.Instr import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.Ppr-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections@@ -34,7 +38,7 @@ import GHC.Platform import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Driver.Session (targetPlatform)+import GHC.Utils.Panic import Data.Word import Data.Int@@ -60,7 +64,7 @@ _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$- (if ncgDebugLevel config > 0+ (if ncgDwarfEnabled config then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl @@ -127,7 +131,7 @@ = maybe_infotable $$ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$- (if ncgDebugLevel config > 0+ (if ncgDwarfEnabled config then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty )@@ -184,11 +188,6 @@ -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where- ppr instr = sdocWithDynFlags $ \dflags ->- pprInstr (targetPlatform dflags) instr-- pprReg :: Reg -> SDoc pprReg r@@ -238,9 +237,8 @@ pprImm (ImmCLbl l) = ppr l pprImm (ImmIndex l i) = ppr l <> char '+' <> int i pprImm (ImmLit s) = s--pprImm (ImmFloat _) = text "naughty float immediate"-pprImm (ImmDouble _) = text "naughty double immediate"+pprImm (ImmFloat f) = float $ fromRational f+pprImm (ImmDouble d) = double $ fromRational d pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b pprImm (ImmConstantDiff a b) = pprImm a <> char '-'@@ -338,13 +336,8 @@ <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item FF32 (CmmFloat r _)- = let bs = floatToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs-- ppr_item FF64 (CmmFloat r _)- = let bs = doubleToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm] ppr_item _ _ = panic "PPC.Ppr.pprDataItem: no match"
compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -62,6 +62,7 @@ import GHC.Platform.Regs import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.Word ( Word8, Word16, Word32, Word64 )
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -9,9 +9,6 @@ ----------------------------------------------------------------------------- module GHC.CmmToAsm.Ppr (- castFloatToWord8Array,- castDoubleToWord8Array,- floatToBytes, doubleToBytes, pprASCII, pprString,@@ -29,6 +26,7 @@ import GHC.CmmToAsm.Config import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import qualified Data.Array.Unsafe as U ( castSTUArray )@@ -43,13 +41,13 @@ import GHC.Exts import GHC.Word -- -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray+-- ToDo: this code is currently shared between SPARC and LLVM.+-- Similar functions for (single precision) floats are+-- present in the SPARC backend only. We need to fix both+-- LLVM and SPARC. castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) castDoubleToWord8Array = U.castSTUArray@@ -61,19 +59,6 @@ -- ToDo: this stuff is very similar to the shenanigans in PprAbs, -- could they be merged?--floatToBytes :: Float -> [Int]-floatToBytes f- = runST (do- arr <- newArray_ ((0::Int),3)- writeArray arr 0 f- arr <- castFloatToWord8Array arr- i0 <- readArray arr 0- i1 <- readArray arr 1- i2 <- readArray arr 2- i3 <- readArray arr 3- return (map fromIntegral [i0,i1,i2,i3])- ) doubleToBytes :: Double -> [Int] doubleToBytes d
compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -17,11 +17,13 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.Data.Bag import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set@@ -44,7 +46,7 @@ -- | The top level of the graph coloring register allocator. regAlloc- :: (Outputable statics, Outputable instr, Instruction instr)+ :: (Outputable statics, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots.@@ -89,7 +91,6 @@ regAlloc_spin :: forall instr statics. (Instruction instr,- Outputable instr, Outputable statics) => NCGConfig -> Int -- ^ Number of solver iterations we've already performed.@@ -387,7 +388,7 @@ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph- :: (Outputable statics, Outputable instr, Instruction instr)+ :: (Outputable statics, Instruction instr) => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr @@ -412,7 +413,7 @@ = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg- $$ ppr code+ $$ pprLiveCmmDecl platform code $$ Color.dotGraph (\_ -> text "white") (trivColorable platform
compiler/GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -27,6 +27,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Utils.Monad (concatMapM)
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -24,6 +24,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.List
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -44,8 +44,10 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Utils.Monad.State import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Cmm.Dataflow.Collections
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -29,6 +29,7 @@ import GHC.Types.Unique.Set import GHC.Data.Graph.Directed (flattenSCCs) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Monad.State import GHC.CmmToAsm.CFG@@ -75,7 +76,7 @@ -- For each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) ---slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)+slurpSpillCostInfo :: forall instr statics. Instruction instr => Platform -> Maybe CFG -> LiveCmmDecl statics instr@@ -115,7 +116,7 @@ | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo"- $ text "no liveness information on instruction " <> ppr instr+ $ text "no liveness information on instruction " <> pprInstr platform instr countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis) = do
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -23,15 +23,17 @@ import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillCost import GHC.CmmToAsm.Reg.Graph.TrivColorable-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg.Class-import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types+ import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class -import GHC.Utils.Outputable import GHC.Types.Unique.FM import GHC.Types.Unique.Set+import GHC.Utils.Outputable import GHC.Utils.Monad.State -- | Holds interesting statistics from the register allocator.@@ -108,6 +110,7 @@ -- | Target platform , raPlatform :: !Platform }+ deriving (Functor) instance (Outputable statics, Outputable instr)
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -122,6 +122,7 @@ import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Platform.Reg import GHC.Cmm.BlockId@@ -134,6 +135,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.Maybe@@ -146,7 +148,7 @@ -- Allocate registers regAlloc- :: (Outputable instr, Instruction instr)+ :: Instruction instr => NCGConfig -> LiveCmmDecl statics instr -> UniqSM ( NatCmmDecl statics instr@@ -203,7 +205,7 @@ -- an entry in the block map or it is the first block. -- linearRegAlloc- :: (Outputable instr, Instruction instr)+ :: Instruction instr => NCGConfig -> [BlockId] -- ^ entry points -> BlockMap RegSet@@ -235,7 +237,7 @@ -- | Constraints on the instruction instances used by the -- linear allocator. type OutputableRegConstraint freeRegs instr =- (FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr)+ (FR freeRegs, Outputable freeRegs, Instruction instr) linearRegAlloc' :: OutputableRegConstraint freeRegs instr@@ -467,7 +469,10 @@ -- See Note [Unique Determinism and code generation] raInsn _ _ _ instr- = pprPanic "raInsn" (text "no match for:" <> ppr instr)+ = do+ platform <- getPlatform+ let instr' = fmap (pprInstr platform) instr+ pprPanic "raInsn" (text "no match for:" <> ppr instr') -- ToDo: what can we do about --@@ -763,7 +768,7 @@ -- the list of free registers and free stack slots. allocateRegsAndSpill- :: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr)+ :: forall freeRegs instr. (FR freeRegs, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns@@ -829,7 +834,7 @@ -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY-allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr) => Bool -> [VirtualReg] -> [instr]
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -18,12 +18,14 @@ import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+ import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Data.Graph.Directed-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set@@ -32,7 +34,7 @@ -- vregs are in the correct regs for its destination. -- joinToTargets- :: (FR freeRegs, Instruction instr, Outputable instr)+ :: (FR freeRegs, Instruction instr) => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. @@ -56,7 +58,7 @@ ----- joinToTargets'- :: (FR freeRegs, Instruction instr, Outputable instr)+ :: (FR freeRegs, Instruction instr) => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. @@ -110,7 +112,7 @@ -- this is the first time we jumped to this block.-joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)+joinToTargets_first :: (FR freeRegs, Instruction instr) => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId@@ -139,7 +141,7 @@ -- we've jumped to this block before-joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)+joinToTargets_again :: (Instruction instr, FR freeRegs) => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId
compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -10,6 +10,7 @@ import GHC.Platform.Reg import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.Word
compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs view
@@ -12,6 +12,7 @@ import GHC.Platform.Regs import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Data.Word
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -12,10 +12,11 @@ import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Types.Unique (Unique)+import GHC.CmmToAsm.Types import GHC.Types.Unique.FM-import GHC.Utils.Outputable +import GHC.Utils.Outputable import GHC.Utils.Monad.State -- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -26,6 +27,7 @@ mapBlockTop, mapBlockTopM, mapSCCM, mapGenBlockTop, mapGenBlockTopM,+ mapLiveCmmDecl, pprLiveCmmDecl, stripLive, stripLiveBlock, slurpConflicts,@@ -43,6 +45,8 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -52,6 +56,7 @@ import GHC.Data.Graph.Directed import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM@@ -105,6 +110,8 @@ -- | reload this reg from a stack slot | RELOAD Int Reg + deriving (Functor)+ instance Instruction instr => Instruction (InstrSR instr) where regUsageOfInstr platform i = case i of@@ -162,10 +169,13 @@ mkStackDeallocInstr platform amount = Instr <$> mkStackDeallocInstr platform amount + pprInstr platform i = ppr (fmap (pprInstr platform) i) + -- | An instruction with liveness information. data LiveInstr instr = LiveInstr (InstrSR instr) (Maybe Liveness)+ deriving (Functor) -- | Liveness information. -- The regs which die are ones which are no longer live in the *next* instruction@@ -493,7 +503,7 @@ -- | Strip away liveness information, yielding NatCmmDecl stripLive- :: (Outputable statics, Outputable instr, Instruction instr)+ :: (Outputable statics, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr@@ -501,7 +511,7 @@ stripLive config live = stripCmm live - where stripCmm :: (Outputable statics, Outputable instr, Instruction instr)+ where stripCmm :: (Outputable statics, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)@@ -518,8 +528,22 @@ -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc- = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)+ = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprLiveCmmDecl (ncgPlatform config) proc) ++-- | Pretty-print a `LiveCmmDecl`+pprLiveCmmDecl :: (Outputable statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc+pprLiveCmmDecl platform d = ppr (mapLiveCmmDecl (pprInstr platform) d)+++-- | Map over instruction type in `LiveCmmDecl`+mapLiveCmmDecl+ :: Outputable statics+ => (instr -> b)+ -> LiveCmmDecl statics instr+ -> LiveCmmDecl statics b+mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc+ -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -652,15 +676,16 @@ -- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information cmmTopLiveness- :: (Outputable instr, Instruction instr)- => Maybe CFG -> Platform+ :: Instruction instr+ => Maybe CFG+ -> Platform -> NatCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr) cmmTopLiveness cfg platform cmm = regLiveness platform $ natCmmTopToLive cfg cmm natCmmTopToLive- :: (Instruction instr, Outputable instr)+ :: Instruction instr => Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr @@ -746,7 +771,7 @@ -- regLiveness- :: (Outputable instr, Instruction instr)+ :: Instruction instr => Platform -> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)@@ -829,7 +854,7 @@ -- want for the next pass. -- computeLiveness- :: (Outputable instr, Instruction instr)+ :: Instruction instr => Platform -> [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers@@ -840,10 +865,11 @@ computeLiveness platform sccs = case checkIsReverseDependent sccs of Nothing -> livenessSCCs platform mapEmpty [] sccs- Just bad -> pprPanic "RegAlloc.Liveness.computeLiveness"+ Just bad -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs+ in pprPanic "RegAlloc.Liveness.computeLiveness" (vcat [ text "SCCs aren't in reverse dependent order" , text "bad blockId" <+> ppr bad- , ppr sccs])+ , ppr sccs']) livenessSCCs :: Instruction instr
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -28,6 +28,7 @@ import GHC.CmmToAsm.Format import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Platform
+ compiler/GHC/CmmToAsm/SPARC.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for SPARC architectures+module GHC.CmmToAsm.SPARC+ ( ncgSPARC+ )+where++import GHC.Prelude+import GHC.Utils.Panic++import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Instr++import qualified GHC.CmmToAsm.SPARC.Instr as SPARC+import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC+import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC+import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC+import qualified GHC.CmmToAsm.SPARC.Regs as SPARC+import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC+++ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest+ncgSPARC config = NcgImpl+ { ncgConfig = config+ , cmmTopCodeGen = SPARC.cmmTopCodeGen+ , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform+ , getJumpDestBlockId = SPARC.getJumpDestBlockId+ , canShortcut = SPARC.canShortcut+ , shortcutStatics = SPARC.shortcutStatics+ , shortcutJump = SPARC.shortcutJump+ , pprNatCmmDecl = SPARC.pprNatCmmDecl config+ , maxSpillSlots = SPARC.maxSpillSlots config+ , allocatableRegs = SPARC.allocatableRegs+ , ncgExpandTop = map SPARC.expandTop+ , ncgMakeFarBranches = const id+ , extractUnwindPoints = const []+ , invertCondBranches = \_ _ -> id+ -- Allocating more stack space for spilling isn't currently supported for the+ -- linear register allocator on SPARC, hence the panic below.+ , ncgAllocMoreStack = noAllocMoreStack+ }+ where+ platform = ncgPlatform config++ noAllocMoreStack amount _+ = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"+ ++ " If you are trying to compile SHA1.hs from the crypto library then this\n"+ ++ " is a known limitation in the linear allocator.\n"+ ++ "\n"+ ++ " Try enabling the graph colouring allocator with -fregs-graph instead."+ ++ " You can still file a bug report if you like.\n"+++-- | instance for sparc instruction set+instance Instruction SPARC.Instr where+ regUsageOfInstr = SPARC.regUsageOfInstr+ patchRegsOfInstr = SPARC.patchRegsOfInstr+ isJumpishInstr = SPARC.isJumpishInstr+ jumpDestsOfInstr = SPARC.jumpDestsOfInstr+ patchJumpInstr = SPARC.patchJumpInstr+ mkSpillInstr = SPARC.mkSpillInstr+ mkLoadInstr = SPARC.mkLoadInstr+ takeDeltaInstr = SPARC.takeDeltaInstr+ isMetaInstr = SPARC.isMetaInstr+ mkRegRegMoveInstr = SPARC.mkRegRegMoveInstr+ takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr+ mkJumpInstr = SPARC.mkJumpInstr+ pprInstr = const SPARC.pprInstr+ mkStackAllocInstr = panic "no sparc_mkStackAllocInstr"+ mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr"++
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -34,7 +34,7 @@ import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types import GHC.CmmToAsm.Format import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig ) import GHC.CmmToAsm.Config@@ -55,7 +55,7 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Data.OrdList-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import Control.Monad ( mapAndUnzipM )
compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs view
@@ -28,6 +28,7 @@ import GHC.Platform import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.OrdList --------------------------------------------------------------------------------
compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs view
@@ -22,6 +22,7 @@ import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic getCondCode :: CmmExpr -> NatM CondCode
compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs view
@@ -13,13 +13,14 @@ import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types import GHC.Cmm +import GHC.Platform.Reg import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.OrdList -- | Expand out synthetic instructions in this top level thing
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs view
@@ -27,7 +27,7 @@ import Control.Monad (liftM) import GHC.Data.OrdList-import GHC.Utils.Outputable+import GHC.Utils.Panic -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is.
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view
@@ -16,9 +16,7 @@ import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.Instr--- GHC.CmmToAsm.SPARC.Ppr() import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.Platform.Reg @@ -26,6 +24,7 @@ import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic -- | Code to assign a 64 bit value to memory. assignMem_I64Code
compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs view
@@ -10,11 +10,12 @@ import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types import GHC.Cmm import GHC.Utils.Outputable+import GHC.Utils.Panic -- | Enforce intra-block invariants.
compiler/GHC/CmmToAsm/SPARC/Imm.hs view
@@ -13,6 +13,7 @@ import GHC.Cmm.CLabel import GHC.Utils.Outputable+import GHC.Utils.Panic -- | An immediate value. -- Not all of these are directly representable by the machine.
compiler/GHC/CmmToAsm/SPARC/Instr.hs view
@@ -9,22 +9,31 @@ ----------------------------------------------------------------------------- #include "GhclibHsVersions.h" -module GHC.CmmToAsm.SPARC.Instr (- RI(..),- riZero,-- fpRelEA,- moveSp,-- isUnconditionalJump,-- Instr(..),- maxSpillSlots-)-+module GHC.CmmToAsm.SPARC.Instr+ ( Instr(..)+ , RI(..)+ , riZero+ , fpRelEA+ , moveSp+ , isUnconditionalJump+ , maxSpillSlots+ , patchRegsOfInstr+ , patchJumpInstr+ , mkRegRegMoveInstr+ , mkLoadInstr+ , mkSpillInstr+ , mkJumpInstr+ , takeDeltaInstr+ , isMetaInstr+ , isJumpishInstr+ , jumpDestsOfInstr+ , takeRegRegMoveInstr+ , regUsageOfInstr+ ) where import GHC.Prelude+import GHC.Platform import GHC.CmmToAsm.SPARC.Stack import GHC.CmmToAsm.SPARC.Imm@@ -33,19 +42,19 @@ import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.Reg.Target-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg.Class-import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) -import GHC.Cmm.CLabel+import GHC.Platform.Reg.Class+import GHC.Platform.Reg import GHC.Platform.Regs++import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Platform+import GHC.Utils.Panic -- | Register or immediate@@ -88,24 +97,6 @@ _ -> False --- | instance for sparc instruction set-instance Instruction Instr where- regUsageOfInstr = sparc_regUsageOfInstr- patchRegsOfInstr = sparc_patchRegsOfInstr- isJumpishInstr = sparc_isJumpishInstr- jumpDestsOfInstr = sparc_jumpDestsOfInstr- patchJumpInstr = sparc_patchJumpInstr- mkSpillInstr = sparc_mkSpillInstr- mkLoadInstr = sparc_mkLoadInstr- takeDeltaInstr = sparc_takeDeltaInstr- isMetaInstr = sparc_isMetaInstr- mkRegRegMoveInstr = sparc_mkRegRegMoveInstr- takeRegRegMoveInstr = sparc_takeRegRegMoveInstr- mkJumpInstr = sparc_mkJumpInstr- mkStackAllocInstr = panic "no sparc_mkStackAllocInstr"- mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr"-- -- | SPARC instruction set. -- Not complete. This is only the ones we need. --@@ -218,8 +209,8 @@ -- consequences of control flow transfers, as far as register -- allocation goes, are taken care of by the register allocator. ---sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage-sparc_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of LD _ addr reg -> usage (regAddr addr, [reg]) ST _ reg addr -> usage (reg : regAddr addr, [])@@ -285,8 +276,8 @@ -- | Apply a given mapping to tall the register references in this instruction.-sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-sparc_patchRegsOfInstr instr env = case instr of+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) @@ -337,8 +328,8 @@ ---------------------------------------------------------------------------------sparc_isJumpishInstr :: Instr -> Bool-sparc_isJumpishInstr instr+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of BI{} -> True BF{} -> True@@ -347,8 +338,8 @@ CALL{} -> True _ -> False -sparc_jumpDestsOfInstr :: Instr -> [BlockId]-sparc_jumpDestsOfInstr insn+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr insn = case insn of BI _ _ id -> [id] BF _ _ id -> [id]@@ -356,8 +347,8 @@ _ -> [] -sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-sparc_patchJumpInstr insn patchF+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr insn patchF = case insn of BI cc annul id -> BI cc annul (patchF id) BF cc annul id -> BF cc annul (patchF id)@@ -368,14 +359,14 @@ -------------------------------------------------------------------------------- -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill-sparc_mkSpillInstr+mkSpillInstr :: NCGConfig -> Reg -- ^ register to spill -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkSpillInstr config reg _ slot+mkSpillInstr config reg _ slot = let platform = ncgPlatform config off = spillSlotToOffset config slot off_w = 1 + (off `div` 4)@@ -388,14 +379,14 @@ -- | Make a spill reload instruction.-sparc_mkLoadInstr+mkLoadInstr :: NCGConfig -> Reg -- ^ register to load into -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkLoadInstr config reg _ slot+mkLoadInstr config reg _ slot = let platform = ncgPlatform config off = spillSlotToOffset config slot off_w = 1 + (off `div` 4)@@ -409,21 +400,21 @@ -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta-sparc_takeDeltaInstr+takeDeltaInstr :: Instr -> Maybe Int -sparc_takeDeltaInstr instr+takeDeltaInstr instr = case instr of DELTA i -> Just i _ -> Nothing -sparc_isMetaInstr+isMetaInstr :: Instr -> Bool -sparc_isMetaInstr instr+isMetaInstr instr = case instr of COMMENT{} -> True LDATA{} -> True@@ -437,13 +428,13 @@ -- floating point and integer regs. If we need to do that then we -- have to go via memory. ---sparc_mkRegRegMoveInstr+mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr -sparc_mkRegRegMoveInstr platform src dst+mkRegRegMoveInstr platform src dst | srcClass <- targetClassOfReg platform src , dstClass <- targetClassOfReg platform dst , srcClass == dstClass@@ -460,8 +451,8 @@ -- The register allocator attempts to eliminate reg->reg moves whenever it can, -- by assigning the src and dest temporaries to the same real register. ---sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-sparc_takeRegRegMoveInstr instr+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+takeRegRegMoveInstr instr = case instr of ADD False False src (RIReg src2) dst | g0 == src2 -> Just (src, dst)@@ -472,10 +463,10 @@ -- | Make an unconditional branch instruction.-sparc_mkJumpInstr+mkJumpInstr :: BlockId -> [Instr] -sparc_mkJumpInstr id+mkJumpInstr id = [BI ALWAYS False id , NOP] -- fill the branch delay slot.
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -9,7 +9,6 @@ ----------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-warn-orphans #-}- module GHC.CmmToAsm.SPARC.Ppr ( pprNatCmmDecl, pprBasicBlock,@@ -26,17 +25,24 @@ import GHC.Prelude +import Data.Word+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++import Control.Monad.ST+ import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Cond import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Ppr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Ppr() -- For Outputable instances@@ -47,6 +53,7 @@ import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Data.FastString @@ -367,6 +374,22 @@ ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"++floatToBytes :: Float -> [Int]+floatToBytes f+ = runST (do+ arr <- newArray_ ((0::Int),3)+ writeArray arr 0 f+ arr <- castFloatToWord8Array arr+ i0 <- readArray arr 0+ i1 <- readArray arr 1+ i2 <- readArray arr 2+ i3 <- readArray arr 3+ return (map fromIntegral [i0,i1,i2,i3])+ )++castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)+castFloatToWord8Array = U.castSTUArray -- | Pretty print an instruction.
compiler/GHC/CmmToAsm/SPARC/Regs.hs view
@@ -41,6 +41,7 @@ import GHC.Types.Unique import GHC.Utils.Outputable+import GHC.Utils.Panic {- The SPARC has 64 registers of interest; 32 integer registers and 32
compiler/GHC/CmmToAsm/SPARC/Stack.hs view
@@ -16,6 +16,7 @@ import GHC.CmmToAsm.Config import GHC.Utils.Outputable+import GHC.Utils.Panic -- | Get an AddrMode relative to the address in sp. -- This gives us a stack relative addressing mode for volatile
+ compiler/GHC/CmmToAsm/Types.hs view
@@ -0,0 +1,32 @@+module GHC.CmmToAsm.Types+ ( NatCmm+ , NatCmmDecl+ , NatBasicBlock+ , GenBasicBlock(..)+ , blockId+ , ListGraph(..)+ , RawCmmStatics+ , RawCmmDecl+ )+where++import GHC.Cmm.Dataflow.Label+import GHC.Cmm+++-- Our flavours of the Cmm types+-- Type synonyms for Cmm populated with native code+type NatCmm instr+ = GenCmmGroup+ RawCmmStatics+ (LabelMap RawCmmStatics)+ (ListGraph instr)++type NatCmmDecl statics instr+ = GenCmmDecl+ statics+ (LabelMap RawCmmStatics)+ (ListGraph instr)++type NatBasicBlock instr+ = GenBasicBlock instr
+ compiler/GHC/CmmToAsm/Utils.hs view
@@ -0,0 +1,33 @@+module GHC.CmmToAsm.Utils+ ( topInfoTable+ , entryBlocks+ )+where++import GHC.Prelude++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm hiding (topInfoTable)++-- | Returns the info table associated with the CmmDecl's entry point,+-- if any.+topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))+ = mapLookup (blockId b) infos+topInfoTable _+ = Nothing++-- | Return the list of BlockIds in a CmmDecl that are entry points+-- for this proc (i.e. they may be jumped to from outside this proc).+entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries+ where+ infos = mapKeys info+ entries = case code of+ [] -> infos+ BasicBlock entry _ : _ -- first block is the entry point+ | entry `elem` infos -> infos+ | otherwise -> entry : infos+entryBlocks _ = []
+ compiler/GHC/CmmToAsm/X86.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for x86 and x86-64 architectures+module GHC.CmmToAsm.X86+ ( ncgX86_64+ , ncgX86+ )+where++import GHC.Prelude++import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Types.Basic (Alignment)++import qualified GHC.CmmToAsm.X86.Instr as X86+import qualified GHC.CmmToAsm.X86.Ppr as X86+import qualified GHC.CmmToAsm.X86.CodeGen as X86+import qualified GHC.CmmToAsm.X86.Regs as X86++ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest+ncgX86 = ncgX86_64+++ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest+ncgX86_64 config = NcgImpl+ { ncgConfig = config+ , cmmTopCodeGen = X86.cmmTopCodeGen+ , generateJumpTableForInstr = X86.generateJumpTableForInstr config+ , getJumpDestBlockId = X86.getJumpDestBlockId+ , canShortcut = X86.canShortcut+ , shortcutStatics = X86.shortcutStatics+ , shortcutJump = X86.shortcutJump+ , pprNatCmmDecl = X86.pprNatCmmDecl config+ , maxSpillSlots = X86.maxSpillSlots config+ , allocatableRegs = X86.allocatableRegs platform+ , ncgAllocMoreStack = X86.allocMoreStack platform+ , ncgExpandTop = id+ , ncgMakeFarBranches = const id+ , extractUnwindPoints = X86.extractUnwindPoints+ , invertCondBranches = X86.invertCondBranches+ }+ where+ platform = ncgPlatform config++-- | Instruction instance for x86 instruction set.+instance Instruction X86.Instr where+ regUsageOfInstr = X86.regUsageOfInstr+ patchRegsOfInstr = X86.patchRegsOfInstr+ isJumpishInstr = X86.isJumpishInstr+ jumpDestsOfInstr = X86.jumpDestsOfInstr+ patchJumpInstr = X86.patchJumpInstr+ mkSpillInstr = X86.mkSpillInstr+ mkLoadInstr = X86.mkLoadInstr+ takeDeltaInstr = X86.takeDeltaInstr+ isMetaInstr = X86.isMetaInstr+ mkRegRegMoveInstr = X86.mkRegRegMoveInstr+ takeRegRegMoveInstr = X86.takeRegRegMoveInstr+ mkJumpInstr = X86.mkJumpInstr+ mkStackAllocInstr = X86.mkStackAllocInstr+ mkStackDeallocInstr = X86.mkStackDeallocInstr+ pprInstr = X86.pprInstr+
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -46,17 +46,18 @@ import GHC.Platform.Regs import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock ( DebugBlock(..), UnwindPoint(..), UnwindTable , UnwindExpr(UwReg), toUnwindExpr )-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat , getPicBaseMaybeNat, getDebugBlock, getFileId , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+ , getCfgWeights ) import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format@@ -83,6 +84,7 @@ import GHC.Types.ForeignCall ( CCallConv(..) ) import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Driver.Session import GHC.Utils.Misc@@ -227,7 +229,7 @@ addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do config <- getConfig- if ncgDebugLevel config >= 1+ if ncgDwarfUnwindings config then do lbl <- mkAsmTempLabel <$> getUniqueM let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) return $ toOL [ instr, UNWIND lbl unwind ]@@ -287,11 +289,11 @@ Instead we now return the new basic block if a statement causes a change in the current block and use the block for all following statements. -For this reason genCCall is also split into two parts.-One for calls which *won't* change the basic blocks in-which successive instructions will be placed.-A different one for calls which *are* known to change the-basic block.+For this reason genCCall is also split into two parts. One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings). A different one for calls+which *are* known to change the basic block. -} @@ -1028,6 +1030,9 @@ tmp. This is likely to be better, because the reg alloc can eliminate this reg->reg move here (it won't eliminate the other one, because the move is into the fixed %ecx).+ * in the case of C calls the use of ecx here can interfere with arguments.+ We avoid this with the hack described in Note [Evaluate C-call+ arguments before placing in destination registers] -} shift_code width instr x y{-amount-} = do x_code <- getAnyReg x@@ -2022,6 +2027,7 @@ arg <- getNewRegNat format arg_code <- getAnyReg n platform <- ncgPlatform <$> getConfig+ let dst_r = getRegisterReg platform (CmmLocal dst) (code, lbl) <- op_code dst_r arg amode return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)@@ -2101,10 +2107,10 @@ -- bid -> lbl2 -- bid -> lbl1 -> lbl2 -- We also changes edges originating at bid to start at lbl2 instead.- dflags <- getDynFlags+ weights <- getCfgWeights updateCfgNat (addWeightEdge bid lbl1 110 . addWeightEdge lbl1 lbl2 110 .- addImmediateSuccessor dflags bid lbl2)+ addImmediateSuccessor weights bid lbl2) -- The following instruction sequence corresponds to the pseudo-code --@@ -2667,9 +2673,12 @@ return code _ -> panic "genCCall: Wrong number of arguments/results for imul2" - _ -> if is32Bit- then genCCall32' target dest_regs args- else genCCall64' target dest_regs args+ _ -> do+ (instrs0, args') <- evalArgs bid args+ instrs1 <- if is32Bit+ then genCCall32' target dest_regs args'+ else genCCall64' target dest_regs args'+ return (instrs0 `appOL` instrs1) where divOp1 platform signed width results [arg_x, arg_y] = divOp platform signed width results Nothing arg_x arg_y@@ -2731,6 +2740,83 @@ return code addSubIntC _ _ _ _ _ _ _ _ = panic "genCCall: Wrong number of arguments/results for addSubIntC"++{-+Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++ (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++ mov _s2hp, $arg1 # place first argument+ mov _s2hq, $arg2 # place second argument++ # Compute 1 << _s2hz+ mov _s2hz, %rcx+ shl %cl, $tmp++ # Compute (_s2hw | (1 << _s2hz))+ mov _s2hw, $arg3+ or $tmp, $arg3++ # Perform the call+ call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call) since outOfLineCmmOp produces the call via+(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up+back in genCCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+ | any mightContainMachOp actuals = do+ regs_blks <- mapM evalArg actuals+ return (concatOL $ map fst regs_blks, map snd regs_blks)+ | otherwise = return (nilOL, actuals)+ where+ mightContainMachOp (CmmReg _) = False+ mightContainMachOp (CmmRegOff _ _) = False+ mightContainMachOp (CmmLit _) = False+ mightContainMachOp _ = True++ evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+ evalArg actual = do+ platform <- getPlatform+ lreg <- newLocalReg $ cmmExprType platform actual+ (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+ -- The above assignment shouldn't change the current block+ MASSERT(isNothing bid1)+ return (instrs, CmmReg $ CmmLocal lreg)++ newLocalReg :: CmmType -> NatM LocalReg+ newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty -- Note [DIV/IDIV for bytes] --
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -9,10 +9,31 @@ ----------------------------------------------------------------------------- module GHC.CmmToAsm.X86.Instr- ( Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..)- , getJumpDestBlockId, canShortcut, shortcutStatics- , shortcutJump, allocMoreStack- , maxSpillSlots, archWordFormat+ ( Instr(..)+ , Operand(..)+ , PrefetchVariant(..)+ , JumpDest(..)+ , getJumpDestBlockId+ , canShortcut+ , shortcutStatics+ , shortcutJump+ , allocMoreStack+ , maxSpillSlots+ , archWordFormat+ , takeRegRegMoveInstr+ , regUsageOfInstr+ , takeDeltaInstr+ , mkLoadInstr+ , mkJumpInstr+ , mkStackAllocInstr+ , mkStackDeallocInstr+ , mkSpillInstr+ , mkRegRegMoveInstr+ , jumpDestsOfInstr+ , patchRegsOfInstr+ , patchJumpInstr+ , isMetaInstr+ , isJumpishInstr ) where @@ -22,8 +43,10 @@ import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target@@ -36,13 +59,14 @@ import GHC.Cmm import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform -import GHC.Types.Basic (Alignment) import GHC.Cmm.CLabel import GHC.Types.Unique.Set import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable) import Control.Monad@@ -55,24 +79,6 @@ | is32Bit = II32 | otherwise = II64 --- | Instruction instance for x86 instruction set.-instance Instruction Instr where- regUsageOfInstr = x86_regUsageOfInstr- patchRegsOfInstr = x86_patchRegsOfInstr- isJumpishInstr = x86_isJumpishInstr- jumpDestsOfInstr = x86_jumpDestsOfInstr- patchJumpInstr = x86_patchJumpInstr- mkSpillInstr = x86_mkSpillInstr- mkLoadInstr = x86_mkLoadInstr- takeDeltaInstr = x86_takeDeltaInstr- isMetaInstr = x86_isMetaInstr- mkRegRegMoveInstr = x86_mkRegRegMoveInstr- takeRegRegMoveInstr = x86_takeRegRegMoveInstr- mkJumpInstr = x86_mkJumpInstr- mkStackAllocInstr = x86_mkStackAllocInstr- mkStackDeallocInstr = x86_mkStackDeallocInstr-- -- ----------------------------------------------------------------------------- -- Intel x86 instructions @@ -344,8 +350,8 @@ -- | Returns which registers are read and written as a (read, written) -- pair.-x86_regUsageOfInstr :: Platform -> Instr -> RegUsage-x86_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of MOV _ src dst -> usageRW src dst CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst]@@ -429,7 +435,7 @@ -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) []- LOCK i -> x86_regUsageOfInstr platform i+ LOCK i -> regUsageOfInstr platform i XADD _ src dst -> usageMM src dst CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) XCHG _ src dst -> usageMM src (OpReg dst)@@ -513,8 +519,8 @@ -- | Applies the supplied function to all registers in instructions. -- Typically used to change virtual registers to real registers.-x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-x86_patchRegsOfInstr instr env+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of MOV fmt src dst -> patch2 (MOV fmt) src dst CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst)@@ -589,7 +595,7 @@ PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) - LOCK i -> LOCK (x86_patchRegsOfInstr i env)+ LOCK i -> LOCK (patchRegsOfInstr i env) XADD fmt src dst -> patch2 (XADD fmt) src dst CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst XCHG fmt src dst -> XCHG fmt (patchOp src) (env dst)@@ -620,10 +626,10 @@ ---------------------------------------------------------------------------------x86_isJumpishInstr+isJumpishInstr :: Instr -> Bool -x86_isJumpishInstr instr+isJumpishInstr instr = case instr of JMP{} -> True JXX{} -> True@@ -633,21 +639,21 @@ _ -> False -x86_jumpDestsOfInstr+jumpDestsOfInstr :: Instr -> [BlockId] -x86_jumpDestsOfInstr insn+jumpDestsOfInstr insn = case insn of JXX _ id -> [id] JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids] _ -> [] -x86_patchJumpInstr+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -x86_patchJumpInstr insn patchF+patchJumpInstr insn patchF = case insn of JXX cc id -> JXX cc (patchF id) JMP_TBL op ids section lbl@@ -663,14 +669,14 @@ -- ----------------------------------------------------------------------------- -- | Make a spill instruction.-x86_mkSpillInstr+mkSpillInstr :: NCGConfig -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkSpillInstr config reg delta slot+mkSpillInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of@@ -682,21 +688,21 @@ is32Bit = target32Bit platform -- | Make a spill reload instruction.-x86_mkLoadInstr+mkLoadInstr :: NCGConfig -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkLoadInstr config reg delta slot+mkLoadInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of RcInteger -> MOV (archWordFormat is32Bit) (OpAddr (spRel platform off)) (OpReg reg) RcDouble -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)- _ -> panic "X86.x86_mkLoadInstr"+ _ -> panic "X86.mkLoadInstr" where platform = ncgPlatform config is32Bit = target32Bit platform @@ -724,21 +730,21 @@ -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta-x86_takeDeltaInstr+takeDeltaInstr :: Instr -> Maybe Int -x86_takeDeltaInstr instr+takeDeltaInstr instr = case instr of DELTA i -> Just i _ -> Nothing -x86_isMetaInstr+isMetaInstr :: Instr -> Bool -x86_isMetaInstr instr+isMetaInstr instr = case instr of COMMENT{} -> True LOCATION{} -> True@@ -756,18 +762,18 @@ -- floating point and integer regs. If we need to do that then we -- have to go via memory. ---x86_mkRegRegMoveInstr+mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr -x86_mkRegRegMoveInstr platform src dst+mkRegRegMoveInstr platform src dst = case targetClassOfReg platform src of RcInteger -> case platformArch platform of ArchX86 -> MOV II32 (OpReg src) (OpReg dst) ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)- _ -> panic "x86_mkRegRegMoveInstr: Bad arch"+ _ -> panic "X86.mkRegRegMoveInstr: Bad arch" RcDouble -> MOV FF64 (OpReg src) (OpReg dst) -- this code is the lie we tell ourselves because both float and double -- use the same register class.on x86_64 and x86 32bit with SSE2,@@ -778,22 +784,22 @@ -- The register allocator attempts to eliminate reg->reg moves whenever it can, -- by assigning the src and dest temporaries to the same real register. ---x86_takeRegRegMoveInstr+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))+takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) = Just (r1,r2) -x86_takeRegRegMoveInstr _ = Nothing+takeRegRegMoveInstr _ = Nothing -- | Make an unconditional branch instruction.-x86_mkJumpInstr+mkJumpInstr :: BlockId -> [Instr] -x86_mkJumpInstr id+mkJumpInstr id = [JXX ALWAYS id] -- Note [Windows stack layout]@@ -836,11 +842,11 @@ _ -> False _ -> False -x86_mkStackAllocInstr+mkStackAllocInstr :: Platform -> Int -> [Instr]-x86_mkStackAllocInstr platform amount+mkStackAllocInstr platform amount = case platformOS platform of OSMinGW32 -> -- These will clobber AX but this should be ok because@@ -879,22 +885,22 @@ [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) , TEST II64 (OpReg rsp) (OpReg rsp) ]- _ -> panic "x86_mkStackAllocInstr"+ _ -> panic "X86.mkStackAllocInstr" _ -> case platformArch platform of ArchX86 -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ] ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]- _ -> panic "x86_mkStackAllocInstr"+ _ -> panic "X86.mkStackAllocInstr" -x86_mkStackDeallocInstr+mkStackDeallocInstr :: Platform -> Int -> [Instr]-x86_mkStackDeallocInstr platform amount+mkStackDeallocInstr platform amount = case platformArch platform of ArchX86 -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)] ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]- _ -> panic "x86_mkStackDeallocInstr"+ _ -> panic "X86.mkStackDeallocInstr" --@@ -975,7 +981,7 @@ insert_dealloc insn r = case insn of JMP _ _ -> dealloc ++ (insn : r) JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"- _other -> x86_patchJumpInstr insn retarget : r+ _other -> patchJumpInstr insn retarget : r where retarget b = fromMaybe b (mapLookup b new_blockmap) new_code = concatMap insert_stack_insns code
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -8,7 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.CmmToAsm.X86.Ppr ( pprNatCmmDecl, pprData,@@ -24,27 +23,30 @@ import GHC.Prelude +import GHC.Platform+import GHC.Platform.Reg+ import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config import GHC.CmmToAsm.Format-import GHC.Platform.Reg+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils import GHC.CmmToAsm.Ppr -+import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)-import GHC.Driver.Session-import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.BlockId import GHC.Cmm.CLabel++import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways )-import GHC.Platform+ import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import Data.Word import Data.Bits@@ -89,7 +91,7 @@ pprProcAlignment config $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$- (if ncgDebugLevel config > 0+ (if ncgDwarfEnabled config then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl @@ -123,7 +125,7 @@ = maybe_infotable $ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$- (if ncgDebugLevel config > 0+ (if ncgDwarfEnabled config then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty )@@ -138,7 +140,7 @@ vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$- (if ncgDebugLevel config > 0+ (if ncgDwarfEnabled config then ppr (mkAsmTempEndLabel infoLbl) <> char ':' else empty )@@ -269,11 +271,6 @@ log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -instance Outputable Instr where- ppr instr = sdocWithDynFlags $ \dflags ->- pprInstr (targetPlatform dflags) instr-- pprReg :: Platform -> Format -> Reg -> SDoc pprReg platform f r = case r of@@ -426,9 +423,8 @@ pprImm (ImmCLbl l) = ppr l pprImm (ImmIndex l i) = ppr l <> char '+' <> int i pprImm (ImmLit s) = s--pprImm (ImmFloat _) = text "naughty float immediate"-pprImm (ImmDouble _) = text "naughty double immediate"+pprImm (ImmFloat f) = float $ fromRational f+pprImm (ImmDouble d) = double $ fromRational d pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b pprImm (ImmConstantDiff a b) = pprImm a <> char '-'@@ -517,13 +513,8 @@ ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] - ppr_item FF32 (CmmFloat r _)- = let bs = floatToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs-- ppr_item FF64 (CmmFloat r _)- = let bs = doubleToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm] ppr_item II64 _ = case platformOS platform of@@ -560,9 +551,6 @@ text "\t.long\t0"] _ -> [text "\t.quad\t" <> pprImm imm]-- ppr_item _ _- = panic "X86.Ppr.ppr_item: no match" asmComment :: SDoc -> SDoc
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -14,6 +14,7 @@ import GHC.Platform.Reg import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -58,6 +58,7 @@ import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import qualified Data.Array as A
compiler/GHC/CmmToC.hs view
@@ -43,8 +43,10 @@ -- Utils import GHC.CmmToAsm.CPrim import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM
compiler/GHC/CmmToLlvm.hs view
@@ -34,6 +34,7 @@ import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream
compiler/GHC/CmmToLlvm/Base.hs view
@@ -498,7 +498,7 @@ dflags <- getDynFlags platform <- getPlatform let sdoc = pprCLabel_LLVM platform lbl- str = Outp.renderWithStyle+ str = Outp.renderWithContext (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)) sdoc return (fsLit str)
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -10,6 +10,9 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Regs@@ -25,11 +28,11 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections -import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall-import GHC.Utils.Outputable hiding (panic, pprPanic)-import qualified GHC.Utils.Outputable as Outputable+import GHC.Utils.Outputable+import GHC.Utils.Panic (assertPanic)+import qualified GHC.Utils.Panic as Panic import GHC.Platform import GHC.Data.OrdList import GHC.Types.Unique.Supply@@ -1563,7 +1566,7 @@ -- Error. Continue anyway so we can debug the generated ll file. dflags <- getDynFlags let style = mkCodeStyle CStyle- toString doc = renderWithStyle (initSDocContext dflags style) doc+ toString doc = renderWithContext (initSDocContext dflags style) doc cmmToStr = (lines . toString . PprCmm.pprExpr platform) statement $ Comment $ map fsLit $ cmmToStr x statement $ Comment $ map fsLit $ cmmToStr y@@ -2001,10 +2004,10 @@ -- | Error functions panic :: HasCallStack => String -> a-panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s+panic s = Panic.panic $ "GHC.CmmToLlvm.CodeGen." ++ s pprPanic :: HasCallStack => String -> SDoc -> a-pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d+pprPanic s d = Panic.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d -- | Returns TBAA meta data by unique
compiler/GHC/CmmToLlvm/Data.hs view
@@ -20,7 +20,7 @@ import GHC.Platform import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Panic import qualified Data.ByteString as BS -- ----------------------------------------------------------------------------
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -11,6 +11,8 @@ import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Data
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -18,7 +18,7 @@ import GHC.Cmm.Expr import GHC.Platform import GHC.Data.FastString-import GHC.Utils.Outputable ( panic )+import GHC.Utils.Panic ( panic ) import GHC.Types.Unique -- | Get the LlvmVar function variable storing the real register
compiler/GHC/Core/Opt/CSE.hs view
@@ -32,6 +32,7 @@ import GHC.Types.Basic import GHC.Core.Map import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn )+import GHC.Utils.Panic import Data.List ( mapAccumL ) {-
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -35,6 +35,7 @@ import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Maybe ( isJust ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
− compiler/GHC/Core/Opt/Driver.hs
@@ -1,1041 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[SimplCore]{Driver for simplifying @Core@ programs}--}--{-# LANGUAGE CPP #-}--module GHC.Core.Opt.Driver ( core2core, simplifyExpr ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Driver.Session-import GHC.Core-import GHC.Driver.Types-import GHC.Core.Opt.CSE ( cseProgram )-import GHC.Core.Rules ( mkRuleBase, unionRuleBase,- extendRuleBaseList, ruleCheckProgram, addRuleInfo,- getRules, initRuleOpts )-import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )-import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )-import GHC.Types.Id.Info-import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )-import GHC.Core.Utils ( mkTicks, stripTicksTop )-import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult,- lintAnnots )-import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules )-import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Opt.Monad-import qualified GHC.Utils.Error as Err-import GHC.Core.Opt.FloatIn ( floatInwards )-import GHC.Core.Opt.FloatOut ( floatOutwards )-import GHC.Core.FamInstEnv-import GHC.Types.Id-import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) )-import GHC.Types.Basic-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Core.Opt.LiberateCase ( liberateCase )-import GHC.Core.Opt.StaticArgs ( doStaticArgs )-import GHC.Core.Opt.Specialise ( specProgram)-import GHC.Core.Opt.SpecConstr ( specConstrProgram)-import GHC.Core.Opt.DmdAnal ( dmdAnalProgram )-import GHC.Core.Opt.CprAnal ( cprAnalProgram )-import GHC.Core.Opt.CallArity ( callArityAnalProgram )-import GHC.Core.Opt.Exitify ( exitifyProgram )-import GHC.Core.Opt.WorkWrap ( wwTopBinds )-import GHC.Types.SrcLoc-import GHC.Utils.Misc-import GHC.Unit.Module.Env-import GHC.Driver.Plugins ( withPlugins, installCoreToDos )-import GHC.Runtime.Loader -- ( initializePlugins )--import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )-import GHC.Types.Unique.FM-import GHC.Utils.Outputable-import Control.Monad-import qualified GHC.LanguageExtensions as LangExt-{--************************************************************************-* *-\subsection{The driver for the simplifier}-* *-************************************************************************--}--core2core :: HscEnv -> ModGuts -> IO ModGuts-core2core hsc_env guts@(ModGuts { mg_module = mod- , mg_loc = loc- , mg_deps = deps- , mg_rdr_env = rdr_env })- = do { -- make sure all plugins are loaded-- ; let builtin_passes = getCoreToDo dflags- orph_mods = mkModuleSet (mod : dep_orphs deps)- uniq_mask = 's'- ;- ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod- orph_mods print_unqual loc $- do { hsc_env' <- getHscEnv- ; dflags' <- liftIO $ initializePlugins hsc_env'- (hsc_dflags hsc_env')- ; all_passes <- withPlugins dflags'- installCoreToDos- builtin_passes- ; runCorePasses all_passes guts }-- ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats- "Grand total simplifier statistics"- FormatText- (pprSimplCount stats)-- ; return guts2 }- where- dflags = hsc_dflags hsc_env- home_pkg_rules = hptRules hsc_env (dep_mods deps)- hpt_rule_base = mkRuleBase home_pkg_rules- print_unqual = mkPrintUnqualified dflags rdr_env- -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.- -- This is very convienent for the users of the monad (e.g. plugins do not have to- -- consume the ModGuts to find the module) but somewhat ugly because mg_module may- -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which- -- would mean our cached value would go out of date.--{--************************************************************************-* *- Generating the main optimisation pipeline-* *-************************************************************************--}--getCoreToDo :: DynFlags -> [CoreToDo]-getCoreToDo dflags- = flatten_todos core_todo- where- opt_level = optLevel dflags- phases = simplPhases dflags- max_iter = maxSimplIterations dflags- rule_check = ruleCheck dflags- call_arity = gopt Opt_CallArity dflags- exitification = gopt Opt_Exitification dflags- strictness = gopt Opt_Strictness dflags- full_laziness = gopt Opt_FullLaziness dflags- do_specialise = gopt Opt_Specialise dflags- do_float_in = gopt Opt_FloatIn dflags- cse = gopt Opt_CSE dflags- spec_constr = gopt Opt_SpecConstr dflags- liberate_case = gopt Opt_LiberateCase dflags- late_dmd_anal = gopt Opt_LateDmdAnal dflags- late_specialise = gopt Opt_LateSpecialise dflags- static_args = gopt Opt_StaticArgumentTransformation dflags- rules_on = gopt Opt_EnableRewriteRules dflags- eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags- ww_on = gopt Opt_WorkerWrapper dflags- static_ptrs = xopt LangExt.StaticPointers dflags-- maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)-- maybe_strictness_before (Phase phase)- | phase `elem` strictnessBefore dflags = CoreDoDemand- maybe_strictness_before _- = CoreDoNothing-- base_mode = SimplMode { sm_phase = panic "base_mode"- , sm_names = []- , sm_dflags = dflags- , sm_rules = rules_on- , sm_eta_expand = eta_expand_on- , sm_inline = True- , sm_case_case = True }-- simpl_phase phase name iter- = CoreDoPasses- $ [ maybe_strictness_before phase- , CoreDoSimplify iter- (base_mode { sm_phase = phase- , sm_names = [name] })-- , maybe_rule_check phase ]-- -- Run GHC's internal simplification phase, after all rules have run.- -- See Note [Compiler phases] in GHC.Types.Basic- simplify name = simpl_phase FinalPhase name max_iter-- -- initial simplify: mk specialiser happy: minimum effort please- simpl_gently = CoreDoSimplify max_iter- (base_mode { sm_phase = InitialPhase- , sm_names = ["Gentle"]- , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase]- , sm_inline = True- -- See Note [Inline in InitialPhase]- , sm_case_case = False })- -- Don't do case-of-case transformations.- -- This makes full laziness work better-- dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]- else [CoreDoDemand,CoreDoCpr]--- demand_analyser = (CoreDoPasses (- dmd_cpr_ww ++- [simplify "post-worker-wrapper"]- ))-- -- Static forms are moved to the top level with the FloatOut pass.- -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.- static_ptrs_float_outwards =- runWhen static_ptrs $ CoreDoPasses- [ simpl_gently -- Float Out can't handle type lets (sometimes created- -- by simpleOptPgm via mkParallelBindings)- , CoreDoFloatOutwards FloatOutSwitches- { floatOutLambdas = Just 0- , floatOutConstants = True- , floatOutOverSatApps = False- , floatToTopLevelOnly = True- }- ]-- core_todo =- if opt_level == 0 then- [ static_ptrs_float_outwards,- CoreDoSimplify max_iter- (base_mode { sm_phase = FinalPhase- , sm_names = ["Non-opt simplification"] })- ]-- else {- opt_level >= 1 -} [-- -- We want to do the static argument transform before full laziness as it- -- may expose extra opportunities to float things outwards. However, to fix- -- up the output of the transformation we need at do at least one simplify- -- after this before anything else- runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),-- -- initial simplify: mk specialiser happy: minimum effort please- simpl_gently,-- -- Specialisation is best done before full laziness- -- so that overloaded functions have all their dictionary lambdas manifest- runWhen do_specialise CoreDoSpecialising,-- if full_laziness then- CoreDoFloatOutwards FloatOutSwitches {- floatOutLambdas = Just 0,- floatOutConstants = True,- floatOutOverSatApps = False,- floatToTopLevelOnly = False }- -- Was: gentleFloatOutSwitches- --- -- I have no idea why, but not floating constants to- -- top level is very bad in some cases.- --- -- Notably: p_ident in spectral/rewrite- -- Changing from "gentle" to "constantsOnly"- -- improved rewrite's allocation by 19%, and- -- made 0.0% difference to any other nofib- -- benchmark- --- -- Not doing floatOutOverSatApps yet, we'll do- -- that later on when we've had a chance to get more- -- accurate arity information. In fact it makes no- -- difference at all to performance if we do it here,- -- but maybe we save some unnecessary to-and-fro in- -- the simplifier.- else- -- Even with full laziness turned off, we still need to float static- -- forms to the top level. See Note [Grand plan for static forms] in- -- GHC.Iface.Tidy.StaticPtrTable.- static_ptrs_float_outwards,-- -- Run the simplier phases 2,1,0 to allow rewrite rules to fire- CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter- | phase <- [phases, phases-1 .. 1] ],- simpl_phase (Phase 0) "main" (max max_iter 3),- -- Phase 0: allow all Ids to be inlined now- -- This gets foldr inlined before strictness analysis-- -- At least 3 iterations because otherwise we land up with- -- huge dead expressions because of an infelicity in the- -- simplifier.- -- let k = BIG in foldr k z xs- -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs- -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs- -- Don't stop now!-- runWhen do_float_in CoreDoFloatInwards,- -- Run float-inwards immediately before the strictness analyser- -- Doing so pushes bindings nearer their use site and hence makes- -- them more likely to be strict. These bindings might only show- -- up after the inlining from simplification. Example in fulsom,- -- Csg.calc, where an arg of timesDouble thereby becomes strict.-- runWhen call_arity $ CoreDoPasses- [ CoreDoCallArity- , simplify "post-call-arity"- ],-- -- Strictness analysis- runWhen strictness demand_analyser,-- runWhen exitification CoreDoExitify,- -- See note [Placement of the exitification pass]-- runWhen full_laziness $- CoreDoFloatOutwards FloatOutSwitches {- floatOutLambdas = floatLamArgs dflags,- floatOutConstants = True,- floatOutOverSatApps = True,- floatToTopLevelOnly = False },- -- nofib/spectral/hartel/wang doubles in speed if you- -- do full laziness late in the day. It only happens- -- after fusion and other stuff, so the early pass doesn't- -- catch it. For the record, the redex is- -- f_el22 (f_el21 r_midblock)--- runWhen cse CoreCSE,- -- We want CSE to follow the final full-laziness pass, because it may- -- succeed in commoning up things floated out by full laziness.- -- CSE used to rely on the no-shadowing invariant, but it doesn't any more-- runWhen do_float_in CoreDoFloatInwards,-- maybe_rule_check FinalPhase,-- -- Case-liberation for -O2. This should be after- -- strictness analysis and the simplification which follows it.- runWhen liberate_case (CoreDoPasses [- CoreLiberateCase,- simplify "post-liberate-case"- ]), -- Run the simplifier after LiberateCase to vastly- -- reduce the possibility of shadowing- -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr-- runWhen spec_constr CoreDoSpecConstr,-- maybe_rule_check FinalPhase,-- runWhen late_specialise- (CoreDoPasses [ CoreDoSpecialising- , simplify "post-late-spec"]),-- -- LiberateCase can yield new CSE opportunities because it peels- -- off one layer of a recursive function (concretely, I saw this- -- in wheel-sieve1), and I'm guessing that SpecConstr can too- -- And CSE is a very cheap pass. So it seems worth doing here.- runWhen ((liberate_case || spec_constr) && cse) CoreCSE,-- -- Final clean-up simplification:- simplify "final",-- runWhen late_dmd_anal $ CoreDoPasses (- dmd_cpr_ww ++ [simplify "post-late-ww"]- ),-- -- Final run of the demand_analyser, ensures that one-shot thunks are- -- really really one-shot thunks. Only needed if the demand analyser- -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal- -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution- -- can become /exponentially/ more expensive. See #11731, #12996.- runWhen (strictness || late_dmd_anal) CoreDoDemand,-- maybe_rule_check FinalPhase- ]-- -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.- flatten_todos [] = []- flatten_todos (CoreDoNothing : rest) = flatten_todos rest- flatten_todos (CoreDoPasses passes : rest) =- flatten_todos passes ++ flatten_todos rest- flatten_todos (todo : rest) = todo : flatten_todos rest--{- Note [Inline in InitialPhase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is-confusing for users because when they say INLINE they expect the function to inline-right away.--So now we do inlining immediately, even in the InitialPhase, assuming that the-Id's Activation allows it.--This is a surprisingly big deal. Compiler performance improved a lot-when I made this change:-- perf/compiler/T5837.run T5837 [stat too good] (normal)- perf/compiler/parsing001.run parsing001 [stat too good] (normal)- perf/compiler/T12234.run T12234 [stat too good] (optasm)- perf/compiler/T9020.run T9020 [stat too good] (optasm)- perf/compiler/T3064.run T3064 [stat too good] (normal)- perf/compiler/T9961.run T9961 [stat too good] (normal)- perf/compiler/T13056.run T13056 [stat too good] (optasm)- perf/compiler/T9872d.run T9872d [stat too good] (normal)- perf/compiler/T783.run T783 [stat too good] (normal)- perf/compiler/T12227.run T12227 [stat too good] (normal)- perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal)- perf/compiler/T1969.run T1969 [stat too good] (normal)- perf/compiler/T9872a.run T9872a [stat too good] (normal)- perf/compiler/T9872c.run T9872c [stat too good] (normal)- perf/compiler/T9872b.run T9872b [stat too good] (normal)- perf/compiler/T9872d.run T9872d [stat too good] (normal)--Note [RULEs enabled in InitialPhase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-RULES are enabled when doing "gentle" simplification in InitialPhase,-or with -O0. Two reasons:-- * We really want the class-op cancellation to happen:- op (df d1 d2) --> $cop3 d1 d2- because this breaks the mutual recursion between 'op' and 'df'-- * I wanted the RULE- lift String ===> ...- to work in Template Haskell when simplifying- splices, so we get simpler code for literal strings--But watch out: list fusion can prevent floating. So use phase control-to switch off those rules until after floating.--************************************************************************-* *- The CoreToDo interpreter-* *-************************************************************************--}--runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts-runCorePasses passes guts- = foldM do_pass guts passes- where- do_pass guts CoreDoNothing = return guts- do_pass guts (CoreDoPasses ps) = runCorePasses ps guts- do_pass guts pass = do- withTimingD (ppr pass <+> brackets (ppr mod))- (const ()) $ do- { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts- ; endPass pass (mg_binds guts') (mg_rules guts')- ; return guts' }-- mod = mg_module guts--doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts-doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}- simplifyPgm pass--doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}- doPass cseProgram--doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}- doPassD liberateCase--doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}- floatInwards--doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}- doPassDUM (floatOutwards f)--doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}- doPassU doStaticArgs--doCorePass CoreDoCallArity = {-# SCC "CallArity" #-}- doPassD callArityAnalProgram--doCorePass CoreDoExitify = {-# SCC "Exitify" #-}- doPass exitifyProgram--doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}- doPassDFM dmdAnalProgram--doCorePass CoreDoCpr = {-# SCC "CprAnal" #-}- doPassDFM cprAnalProgram--doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}- doPassDFU wwTopBinds--doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}- specProgram--doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}- specConstrProgram--doCorePass CoreDoPrintCore = observe printCore-doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat-doCorePass CoreDoNothing = return-doCorePass (CoreDoPasses passes) = runCorePasses passes--doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass--doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass)--{--************************************************************************-* *-\subsection{Core pass combinators}-* *-************************************************************************--}--printCore :: DynFlags -> CoreProgram -> IO ()-printCore dflags binds- = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)--ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts-ruleCheckPass current_phase pat guts =- withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))- (const ()) $ do- { rb <- getRuleBase- ; dflags <- getDynFlags- ; vis_orphs <- getVisibleOrphanMods- ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn- ++ (mg_rules guts)- ; let ropts = initRuleOpts dflags- ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan- $ withPprStyle defaultDumpStyle- (ruleCheckProgram ropts current_phase pat- rule_fn (mg_binds guts))- ; return guts }--doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDUM do_pass = doPassM $ \binds -> do- dflags <- getDynFlags- us <- getUniqueSupplyM- liftIO $ do_pass dflags us binds--doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))--doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)--doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)--doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassU do_pass = doPassDU (const do_pass)--doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFM do_pass guts = do- dflags <- getDynFlags- p_fam_env <- getPackageFamInstEnv- let fam_envs = (p_fam_env, mg_fam_inst_env guts)- doPassM (liftIO . do_pass dflags fam_envs) guts--doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFU do_pass guts = do- dflags <- getDynFlags- us <- getUniqueSupplyM- p_fam_env <- getPackageFamInstEnv- let fam_envs = (p_fam_env, mg_fam_inst_env guts)- doPass (do_pass dflags fam_envs us) guts---- Most passes return no stats and don't change rules: these combinators--- let us lift them to the full blown ModGuts+CoreM world-doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts-doPassM bind_f guts = do- binds' <- bind_f (mg_binds guts)- return (guts { mg_binds = binds' })--doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }---- Observer passes just peek; don't modify the bindings at all-observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts-observe do_pass = doPassM $ \binds -> do- dflags <- getDynFlags- _ <- liftIO $ do_pass dflags binds- return binds--{--************************************************************************-* *- Gentle simplification-* *-************************************************************************--}--simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do- -> CoreExpr- -> IO CoreExpr--- simplifyExpr is called by the driver to simplify an--- expression typed in at the interactive prompt-simplifyExpr hsc_env expr- = withTiming dflags (text "Simplify [expr]") (const ()) $- do { eps <- hscEPS hsc_env ;- ; let rule_env = mkRuleEnv (eps_rule_base eps) []- fi_env = ( eps_fam_inst_env eps- , extendFamInstEnvList emptyFamInstEnv $- snd $ ic_instances $ hsc_IC hsc_env )- simpl_env = simplEnvForGHCi dflags-- ; us <- mkSplitUniqSupply 's'- ; let sz = exprSize expr-- ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $- simplExprGently simpl_env expr-- ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)- "Simplifier statistics" (pprSimplCount counts)-- ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"- FormatCore- (pprCoreExpr expr')-- ; return expr'- }- where- dflags = hsc_dflags hsc_env--simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr--- Simplifies an expression--- does occurrence analysis, then simplification--- and repeats (twice currently) because one pass--- alone leaves tons of crud.--- Used (a) for user expressions typed in at the interactive prompt--- (b) the LHS and RHS of a RULE--- (c) Template Haskell splices------ The name 'Gently' suggests that the SimplMode is InitialPhase,--- and in fact that is so.... but the 'Gently' in simplExprGently doesn't--- enforce that; it just simplifies the expression twice---- It's important that simplExprGently does eta reduction; see--- Note [Simplifying the left-hand side of a RULE] above. The--- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)--- but only if -O is on.--simplExprGently env expr = do- expr1 <- simplExpr env (occurAnalyseExpr expr)- simplExpr env (occurAnalyseExpr expr1)--{--************************************************************************-* *-\subsection{The driver for the simplifier}-* *-************************************************************************--}--simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts-simplifyPgm pass guts- = do { hsc_env <- getHscEnv- ; us <- getUniqueSupplyM- ; rb <- getRuleBase- ; liftIOWithCount $- simplifyPgmIO pass hsc_env us rb guts }--simplifyPgmIO :: CoreToDo- -> HscEnv- -> UniqSupply- -> RuleBase- -> ModGuts- -> IO (SimplCount, ModGuts) -- New bindings--simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)- hsc_env us hpt_rule_base- guts@(ModGuts { mg_module = this_mod- , mg_rdr_env = rdr_env- , mg_deps = deps- , mg_binds = binds, mg_rules = rules- , mg_fam_inst_env = fam_inst_env })- = do { (termination_msg, it_count, counts_out, guts')- <- do_iteration us 1 [] binds rules-- ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&- dopt Opt_D_dump_simpl_stats dflags)- "Simplifier statistics for following pass"- (vcat [text termination_msg <+> text "after" <+> ppr it_count- <+> text "iterations",- blankLine,- pprSimplCount counts_out])-- ; return (counts_out, guts')- }- where- dflags = hsc_dflags hsc_env- print_unqual = mkPrintUnqualified dflags rdr_env- simpl_env = mkSimplEnv mode- active_rule = activeRule mode- active_unf = activeUnfolding mode-- do_iteration :: UniqSupply- -> Int -- Counts iterations- -> [SimplCount] -- Counts from earlier iterations, reversed- -> CoreProgram -- Bindings in- -> [CoreRule] -- and orphan rules- -> IO (String, Int, SimplCount, ModGuts)-- do_iteration us iteration_no counts_so_far binds rules- -- iteration_no is the number of the iteration we are- -- about to begin, with '1' for the first- | iteration_no > max_iterations -- Stop if we've run out of iterations- = WARN( debugIsOn && (max_iterations > 2)- , hang (text "Simplifier bailing out after" <+> int max_iterations- <+> text "iterations"- <+> (brackets $ hsep $ punctuate comma $- map (int . simplCountN) (reverse counts_so_far)))- 2 (text "Size =" <+> ppr (coreBindsStats binds)))-- -- Subtract 1 from iteration_no to get the- -- number of iterations we actually completed- return ( "Simplifier baled out", iteration_no - 1- , totalise counts_so_far- , guts { mg_binds = binds, mg_rules = rules } )-- -- Try and force thunks off the binds; significantly reduces- -- space usage, especially with -O. JRS, 000620.- | let sz = coreBindsSize binds- , () <- sz `seq` () -- Force it- = do {- -- Occurrence analysis- let { tagged_binds = {-# SCC "OccAnal" #-}- occurAnalysePgm this_mod active_unf active_rule rules- binds- } ;- Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"- FormatCore- (pprCoreBindings tagged_binds);-- -- Get any new rules, and extend the rule base- -- See Note [Overall plumbing for rules] in GHC.Core.Rules- -- We need to do this regularly, because simplification can- -- poke on IdInfo thunks, which in turn brings in new rules- -- behind the scenes. Otherwise there's a danger we'll simply- -- miss the rules for Ids hidden inside imported inlinings- eps <- hscEPS hsc_env ;- let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)- ; rule_base2 = extendRuleBaseList rule_base1 rules- ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)- ; vis_orphs = this_mod : dep_orphs deps } ;-- -- Simplify the program- ((binds1, rules1), counts1) <-- initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $- do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}- simplTopBinds simpl_env tagged_binds-- -- Apply the substitution to rules defined in this module- -- for imported Ids. Eg RULE map my_f = blah- -- If we have a substitution my_f :-> other_f, we'd better- -- apply it to the rule to, or it'll never match- ; rules1 <- simplRules env1 Nothing rules Nothing-- ; return (getTopFloatBinds floats, rules1) } ;-- -- Stop if nothing happened; don't dump output- -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad- if isZeroSimplCount counts1 then- return ( "Simplifier reached fixed point", iteration_no- , totalise (counts1 : counts_so_far) -- Include "free" ticks- , guts { mg_binds = binds1, mg_rules = rules1 } )- else do {- -- Short out indirections- -- We do this *after* at least one run of the simplifier- -- because indirection-shorting uses the export flag on *occurrences*- -- and that isn't guaranteed to be ok until after the first run propagates- -- stuff from the binding site to its occurrences- --- -- ToDo: alas, this means that indirection-shorting does not happen at all- -- if the simplifier does nothing (not common, I know, but unsavoury)- let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;-- -- Dump the result of this iteration- dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;- lintPassResult hsc_env pass binds2 ;-- -- Loop- do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1- } }-#if __GLASGOW_HASKELL__ <= 810- | otherwise = panic "do_iteration"-#endif- where- (us1, us2) = splitUniqSupply us-- -- Remember the counts_so_far are reversed- totalise :: [SimplCount] -> SimplCount- totalise = foldr (\c acc -> acc `plusSimplCount` c)- (zeroSimplCount dflags)--simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"----------------------dump_end_iteration :: DynFlags -> PrintUnqualified -> Int- -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration dflags print_unqual iteration_no counts binds rules- = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules- where- mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations- | otherwise = Nothing- -- Show details if Opt_D_dump_simpl_iterations is on-- hdr = text "Simplifier iteration=" <> int iteration_no- pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr- , pprSimplCount counts- , text "---- End of simplifier counts for" <+> hdr ]--{--************************************************************************-* *- Shorting out indirections-* *-************************************************************************--If we have this:-- x_local = <expression>- ...bindings...- x_exported = x_local--where x_exported is exported, and x_local is not, then we replace it with this:-- x_exported = <expression>- x_local = x_exported- ...bindings...--Without this we never get rid of the x_exported = x_local thing. This-save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and-makes strictness information propagate better. This used to happen in-the final phase, but it's tidier to do it here.--Note [Messing up the exported Id's RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must be careful about discarding (obviously) or even merging the-RULES on the exported Id. The example that went bad on me at one stage-was this one:-- iterate :: (a -> a) -> a -> [a]- [Exported]- iterate = iterateList-- iterateFB c f x = x `c` iterateFB c f (f x)- iterateList f x = x : iterateList f (f x)- [Not exported]-- {-# RULES- "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)- "iterateFB" iterateFB (:) = iterateList- #-}--This got shorted out to:-- iterateList :: (a -> a) -> a -> [a]- iterateList = iterate-- iterateFB c f x = x `c` iterateFB c f (f x)- iterate f x = x : iterate f (f x)-- {-# RULES- "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)- "iterateFB" iterateFB (:) = iterate- #-}--And now we get an infinite loop in the rule system- iterate f x -> build (\cn -> iterateFB c f x)- -> iterateFB (:) f x- -> iterate f x--Old "solution":- use rule switching-off pragmas to get rid- of iterateList in the first place--But in principle the user *might* want rules that only apply to the Id-he says. And inline pragmas are similar- {-# NOINLINE f #-}- f = local- local = <stuff>-Then we do not want to get rid of the NOINLINE.--Hence hasShortableIdinfo.---Note [Rules and indirection-zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Problem: what if x_exported has a RULE that mentions something in ...bindings...?-Then the things mentioned can be out of scope! Solution- a) Make sure that in this pass the usage-info from x_exported is- available for ...bindings...- b) If there are any such RULES, rec-ify the entire top-level.- It'll get sorted out next time round--Other remarks-~~~~~~~~~~~~~-If more than one exported thing is equal to a local thing (i.e., the-local thing really is shared), then we do one only:-\begin{verbatim}- x_local = ....- x_exported1 = x_local- x_exported2 = x_local-==>- x_exported1 = ....-- x_exported2 = x_exported1-\end{verbatim}--We rely on prior eta reduction to simplify things like-\begin{verbatim}- x_exported = /\ tyvars -> x_local tyvars-==>- x_exported = x_local-\end{verbatim}-Hence,there's a possibility of leaving unchanged something like this:-\begin{verbatim}- x_local = ....- x_exported1 = x_local Int-\end{verbatim}-By the time we've thrown away the types in STG land this-could be eliminated. But I don't think it's very common-and it's dangerous to do this fiddling in STG land-because we might eliminate a binding that's mentioned in the-unfolding for something.--Note [Indirection zapping and ticks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unfortunately this is another place where we need a special case for-ticks. The following happens quite regularly:-- x_local = <expression>- x_exported = tick<x> x_local--Which we want to become:-- x_exported = tick<x> <expression>--As it makes no sense to keep the tick and the expression on separate-bindings. Note however that this might increase the ticks scoping-over the execution of x_local, so we can only do this for floatable-ticks. More often than not, other references will be unfoldings of-x_exported, and therefore carry the tick anyway.--}--type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks--shortOutIndirections :: CoreProgram -> CoreProgram-shortOutIndirections binds- | isEmptyVarEnv ind_env = binds- | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]- | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff- where- ind_env = makeIndEnv binds- -- These exported Ids are the subjects of the indirection-elimination- exp_ids = map fst $ nonDetEltsUFM ind_env- -- It's OK to use nonDetEltsUFM here because we forget the ordering- -- by immediately converting to a set or check if all the elements- -- satisfy a predicate.- exp_id_set = mkVarSet exp_ids- no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids- binds' = concatMap zap binds-- zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]- zap (Rec pairs) = [Rec (concatMap zapPair pairs)]-- zapPair (bndr, rhs)- | bndr `elemVarSet` exp_id_set- = [] -- Kill the exported-id binding-- | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr- , (exp_id', lcl_id') <- transferIdInfo exp_id bndr- = -- Turn a local-id binding into two bindings- -- exp_id = rhs; lcl_id = exp_id- [ (exp_id', mkTicks ticks rhs),- (lcl_id', Var exp_id') ]-- | otherwise- = [(bndr,rhs)]--makeIndEnv :: [CoreBind] -> IndEnv-makeIndEnv binds- = foldl' add_bind emptyVarEnv binds- where- add_bind :: IndEnv -> CoreBind -> IndEnv- add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)- add_bind env (Rec pairs) = foldl' add_pair env pairs-- add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv- add_pair env (exported_id, exported)- | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported- , shortMeOut env exported_id local_id- = extendVarEnv env local_id (exported_id, ticks)- add_pair env _ = env--------------------shortMeOut :: IndEnv -> Id -> Id -> Bool-shortMeOut ind_env exported_id local_id--- The if-then-else stuff is just so I can get a pprTrace to see--- how often I don't get shorting out because of IdInfo stuff- = if isExportedId exported_id && -- Only if this is exported-- isLocalId local_id && -- Only if this one is defined in this- -- module, so that we *can* change its- -- binding to be the exported thing!-- not (isExportedId local_id) && -- Only if this one is not itself exported,- -- since the transformation will nuke it-- not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for- then- if hasShortableIdInfo exported_id- then True -- See Note [Messing up the exported Id's IdInfo]- else WARN( True, text "Not shorting out:" <+> ppr exported_id )- False- else- False--------------------hasShortableIdInfo :: Id -> Bool--- True if there is no user-attached IdInfo on exported_id,--- so we can safely discard it--- See Note [Messing up the exported Id's IdInfo]-hasShortableIdInfo id- = isEmptyRuleInfo (ruleInfo info)- && isDefaultInlinePragma (inlinePragInfo info)- && not (isStableUnfolding (unfoldingInfo info))- where- info = idInfo id--------------------{- Note [Transferring IdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have- lcl_id = e; exp_id = lcl_id--and lcl_id has useful IdInfo, we don't want to discard it by going- gbl_id = e; lcl_id = gbl_id--Instead, transfer IdInfo from lcl_id to exp_id, specifically-* (Stable) unfolding-* Strictness-* Rules-* Inline pragma--Overwriting, rather than merging, seems to work ok.--We also zap the InlinePragma on the lcl_id. It might originally-have had a NOINLINE, which we have now transferred; and we really-want the lcl_id to inline now that its RHS is trivial!--}--transferIdInfo :: Id -> Id -> (Id, Id)--- See Note [Transferring IdInfo]-transferIdInfo exported_id local_id- = ( modifyIdInfo transfer exported_id- , local_id `setInlinePragma` defaultInlinePragma )- where- local_info = idInfo local_id- transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info- `setCprInfo` cprInfo local_info- `setUnfoldingInfo` unfoldingInfo local_info- `setInlinePragInfo` inlinePragInfo local_info- `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info- new_info = setRuleInfoHead (idName exported_id)- (ruleInfo local_info)- -- Remember to set the function-name field of the- -- rules as we transfer them from one function to another
compiler/GHC/Core/Opt/Exitify.hs view
@@ -44,7 +44,7 @@ import GHC.Core import GHC.Core.Utils import GHC.Utils.Monad.State-import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.FVs
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -35,7 +35,7 @@ import GHC.Types.Var.Set import GHC.Utils.Misc import GHC.Driver.Session-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Basic ( RecFlag(..), isRec ) {-
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -28,6 +28,7 @@ import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Type import qualified Data.IntMap as M
+ compiler/GHC/Core/Opt/Pipeline.hs view
@@ -0,0 +1,1046 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SimplCore]{Driver for simplifying @Core@ programs}+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Core+import GHC.Driver.Types+import GHC.Core.Opt.CSE ( cseProgram )+import GHC.Core.Rules ( mkRuleBase, unionRuleBase,+ extendRuleBaseList, ruleCheckProgram, addRuleInfo,+ getRules, initRuleOpts )+import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )+import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )+import GHC.Types.Id.Info+import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )+import GHC.Core.Utils ( mkTicks, stripTicksTop )+import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult,+ lintAnnots )+import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules )+import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.Monad+import qualified GHC.Utils.Error as Err+import GHC.Core.Opt.FloatIn ( floatInwards )+import GHC.Core.Opt.FloatOut ( floatOutwards )+import GHC.Core.FamInstEnv+import GHC.Types.Id+import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) )+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core.Opt.LiberateCase ( liberateCase )+import GHC.Core.Opt.StaticArgs ( doStaticArgs )+import GHC.Core.Opt.Specialise ( specProgram)+import GHC.Core.Opt.SpecConstr ( specConstrProgram)+import GHC.Core.Opt.DmdAnal ( dmdAnalProgram )+import GHC.Core.Opt.CprAnal ( cprAnalProgram )+import GHC.Core.Opt.CallArity ( callArityAnalProgram )+import GHC.Core.Opt.Exitify ( exitifyProgram )+import GHC.Core.Opt.WorkWrap ( wwTopBinds )+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Unit.Module.Env+import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Runtime.Loader -- ( initializePlugins )++import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )+import GHC.Types.Unique.FM+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Control.Monad+import qualified GHC.LanguageExtensions as LangExt+{-+************************************************************************+* *+\subsection{The driver for the simplifier}+* *+************************************************************************+-}++core2core :: HscEnv -> ModGuts -> IO ModGuts+core2core hsc_env guts@(ModGuts { mg_module = mod+ , mg_loc = loc+ , mg_deps = deps+ , mg_rdr_env = rdr_env })+ = do { -- make sure all plugins are loaded++ ; let builtin_passes = getCoreToDo dflags+ orph_mods = mkModuleSet (mod : dep_orphs deps)+ uniq_mask = 's'+ ;+ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod+ orph_mods print_unqual loc $+ do { hsc_env' <- getHscEnv+ ; dflags' <- liftIO $ initializePlugins hsc_env'+ (hsc_dflags hsc_env')+ ; all_passes <- withPlugins dflags'+ installCoreToDos+ builtin_passes+ ; runCorePasses all_passes guts }++ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats+ "Grand total simplifier statistics"+ FormatText+ (pprSimplCount stats)++ ; return guts2 }+ where+ dflags = hsc_dflags hsc_env+ home_pkg_rules = hptRules hsc_env (dep_mods deps)+ hpt_rule_base = mkRuleBase home_pkg_rules+ print_unqual = mkPrintUnqualified+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ rdr_env+ -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.+ -- This is very convienent for the users of the monad (e.g. plugins do not have to+ -- consume the ModGuts to find the module) but somewhat ugly because mg_module may+ -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which+ -- would mean our cached value would go out of date.++{-+************************************************************************+* *+ Generating the main optimisation pipeline+* *+************************************************************************+-}++getCoreToDo :: DynFlags -> [CoreToDo]+getCoreToDo dflags+ = flatten_todos core_todo+ where+ opt_level = optLevel dflags+ phases = simplPhases dflags+ max_iter = maxSimplIterations dflags+ rule_check = ruleCheck dflags+ call_arity = gopt Opt_CallArity dflags+ exitification = gopt Opt_Exitification dflags+ strictness = gopt Opt_Strictness dflags+ full_laziness = gopt Opt_FullLaziness dflags+ do_specialise = gopt Opt_Specialise dflags+ do_float_in = gopt Opt_FloatIn dflags+ cse = gopt Opt_CSE dflags+ spec_constr = gopt Opt_SpecConstr dflags+ liberate_case = gopt Opt_LiberateCase dflags+ late_dmd_anal = gopt Opt_LateDmdAnal dflags+ late_specialise = gopt Opt_LateSpecialise dflags+ static_args = gopt Opt_StaticArgumentTransformation dflags+ rules_on = gopt Opt_EnableRewriteRules dflags+ eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags+ ww_on = gopt Opt_WorkerWrapper dflags+ static_ptrs = xopt LangExt.StaticPointers dflags++ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)++ maybe_strictness_before (Phase phase)+ | phase `elem` strictnessBefore dflags = CoreDoDemand+ maybe_strictness_before _+ = CoreDoNothing++ base_mode = SimplMode { sm_phase = panic "base_mode"+ , sm_names = []+ , sm_dflags = dflags+ , sm_rules = rules_on+ , sm_eta_expand = eta_expand_on+ , sm_inline = True+ , sm_case_case = True }++ simpl_phase phase name iter+ = CoreDoPasses+ $ [ maybe_strictness_before phase+ , CoreDoSimplify iter+ (base_mode { sm_phase = phase+ , sm_names = [name] })++ , maybe_rule_check phase ]++ -- Run GHC's internal simplification phase, after all rules have run.+ -- See Note [Compiler phases] in GHC.Types.Basic+ simplify name = simpl_phase FinalPhase name max_iter++ -- initial simplify: mk specialiser happy: minimum effort please+ simpl_gently = CoreDoSimplify max_iter+ (base_mode { sm_phase = InitialPhase+ , sm_names = ["Gentle"]+ , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase]+ , sm_inline = True+ -- See Note [Inline in InitialPhase]+ , sm_case_case = False })+ -- Don't do case-of-case transformations.+ -- This makes full laziness work better++ dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]+ else [CoreDoDemand,CoreDoCpr]+++ demand_analyser = (CoreDoPasses (+ dmd_cpr_ww +++ [simplify "post-worker-wrapper"]+ ))++ -- Static forms are moved to the top level with the FloatOut pass.+ -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+ static_ptrs_float_outwards =+ runWhen static_ptrs $ CoreDoPasses+ [ simpl_gently -- Float Out can't handle type lets (sometimes created+ -- by simpleOptPgm via mkParallelBindings)+ , CoreDoFloatOutwards FloatOutSwitches+ { floatOutLambdas = Just 0+ , floatOutConstants = True+ , floatOutOverSatApps = False+ , floatToTopLevelOnly = True+ }+ ]++ core_todo =+ if opt_level == 0 then+ [ static_ptrs_float_outwards,+ CoreDoSimplify max_iter+ (base_mode { sm_phase = FinalPhase+ , sm_names = ["Non-opt simplification"] })+ ]++ else {- opt_level >= 1 -} [++ -- We want to do the static argument transform before full laziness as it+ -- may expose extra opportunities to float things outwards. However, to fix+ -- up the output of the transformation we need at do at least one simplify+ -- after this before anything else+ runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),++ -- initial simplify: mk specialiser happy: minimum effort please+ simpl_gently,++ -- Specialisation is best done before full laziness+ -- so that overloaded functions have all their dictionary lambdas manifest+ runWhen do_specialise CoreDoSpecialising,++ if full_laziness then+ CoreDoFloatOutwards FloatOutSwitches {+ floatOutLambdas = Just 0,+ floatOutConstants = True,+ floatOutOverSatApps = False,+ floatToTopLevelOnly = False }+ -- Was: gentleFloatOutSwitches+ --+ -- I have no idea why, but not floating constants to+ -- top level is very bad in some cases.+ --+ -- Notably: p_ident in spectral/rewrite+ -- Changing from "gentle" to "constantsOnly"+ -- improved rewrite's allocation by 19%, and+ -- made 0.0% difference to any other nofib+ -- benchmark+ --+ -- Not doing floatOutOverSatApps yet, we'll do+ -- that later on when we've had a chance to get more+ -- accurate arity information. In fact it makes no+ -- difference at all to performance if we do it here,+ -- but maybe we save some unnecessary to-and-fro in+ -- the simplifier.+ else+ -- Even with full laziness turned off, we still need to float static+ -- forms to the top level. See Note [Grand plan for static forms] in+ -- GHC.Iface.Tidy.StaticPtrTable.+ static_ptrs_float_outwards,++ -- Run the simplier phases 2,1,0 to allow rewrite rules to fire+ CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter+ | phase <- [phases, phases-1 .. 1] ],+ simpl_phase (Phase 0) "main" (max max_iter 3),+ -- Phase 0: allow all Ids to be inlined now+ -- This gets foldr inlined before strictness analysis++ -- At least 3 iterations because otherwise we land up with+ -- huge dead expressions because of an infelicity in the+ -- simplifier.+ -- let k = BIG in foldr k z xs+ -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs+ -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs+ -- Don't stop now!++ runWhen do_float_in CoreDoFloatInwards,+ -- Run float-inwards immediately before the strictness analyser+ -- Doing so pushes bindings nearer their use site and hence makes+ -- them more likely to be strict. These bindings might only show+ -- up after the inlining from simplification. Example in fulsom,+ -- Csg.calc, where an arg of timesDouble thereby becomes strict.++ runWhen call_arity $ CoreDoPasses+ [ CoreDoCallArity+ , simplify "post-call-arity"+ ],++ -- Strictness analysis+ runWhen strictness demand_analyser,++ runWhen exitification CoreDoExitify,+ -- See note [Placement of the exitification pass]++ runWhen full_laziness $+ CoreDoFloatOutwards FloatOutSwitches {+ floatOutLambdas = floatLamArgs dflags,+ floatOutConstants = True,+ floatOutOverSatApps = True,+ floatToTopLevelOnly = False },+ -- nofib/spectral/hartel/wang doubles in speed if you+ -- do full laziness late in the day. It only happens+ -- after fusion and other stuff, so the early pass doesn't+ -- catch it. For the record, the redex is+ -- f_el22 (f_el21 r_midblock)+++ runWhen cse CoreCSE,+ -- We want CSE to follow the final full-laziness pass, because it may+ -- succeed in commoning up things floated out by full laziness.+ -- CSE used to rely on the no-shadowing invariant, but it doesn't any more++ runWhen do_float_in CoreDoFloatInwards,++ maybe_rule_check FinalPhase,++ -- Case-liberation for -O2. This should be after+ -- strictness analysis and the simplification which follows it.+ runWhen liberate_case (CoreDoPasses [+ CoreLiberateCase,+ simplify "post-liberate-case"+ ]), -- Run the simplifier after LiberateCase to vastly+ -- reduce the possibility of shadowing+ -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr++ runWhen spec_constr CoreDoSpecConstr,++ maybe_rule_check FinalPhase,++ runWhen late_specialise+ (CoreDoPasses [ CoreDoSpecialising+ , simplify "post-late-spec"]),++ -- LiberateCase can yield new CSE opportunities because it peels+ -- off one layer of a recursive function (concretely, I saw this+ -- in wheel-sieve1), and I'm guessing that SpecConstr can too+ -- And CSE is a very cheap pass. So it seems worth doing here.+ runWhen ((liberate_case || spec_constr) && cse) CoreCSE,++ -- Final clean-up simplification:+ simplify "final",++ runWhen late_dmd_anal $ CoreDoPasses (+ dmd_cpr_ww ++ [simplify "post-late-ww"]+ ),++ -- Final run of the demand_analyser, ensures that one-shot thunks are+ -- really really one-shot thunks. Only needed if the demand analyser+ -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal+ -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution+ -- can become /exponentially/ more expensive. See #11731, #12996.+ runWhen (strictness || late_dmd_anal) CoreDoDemand,++ maybe_rule_check FinalPhase+ ]++ -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.+ flatten_todos [] = []+ flatten_todos (CoreDoNothing : rest) = flatten_todos rest+ flatten_todos (CoreDoPasses passes : rest) =+ flatten_todos passes ++ flatten_todos rest+ flatten_todos (todo : rest) = todo : flatten_todos rest++{- Note [Inline in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is+confusing for users because when they say INLINE they expect the function to inline+right away.++So now we do inlining immediately, even in the InitialPhase, assuming that the+Id's Activation allows it.++This is a surprisingly big deal. Compiler performance improved a lot+when I made this change:++ perf/compiler/T5837.run T5837 [stat too good] (normal)+ perf/compiler/parsing001.run parsing001 [stat too good] (normal)+ perf/compiler/T12234.run T12234 [stat too good] (optasm)+ perf/compiler/T9020.run T9020 [stat too good] (optasm)+ perf/compiler/T3064.run T3064 [stat too good] (normal)+ perf/compiler/T9961.run T9961 [stat too good] (normal)+ perf/compiler/T13056.run T13056 [stat too good] (optasm)+ perf/compiler/T9872d.run T9872d [stat too good] (normal)+ perf/compiler/T783.run T783 [stat too good] (normal)+ perf/compiler/T12227.run T12227 [stat too good] (normal)+ perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal)+ perf/compiler/T1969.run T1969 [stat too good] (normal)+ perf/compiler/T9872a.run T9872a [stat too good] (normal)+ perf/compiler/T9872c.run T9872c [stat too good] (normal)+ perf/compiler/T9872b.run T9872b [stat too good] (normal)+ perf/compiler/T9872d.run T9872d [stat too good] (normal)++Note [RULEs enabled in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+RULES are enabled when doing "gentle" simplification in InitialPhase,+or with -O0. Two reasons:++ * We really want the class-op cancellation to happen:+ op (df d1 d2) --> $cop3 d1 d2+ because this breaks the mutual recursion between 'op' and 'df'++ * I wanted the RULE+ lift String ===> ...+ to work in Template Haskell when simplifying+ splices, so we get simpler code for literal strings++But watch out: list fusion can prevent floating. So use phase control+to switch off those rules until after floating.++************************************************************************+* *+ The CoreToDo interpreter+* *+************************************************************************+-}++runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts+runCorePasses passes guts+ = foldM do_pass guts passes+ where+ do_pass guts CoreDoNothing = return guts+ do_pass guts (CoreDoPasses ps) = runCorePasses ps guts+ do_pass guts pass = do+ withTimingD (ppr pass <+> brackets (ppr mod))+ (const ()) $ do+ { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts+ ; endPass pass (mg_binds guts') (mg_rules guts')+ ; return guts' }++ mod = mg_module guts++doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts+doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}+ simplifyPgm pass++doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}+ doPass cseProgram++doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}+ doPassD liberateCase++doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}+ floatInwards++doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}+ doPassDUM (floatOutwards f)++doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}+ doPassU doStaticArgs++doCorePass CoreDoCallArity = {-# SCC "CallArity" #-}+ doPassD callArityAnalProgram++doCorePass CoreDoExitify = {-# SCC "Exitify" #-}+ doPass exitifyProgram++doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}+ doPassDFM dmdAnalProgram++doCorePass CoreDoCpr = {-# SCC "CprAnal" #-}+ doPassDFM cprAnalProgram++doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}+ doPassDFU wwTopBinds++doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}+ specProgram++doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}+ specConstrProgram++doCorePass CoreDoPrintCore = observe printCore+doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat+doCorePass CoreDoNothing = return+doCorePass (CoreDoPasses passes) = runCorePasses passes++doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass++doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass)++{-+************************************************************************+* *+\subsection{Core pass combinators}+* *+************************************************************************+-}++printCore :: DynFlags -> CoreProgram -> IO ()+printCore dflags binds+ = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)++ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts+ruleCheckPass current_phase pat guts =+ withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+ (const ()) $ do+ { rb <- getRuleBase+ ; dflags <- getDynFlags+ ; vis_orphs <- getVisibleOrphanMods+ ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+ ++ (mg_rules guts)+ ; let ropts = initRuleOpts dflags+ ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan+ $ withPprStyle defaultDumpStyle+ (ruleCheckProgram ropts current_phase pat+ rule_fn (mg_binds guts))+ ; return guts }++doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDUM do_pass = doPassM $ \binds -> do+ dflags <- getDynFlags+ us <- getUniqueSupplyM+ liftIO $ do_pass dflags us binds++doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))++doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)++doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)++doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassU do_pass = doPassDU (const do_pass)++doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFM do_pass guts = do+ dflags <- getDynFlags+ p_fam_env <- getPackageFamInstEnv+ let fam_envs = (p_fam_env, mg_fam_inst_env guts)+ doPassM (liftIO . do_pass dflags fam_envs) guts++doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFU do_pass guts = do+ dflags <- getDynFlags+ us <- getUniqueSupplyM+ p_fam_env <- getPackageFamInstEnv+ let fam_envs = (p_fam_env, mg_fam_inst_env guts)+ doPass (do_pass dflags fam_envs us) guts++-- Most passes return no stats and don't change rules: these combinators+-- let us lift them to the full blown ModGuts+CoreM world+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts+doPassM bind_f guts = do+ binds' <- bind_f (mg_binds guts)+ return (guts { mg_binds = binds' })++doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }++-- Observer passes just peek; don't modify the bindings at all+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts+observe do_pass = doPassM $ \binds -> do+ dflags <- getDynFlags+ _ <- liftIO $ do_pass dflags binds+ return binds++{-+************************************************************************+* *+ Gentle simplification+* *+************************************************************************+-}++simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do+ -> CoreExpr+ -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+simplifyExpr hsc_env expr+ = withTiming dflags (text "Simplify [expr]") (const ()) $+ do { eps <- hscEPS hsc_env ;+ ; let rule_env = mkRuleEnv (eps_rule_base eps) []+ fi_env = ( eps_fam_inst_env eps+ , extendFamInstEnvList emptyFamInstEnv $+ snd $ ic_instances $ hsc_IC hsc_env )+ simpl_env = simplEnvForGHCi dflags++ ; us <- mkSplitUniqSupply 's'+ ; let sz = exprSize expr++ ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $+ simplExprGently simpl_env expr++ ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)+ "Simplifier statistics" (pprSimplCount counts)++ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+ FormatCore+ (pprCoreExpr expr')++ ; return expr'+ }+ where+ dflags = hsc_dflags hsc_env++simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr+-- Simplifies an expression+-- does occurrence analysis, then simplification+-- and repeats (twice currently) because one pass+-- alone leaves tons of crud.+-- Used (a) for user expressions typed in at the interactive prompt+-- (b) the LHS and RHS of a RULE+-- (c) Template Haskell splices+--+-- The name 'Gently' suggests that the SimplMode is InitialPhase,+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't+-- enforce that; it just simplifies the expression twice++-- It's important that simplExprGently does eta reduction; see+-- Note [Simplifying the left-hand side of a RULE] above. The+-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)+-- but only if -O is on.++simplExprGently env expr = do+ expr1 <- simplExpr env (occurAnalyseExpr expr)+ simplExpr env (occurAnalyseExpr expr1)++{-+************************************************************************+* *+\subsection{The driver for the simplifier}+* *+************************************************************************+-}++simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts+simplifyPgm pass guts+ = do { hsc_env <- getHscEnv+ ; us <- getUniqueSupplyM+ ; rb <- getRuleBase+ ; liftIOWithCount $+ simplifyPgmIO pass hsc_env us rb guts }++simplifyPgmIO :: CoreToDo+ -> HscEnv+ -> UniqSupply+ -> RuleBase+ -> ModGuts+ -> IO (SimplCount, ModGuts) -- New bindings++simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)+ hsc_env us hpt_rule_base+ guts@(ModGuts { mg_module = this_mod+ , mg_rdr_env = rdr_env+ , mg_deps = deps+ , mg_binds = binds, mg_rules = rules+ , mg_fam_inst_env = fam_inst_env })+ = do { (termination_msg, it_count, counts_out, guts')+ <- do_iteration us 1 [] binds rules++ ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&+ dopt Opt_D_dump_simpl_stats dflags)+ "Simplifier statistics for following pass"+ (vcat [text termination_msg <+> text "after" <+> ppr it_count+ <+> text "iterations",+ blankLine,+ pprSimplCount counts_out])++ ; return (counts_out, guts')+ }+ where+ dflags = hsc_dflags hsc_env+ print_unqual = mkPrintUnqualified (unitState dflags) (mkHomeUnitFromFlags dflags) rdr_env+ simpl_env = mkSimplEnv mode+ active_rule = activeRule mode+ active_unf = activeUnfolding mode++ do_iteration :: UniqSupply+ -> Int -- Counts iterations+ -> [SimplCount] -- Counts from earlier iterations, reversed+ -> CoreProgram -- Bindings in+ -> [CoreRule] -- and orphan rules+ -> IO (String, Int, SimplCount, ModGuts)++ do_iteration us iteration_no counts_so_far binds rules+ -- iteration_no is the number of the iteration we are+ -- about to begin, with '1' for the first+ | iteration_no > max_iterations -- Stop if we've run out of iterations+ = WARN( debugIsOn && (max_iterations > 2)+ , hang (text "Simplifier bailing out after" <+> int max_iterations+ <+> text "iterations"+ <+> (brackets $ hsep $ punctuate comma $+ map (int . simplCountN) (reverse counts_so_far)))+ 2 (text "Size =" <+> ppr (coreBindsStats binds)))++ -- Subtract 1 from iteration_no to get the+ -- number of iterations we actually completed+ return ( "Simplifier baled out", iteration_no - 1+ , totalise counts_so_far+ , guts { mg_binds = binds, mg_rules = rules } )++ -- Try and force thunks off the binds; significantly reduces+ -- space usage, especially with -O. JRS, 000620.+ | let sz = coreBindsSize binds+ , () <- sz `seq` () -- Force it+ = do {+ -- Occurrence analysis+ let { tagged_binds = {-# SCC "OccAnal" #-}+ occurAnalysePgm this_mod active_unf active_rule rules+ binds+ } ;+ Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+ FormatCore+ (pprCoreBindings tagged_binds);++ -- Get any new rules, and extend the rule base+ -- See Note [Overall plumbing for rules] in GHC.Core.Rules+ -- We need to do this regularly, because simplification can+ -- poke on IdInfo thunks, which in turn brings in new rules+ -- behind the scenes. Otherwise there's a danger we'll simply+ -- miss the rules for Ids hidden inside imported inlinings+ eps <- hscEPS hsc_env ;+ let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)+ ; rule_base2 = extendRuleBaseList rule_base1 rules+ ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+ ; vis_orphs = this_mod : dep_orphs deps } ;++ -- Simplify the program+ ((binds1, rules1), counts1) <-+ initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $+ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}+ simplTopBinds simpl_env tagged_binds++ -- Apply the substitution to rules defined in this module+ -- for imported Ids. Eg RULE map my_f = blah+ -- If we have a substitution my_f :-> other_f, we'd better+ -- apply it to the rule to, or it'll never match+ ; rules1 <- simplRules env1 Nothing rules Nothing++ ; return (getTopFloatBinds floats, rules1) } ;++ -- Stop if nothing happened; don't dump output+ -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad+ if isZeroSimplCount counts1 then+ return ( "Simplifier reached fixed point", iteration_no+ , totalise (counts1 : counts_so_far) -- Include "free" ticks+ , guts { mg_binds = binds1, mg_rules = rules1 } )+ else do {+ -- Short out indirections+ -- We do this *after* at least one run of the simplifier+ -- because indirection-shorting uses the export flag on *occurrences*+ -- and that isn't guaranteed to be ok until after the first run propagates+ -- stuff from the binding site to its occurrences+ --+ -- ToDo: alas, this means that indirection-shorting does not happen at all+ -- if the simplifier does nothing (not common, I know, but unsavoury)+ let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;++ -- Dump the result of this iteration+ dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;+ lintPassResult hsc_env pass binds2 ;++ -- Loop+ do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+ } }+#if __GLASGOW_HASKELL__ <= 810+ | otherwise = panic "do_iteration"+#endif+ where+ (us1, us2) = splitUniqSupply us++ -- Remember the counts_so_far are reversed+ totalise :: [SimplCount] -> SimplCount+ totalise = foldr (\c acc -> acc `plusSimplCount` c)+ (zeroSimplCount dflags)++simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"++-------------------+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int+ -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration dflags print_unqual iteration_no counts binds rules+ = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules+ where+ mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations+ | otherwise = Nothing+ -- Show details if Opt_D_dump_simpl_iterations is on++ hdr = text "Simplifier iteration=" <> int iteration_no+ pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+ , pprSimplCount counts+ , text "---- End of simplifier counts for" <+> hdr ]++{-+************************************************************************+* *+ Shorting out indirections+* *+************************************************************************++If we have this:++ x_local = <expression>+ ...bindings...+ x_exported = x_local++where x_exported is exported, and x_local is not, then we replace it with this:++ x_exported = <expression>+ x_local = x_exported+ ...bindings...++Without this we never get rid of the x_exported = x_local thing. This+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and+makes strictness information propagate better. This used to happen in+the final phase, but it's tidier to do it here.++Note [Messing up the exported Id's RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must be careful about discarding (obviously) or even merging the+RULES on the exported Id. The example that went bad on me at one stage+was this one:++ iterate :: (a -> a) -> a -> [a]+ [Exported]+ iterate = iterateList++ iterateFB c f x = x `c` iterateFB c f (f x)+ iterateList f x = x : iterateList f (f x)+ [Not exported]++ {-# RULES+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)+ "iterateFB" iterateFB (:) = iterateList+ #-}++This got shorted out to:++ iterateList :: (a -> a) -> a -> [a]+ iterateList = iterate++ iterateFB c f x = x `c` iterateFB c f (f x)+ iterate f x = x : iterate f (f x)++ {-# RULES+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)+ "iterateFB" iterateFB (:) = iterate+ #-}++And now we get an infinite loop in the rule system+ iterate f x -> build (\cn -> iterateFB c f x)+ -> iterateFB (:) f x+ -> iterate f x++Old "solution":+ use rule switching-off pragmas to get rid+ of iterateList in the first place++But in principle the user *might* want rules that only apply to the Id+he says. And inline pragmas are similar+ {-# NOINLINE f #-}+ f = local+ local = <stuff>+Then we do not want to get rid of the NOINLINE.++Hence hasShortableIdinfo.+++Note [Rules and indirection-zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem: what if x_exported has a RULE that mentions something in ...bindings...?+Then the things mentioned can be out of scope! Solution+ a) Make sure that in this pass the usage-info from x_exported is+ available for ...bindings...+ b) If there are any such RULES, rec-ify the entire top-level.+ It'll get sorted out next time round++Other remarks+~~~~~~~~~~~~~+If more than one exported thing is equal to a local thing (i.e., the+local thing really is shared), then we do one only:+\begin{verbatim}+ x_local = ....+ x_exported1 = x_local+ x_exported2 = x_local+==>+ x_exported1 = ....++ x_exported2 = x_exported1+\end{verbatim}++We rely on prior eta reduction to simplify things like+\begin{verbatim}+ x_exported = /\ tyvars -> x_local tyvars+==>+ x_exported = x_local+\end{verbatim}+Hence,there's a possibility of leaving unchanged something like this:+\begin{verbatim}+ x_local = ....+ x_exported1 = x_local Int+\end{verbatim}+By the time we've thrown away the types in STG land this+could be eliminated. But I don't think it's very common+and it's dangerous to do this fiddling in STG land+because we might eliminate a binding that's mentioned in the+unfolding for something.++Note [Indirection zapping and ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately this is another place where we need a special case for+ticks. The following happens quite regularly:++ x_local = <expression>+ x_exported = tick<x> x_local++Which we want to become:++ x_exported = tick<x> <expression>++As it makes no sense to keep the tick and the expression on separate+bindings. Note however that this might increase the ticks scoping+over the execution of x_local, so we can only do this for floatable+ticks. More often than not, other references will be unfoldings of+x_exported, and therefore carry the tick anyway.+-}++type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+ | isEmptyVarEnv ind_env = binds+ | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]+ | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff+ where+ ind_env = makeIndEnv binds+ -- These exported Ids are the subjects of the indirection-elimination+ exp_ids = map fst $ nonDetEltsUFM ind_env+ -- It's OK to use nonDetEltsUFM here because we forget the ordering+ -- by immediately converting to a set or check if all the elements+ -- satisfy a predicate.+ exp_id_set = mkVarSet exp_ids+ no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids+ binds' = concatMap zap binds++ zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]+ zap (Rec pairs) = [Rec (concatMap zapPair pairs)]++ zapPair (bndr, rhs)+ | bndr `elemVarSet` exp_id_set+ = [] -- Kill the exported-id binding++ | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr+ , (exp_id', lcl_id') <- transferIdInfo exp_id bndr+ = -- Turn a local-id binding into two bindings+ -- exp_id = rhs; lcl_id = exp_id+ [ (exp_id', mkTicks ticks rhs),+ (lcl_id', Var exp_id') ]++ | otherwise+ = [(bndr,rhs)]++makeIndEnv :: [CoreBind] -> IndEnv+makeIndEnv binds+ = foldl' add_bind emptyVarEnv binds+ where+ add_bind :: IndEnv -> CoreBind -> IndEnv+ add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)+ add_bind env (Rec pairs) = foldl' add_pair env pairs++ add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv+ add_pair env (exported_id, exported)+ | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported+ , shortMeOut env exported_id local_id+ = extendVarEnv env local_id (exported_id, ticks)+ add_pair env _ = env++-----------------+shortMeOut :: IndEnv -> Id -> Id -> Bool+shortMeOut ind_env exported_id local_id+-- The if-then-else stuff is just so I can get a pprTrace to see+-- how often I don't get shorting out because of IdInfo stuff+ = if isExportedId exported_id && -- Only if this is exported++ isLocalId local_id && -- Only if this one is defined in this+ -- module, so that we *can* change its+ -- binding to be the exported thing!++ not (isExportedId local_id) && -- Only if this one is not itself exported,+ -- since the transformation will nuke it++ not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for+ then+ if hasShortableIdInfo exported_id+ then True -- See Note [Messing up the exported Id's IdInfo]+ else WARN( True, text "Not shorting out:" <+> ppr exported_id )+ False+ else+ False++-----------------+hasShortableIdInfo :: Id -> Bool+-- True if there is no user-attached IdInfo on exported_id,+-- so we can safely discard it+-- See Note [Messing up the exported Id's IdInfo]+hasShortableIdInfo id+ = isEmptyRuleInfo (ruleInfo info)+ && isDefaultInlinePragma (inlinePragInfo info)+ && not (isStableUnfolding (unfoldingInfo info))+ where+ info = idInfo id++-----------------+{- Note [Transferring IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+ lcl_id = e; exp_id = lcl_id++and lcl_id has useful IdInfo, we don't want to discard it by going+ gbl_id = e; lcl_id = gbl_id++Instead, transfer IdInfo from lcl_id to exp_id, specifically+* (Stable) unfolding+* Strictness+* Rules+* Inline pragma++Overwriting, rather than merging, seems to work ok.++We also zap the InlinePragma on the lcl_id. It might originally+have had a NOINLINE, which we have now transferred; and we really+want the lcl_id to inline now that its RHS is trivial!+-}++transferIdInfo :: Id -> Id -> (Id, Id)+-- See Note [Transferring IdInfo]+transferIdInfo exported_id local_id+ = ( modifyIdInfo transfer exported_id+ , local_id `setInlinePragma` defaultInlinePragma )+ where+ local_info = idInfo local_id+ transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info+ `setCprInfo` cprInfo local_info+ `setUnfoldingInfo` unfoldingInfo local_info+ `setInlinePragInfo` inlinePragInfo local_info+ `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info+ new_info = setRuleInfoHead (idName exported_id)+ (ruleInfo local_info)+ -- Remember to set the function-name field of the+ -- rules as we transfer them from one function to another
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -77,6 +77,8 @@ import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils ( exprType, exprIsHNF@@ -114,6 +116,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.DFM import GHC.Utils.FV
compiler/GHC/Core/Opt/Simplify.hs view
@@ -15,6 +15,7 @@ import GHC.Platform import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env@@ -58,6 +59,7 @@ import GHC.Data.Maybe ( orElse ) import Control.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Error@@ -68,7 +70,7 @@ {- The guts of the simplifier is in this module, but the driver loop for-the simplifier is in GHC.Core.Opt.Driver+the simplifier is in GHC.Core.Opt.Pipeline Note [The big picture] ~~~~~~~~~~~~~~~~~~~~~~@@ -1970,8 +1972,10 @@ = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont ---------- The runRW# rule. Do this after absorbing all arguments ------+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.+-- -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])+-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty })
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -59,6 +59,7 @@ import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags )+import GHC.Driver.Ppr import GHC.Builtin.Types import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type@@ -68,6 +69,7 @@ import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Unique.FM ( pprUniqFM )
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -71,7 +71,7 @@ -- This pattern synonym makes the simplifier monad eta-expand, -- which as a very beneficial effect on compiler performance -- (worth a 1-2% reduction in bytes-allocated). See #18202.--- See Note [The one-shot state monad trick] in GHC.Core.Unify+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad pattern SM m <- SM' m where SM m = SM' (oneShot m)
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -44,6 +44,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Core import qualified GHC.Core.Subst import GHC.Core.Ppr@@ -68,6 +69,7 @@ import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Opt.ConstantFold import GHC.Data.FastString ( fsLit )
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -42,6 +42,7 @@ import GHC.Types.Basic import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug )+import GHC.Driver.Ppr import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr@@ -49,6 +50,7 @@ import GHC.Data.Pair import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Utils.Monad
compiler/GHC/Core/Opt/Specialise.hs view
@@ -46,8 +46,10 @@ import GHC.Driver.Types import GHC.Data.Bag import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Monad.State import GHC.Types.Unique.DFM
compiler/GHC/Core/Opt/StaticArgs.hs view
@@ -68,6 +68,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Outputable+import GHC.Utils.Panic import Data.List (mapAccumL) import GHC.Data.FastString
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -21,11 +21,13 @@ import GHC.Types.Unique.Supply import GHC.Types.Basic import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.FamInstEnv import GHC.Utils.Monad
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -46,6 +46,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Data.List.SetOps
compiler/GHC/Core/Ppr/TyThing.hs view
@@ -26,6 +26,7 @@ , showToHeader, pprIfaceDecl ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Driver.Types( tyThingParent_maybe )+import GHC.Driver.Ppr import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )
compiler/GHC/Core/Rules.hs view
@@ -60,8 +60,10 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic import GHC.Driver.Session ( DynFlags, gopt, targetPlatform )+import GHC.Driver.Ppr import GHC.Driver.Flags import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag
compiler/GHC/CoreToByteCode.hs view
@@ -50,6 +50,7 @@ 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 )
compiler/GHC/CoreToStg.hs view
@@ -41,8 +41,10 @@ import GHC.Utils.Monad import GHC.Data.FastString import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Driver.Session import GHC.Platform.Ways+import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Types.Demand ( isUsedOnce ) import GHC.Builtin.PrimOps ( PrimCall(..) )
compiler/GHC/CoreToStg/Prep.hs view
@@ -24,6 +24,7 @@ import GHC.Core.Opt.OccurAnal import GHC.Driver.Types+import GHC.Driver.Ppr import GHC.Builtin.Names import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils@@ -47,7 +48,7 @@ import GHC.Builtin.Types import GHC.Core.DataCon import GHC.Types.Basic-import GHC.Unit.Module+import GHC.Unit import GHC.Types.Unique.Supply import GHC.Data.Maybe import GHC.Data.OrdList@@ -55,6 +56,7 @@ import GHC.Driver.Session import GHC.Platform.Ways import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )@@ -721,18 +723,6 @@ ppr (CpeCast co) = text "cast" <+> ppr co ppr (CpeTick tick) = text "tick" <+> ppr tick -{-- Note [runRW arg]-~~~~~~~~~~~~~~~~~~~-If we got, say- runRW# (case bot of {})-which happened in #11291, we do /not/ want to turn it into- (case bot of {}) realWorldPrimId#-because that gives a panic in CoreToStg.myCollectArgs, which expects-only variables in function position. But if we are sure to make-runRW# strict (which we do in GHC.Types.Id.Make), this can't happen--}- cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops cpeApp top_env expr@@ -798,10 +788,6 @@ _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1) -- TODO: What about casts? - cpe_app _env (Var f) args n- | f `hasKey` runRWKey- = pprPanic "cpe_app(runRW#)" (ppr args $$ ppr n)- cpe_app env (Var v) args depth = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1@@ -923,34 +909,96 @@ no further floating will occur. This allows us to safely inline things like @runST@, which are otherwise needlessly expensive (see #10678 and #5916). -'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE-pragma. It is levity-polymorphic.+'runRW' has a variety of quirks: + * 'runRW' is known-key with a NOINLINE definition in+ GHC.Magic. This definition is used in cases where runRW is curried.++ * In addition to its normal Haskell definition in GHC.Magic, we give it+ a special late inlining here in CorePrep and GHC.CoreToByteCode, avoiding+ the incorrect sharing due to float-out noted above.++ * It is levity-polymorphic:+ runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) => (State# RealWorld -> (# State# RealWorld, o #))- -> (# State# RealWorld, o #)+ -> (# State# RealWorld, o #) -It's correctness needs no special treatment in GHC except this special inlining-here in CorePrep (and in GHC.CoreToByteCode).+ * It has some special simplification logic to allow unboxing of results when+ runRW# appears in a strict context. See Note [Simplification of runRW#]+ below. -However, there are a variety of optimisation opportunities that the simplifier-takes advantage of. See Note [Simplification of runRW#].+ * Since its body is inlined, we allow runRW#'s argument to contain jumps to+ join points. That is, the following is allowed: + join j x = ...+ in runRW# @_ @_ (\s -> ... jump j 42 ...) + The Core Linter knows about this. See Note [Linting of runRW#] in+ GHC.Core.Lint for details.++ The occurrence analyser and SetLevels also know about this, as described in+ Note [Simplification of runRW#].++Other relevant Notes:++ * Note [Simplification of runRW#] below, describing a transformation of runRW+ applications in strict contexts performed by the simplifier.+ * Note [Linting of runRW#] in GHC.Core.Lint+ * Note [runRW arg] below, describing a non-obvious case where the+ late-inlining could go wrong.+++ Note [runRW arg]+~~~~~~~~~~~~~~~~~~~+Consider the Core program (from #11291),++ runRW# (case bot of {})++The late inlining logic in cpe_app would transform this into:++ (case bot of {}) realWorldPrimId#++Which would rise to a panic in CoreToStg.myCollectArgs, which expects only+variables in function position.++However, as runRW#'s strictness signature captures the fact that it will call+its argument this can't happen: the simplifier will transform the bottoming+application into simply (case bot of {}).++Note that this reasoning does *not* apply to non-bottoming continuations like:++ hello :: Bool -> Int+ hello n =+ runRW# (+ case n of+ True -> \s -> 23+ _ -> \s -> 10)++Why? The difference is that (case bot of {}) is considered by okCpeArg to be+trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both+the function and the arguments) will forgo binding it to a variable. By+contrast, in the non-bottoming case of `hello` above the function will be+deemed non-trivial and consequently will be case-bound.++ Note [Simplification of runRW#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the program, - case runRW# (\s -> let n = I# 42# in n) of+ case runRW# (\s -> I# 42#) of I# n# -> f n# There is no reason why we should allocate an I# constructor given that we-immediately destructure it. To avoid this the simplifier will push strict-contexts into runRW's continuation. That is, it transforms+immediately destructure it. +To avoid this the simplifier has a special transformation rule, specific to+runRW#, that pushes a strict context into runRW#'s continuation. See the+`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`. That is, it transforms+ K[ runRW# @r @ty cont ] ~>- runRW# @r @ty K[cont]+ runRW# @r @ty (\s -> K[cont s]) This has a few interesting implications. Consider, for instance, this program: @@ -969,15 +1017,29 @@ If runRW# were a "normal" function this call to join point j would not be allowed in its continuation argument. However, since runRW# is inlined (as described in Note [runRW magic] above), such join point occurences are-completely fine. Both occurrence analysis and Core Lint have special treatment-for runRW# applications. See Note [Linting of runRW#] for details on the latter.+completely fine. Both occurrence analysis (see the runRW guard in occAnalApp)+and Core Lint (see the App case of lintCoreExpr) have special treatment for+runRW# applications. See Note [Linting of runRW#] for details on the latter. Moreover, it's helpful to ensure that runRW's continuation isn't floated out-(since doing so would then require a call, whereas we would otherwise end up-with straight-line). Consequently, GHC.Core.Opt.SetLevels.lvlApp has special-treatment for runRW# applications, ensure the arguments are not floated if+For instance, if we have++ runRW# (\s -> do_something)++where do_something contains only top-level free variables, we may be tempted to+float the argument to the top-level. However, we must resist this urge as since+doing so would then require that runRW# produce an allocation and call, e.g.:++ let lvl = \s -> do_somethign+ in+ ....(runRW# lvl)....++whereas without floating the inlining of the definition of runRW would result+in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special+treatment for runRW# applications, ensure the arguments are not floated as MFEs. + Other considered designs ------------------------ @@ -1494,10 +1556,11 @@ let dflags = hsc_dflags hsc_env platform = targetPlatform dflags+ home_unit = mkHomeUnitFromFlags dflags guardBignum act- | homeUnitId dflags == primUnitId+ | isHomeUnitInstanceOf home_unit primUnitId = return $ panic "Bignum literals are not supported in ghc-prim"- | homeUnitId dflags == bignumUnitId+ | isHomeUnitInstanceOf home_unit bignumUnitId = return $ panic "Bignum literals are not supported in ghc-bignum" | otherwise = act
compiler/GHC/Data/Graph/Color.hs view
@@ -25,6 +25,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable+import GHC.Utils.Panic import Data.Maybe import Data.List
compiler/GHC/Data/Graph/Ops.hs view
@@ -41,6 +41,7 @@ import GHC.Data.Graph.Base import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Unique.FM
compiler/GHC/Driver/Backpack.hs view
@@ -29,6 +29,7 @@ import GHC.Parser.Lexer import GHC.Driver.Monad import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Tc.Utils.Monad import GHC.Tc.Module import GHC.Unit@@ -87,7 +88,7 @@ -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. let pkgstate = unitState dflags- let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp+ let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgname_bkp) pkgname_bkp initBkpM src_filename bkp $ forM_ (zip [1..] bkp) $ \(i, lunit) -> do let comp_name = unLoc (hsunitName (unLoc lunit))@@ -95,7 +96,7 @@ innerBkpM $ do let (cid, insts) = computeUnitId lunit if null insts- then if cid == Indefinite (UnitId (fsLit "main")) Nothing+ then if cid == Indefinite (UnitId (fsLit "main")) then compileExe lunit else compileUnit cid [] else typecheckUnit cid insts@@ -136,7 +137,7 @@ -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags- let cid_fs = unitIdFS (indefUnit cid)+ let cid_fs = unitFS (indefUnit cid) is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) cid_str = unpackFS cid_fs@@ -171,12 +172,12 @@ backend = case session_type of TcSession -> NoBackend _ -> backend dflags,- homeUnitInstantiations = insts,+ homeUnitInstantiations_ = insts, -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no -- sense (we're not instantiating anything)- homeUnitInstanceOfId = if null insts then Nothing else Just cid,- homeUnitId =+ homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid),+ homeUnitId_ = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances@@ -208,7 +209,7 @@ withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = do- withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this+ withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) getSource cid = do@@ -285,7 +286,6 @@ dflags <- getDynFlags mod_graph <- hsunitModuleGraph dflags (unLoc lunit)- -- pprTrace "mod_graph" (ppr mod_graph) $ return () msg <- mkBackpackMsg ok <- load' LoadAllTargets (Just msg) mod_graph@@ -309,6 +309,7 @@ let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs+ unit_id = homeUnitId (mkHomeUnitFromFlags (hsc_dflags hsc_env)) return GenericUnitInfo { -- Stub data@@ -316,7 +317,7 @@ unitPackageId = PackageId compat_fs, unitPackageName = compat_pn, unitPackageVersion = makeVersion [],- unitId = toUnitId (homeUnit dflags),+ unitId = unit_id, unitComponentName = Nothing, unitInstanceOf = cid, unitInstantiations = insts,@@ -490,9 +491,10 @@ -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation).-backpackProgressMsg :: Int -> DynFlags -> String -> IO ()+backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO () backpackProgressMsg level dflags msg =- compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg+ compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr+ <> msg -- | Creates a 'Messager' for Backpack compilation; this is basically -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which@@ -502,17 +504,18 @@ level <- getBkpLevel return $ \hsc_env mod_index recomp mod_summary -> let dflags = hsc_dflags hsc_env+ state = unitState dflags showMsg msg reason =- backpackProgressMsg level dflags $- showModuleIndex mod_index ++- msg ++ showModMsg dflags (recompileRequired recomp) mod_summary- ++ reason+ backpackProgressMsg level dflags $ pprWithUnitState state $+ showModuleIndex mod_index <>+ msg <> showModMsg dflags (recompileRequired recomp) mod_summary+ <> reason in case recomp of- MustCompile -> showMsg "Compiling " ""+ MustCompile -> showMsg (text "Compiling ") empty UpToDate- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""+ | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return ()- RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")+ RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]") -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not@@ -530,27 +533,29 @@ dflags <- getDynFlags level <- getBkpLevel liftIO . backpackProgressMsg level dflags- $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn+ $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn -- | Message when we instantiate a Backpack unit. msgUnitId :: Unit -> BkpM () msgUnitId pk = do dflags <- getDynFlags level <- getBkpLevel+ let state = unitState dflags liftIO . backpackProgressMsg level dflags- $ "Instantiating " ++ renderWithStyle- (initSDocContext dflags backpackStyle)- (ppr pk)+ $ pprWithUnitState state+ $ text "Instantiating "+ <> withPprStyle backpackStyle (ppr pk) -- | Message when we include a Backpack unit. msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do dflags <- getDynFlags level <- getBkpLevel+ let state = unitState dflags liftIO . backpackProgressMsg level dflags- $ showModuleIndex (i, n) ++ "Including " ++- renderWithStyle (initSDocContext dflags backpackStyle)- (ppr uid)+ $ pprWithUnitState state+ $ showModuleIndex (i, n) <> text "Including "+ <> withPprStyle backpackStyle (ppr uid) -- ---------------------------------------------------------------------------- -- Conversion from PackageName to HsComponentId@@ -559,12 +564,12 @@ -- For now, something really simple, since we're not actually going -- to use this for anything-unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)-unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })- = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs))+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+ = (pn, HsComponentId pn (Indefinite (UnitId fs))) -bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId-bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)+bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId+bkpPackageNameMap units = Map.fromList (map unitDefines units) renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] renameHsUnits pkgstate m units = map (fmap renameHsUnit) units@@ -641,6 +646,7 @@ hsunitModuleGraph dflags unit = do let decls = hsunitBody unit pn = hsPackageName (unLoc (hsunitName unit))+ home_unit = mkHomeUnitFromFlags dflags -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature.@@ -654,7 +660,7 @@ -- requirement. let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) | n <- nodes ]- req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) ->+ req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> let has_local = Map.member (mod_name, True) node_map in if has_local then return Nothing
compiler/GHC/Driver/CodeOutput.hs view
@@ -30,12 +30,14 @@ import GHC.Cmm.CLabel import GHC.Driver.Types import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.Stream ( Stream ) import qualified GHC.Data.Stream as Stream import GHC.SysTools.FileCleanup import GHC.Utils.Error import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Unit import GHC.Types.SrcLoc import GHC.Types.CostCentre@@ -125,27 +127,10 @@ outputC dflags filenm cmm_stream packages = do withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do-- -- figure out which header files to #include in the generated .hc file:- --- -- * extra_includes from packages- -- * -#include options from the cmdline and OPTIONS pragmas- -- * the _stub.h file, if there is one.- --- let rts = unsafeLookupUnitId (unitState dflags) rtsUnitId-- let cc_injects = unlines (map mk_include (unitIncludes rts))- mk_include h_file =- case h_file of- '"':_{-"-} -> "#include "++h_file- '<':_ -> "#include "++h_file- _ -> "#include \""++h_file++"\""- let pkg_names = map unitIdString packages- doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")- hPutStr h cc_injects+ hPutStr h "#include \"Stg.h\"\n" let platform = targetPlatform dflags writeC = printForC dflags h . cmmToC platform Stream.consume cmm_stream writeC
compiler/GHC/Driver/Finder.hs view
@@ -44,6 +44,7 @@ import GHC.Driver.Session import GHC.Platform.Ways import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust ) import Data.IORef ( IORef, readIORef, atomicModifyIORef' )@@ -75,10 +76,9 @@ flushFinderCaches hsc_env = atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where- this_pkg = homeUnit (hsc_dflags hsc_env)- fc_ref = hsc_FC hsc_env- is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True- | otherwise = False+ fc_ref = hsc_FC hsc_env+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ is_ext mod _ = not (isHomeInstalledModule home_unit mod) addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache ref key val =@@ -135,8 +135,8 @@ findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod =- let dflags = hsc_dflags hsc_env- in if moduleUnit mod `unitIdEq` homeUnit dflags+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ in if isHomeInstalledModule home_unit mod then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -175,7 +175,8 @@ -- was successful.) homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache hsc_env mod_name do_this = do- let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ mod = mkHomeInstalledModule home_unit mod_name modLocationCache hsc_env mod do_this findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString@@ -247,21 +248,18 @@ addToFinderCache (hsc_FC hsc_env) mod result return result -mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule-mkHomeInstalledModule dflags mod_name =- let iuid = homeUnitId dflags- in Module iuid mod_name- -- This returns a module because it's more convenient for users addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do- let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ mod = mkHomeInstalledModule home_unit mod_name addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)- return (mkHomeModule (hsc_dflags hsc_env) mod_name)+ return (mkHomeModule home_unit mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () uncacheModule hsc_env mod_name = do- let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ mod = mkHomeInstalledModule home_unit mod_name removeFromFinderCache (hsc_FC hsc_env) mod -- -----------------------------------------------------------------------------@@ -271,7 +269,7 @@ findHomeModule hsc_env mod_name = do r <- findInstalledHomeModule hsc_env mod_name return $ case r of- InstalledFound loc _ -> Found loc (mkModule uid mod_name)+ InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible InstalledNotFound fps _ -> NotFound { fr_paths = fps,@@ -282,8 +280,9 @@ fr_suggestions = [] } where- dflags = hsc_dflags hsc_env- uid = homeUnit dflags+ dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags+ uid = homeUnitAsUnit (mkHomeUnitFromFlags dflags) -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used@@ -306,9 +305,10 @@ homeSearchCache hsc_env mod_name $ let dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags home_path = importPaths dflags hisuf = hiSuf dflags- mod = mkHomeInstalledModule dflags mod_name+ mod = mkHomeInstalledModule home_unit mod_name source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs")@@ -620,11 +620,12 @@ -- Error messages cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc-cannotFindModule flags mod res =+cannotFindModule dflags mod res = pprWithUnitState unit_state $ cantFindErr (sLit cannotFindMsg) (sLit "Ambiguous module name")- flags mod res+ dflags mod res where+ unit_state = unitState dflags cannotFindMsg = case res of NotFound { fr_mods_hidden = hidden_mods@@ -674,6 +675,7 @@ $$ more_info where pkgs = unitState dflags+ home_unit = mkHomeUnitFromFlags dflags more_info = case find_result of NoPackage pkg@@ -683,7 +685,7 @@ NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest }- | Just pkg <- mb_pkg, pkg /= homeUnit dflags+ | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg) -> not_found_in_package pkg files | not (null suggest)@@ -792,6 +794,10 @@ = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where+ home_unit = mkHomeUnitFromFlags dflags+ unit_state = unitState dflags+ build_tag = waysBuildTag (ways dflags)+ more_info = case find_result of InstalledNoPackage pkg@@ -799,7 +805,7 @@ text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg- | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags)+ | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) -> not_found_in_package pkg files | null files@@ -810,14 +816,11 @@ _ -> panic "cantFindInstalledErr" - build_tag = waysBuildTag (ways dflags)- pkgstate = unitState dflags- looks_like_srcpkgid :: UnitId -> SDoc looks_like_srcpkgid pk -- Unsafely coerce a unit id (i.e. an installed package component -- identifier) into a PackageId and see if it means anything.- | (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk))+ | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) = parens (text "This unit ID looks like the source package ID;" $$ text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ (if null pkgs then Outputable.empty
compiler/GHC/Driver/Main.hs view
@@ -101,8 +101,7 @@ import GHC.Core.ConLike import GHC.Parser.Annotation-import GHC.Unit.Module-import GHC.Unit.State+import GHC.Unit import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump@@ -117,7 +116,7 @@ import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) import GHC.Types.Name.Cache ( initNameCache ) import GHC.Builtin.Utils-import GHC.Core.Opt.Driver+import GHC.Core.Opt.Pipeline import GHC.HsToCore import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface ) import GHC.Iface.Make@@ -194,7 +193,8 @@ newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do- eps_var <- newIORef (initExternalPackageState dflags)+ let home_unit = mkHomeUnitFromFlags dflags+ eps_var <- newIORef (initExternalPackageState home_unit) us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv@@ -469,14 +469,15 @@ hsc_env <- getHscEnv let hsc_src = ms_hsc_src mod_summary dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags outer_mod = ms_mod mod_summary mod_name = moduleName outer_mod- outer_mod' = mkHomeModule dflags mod_name- inner_mod = canonicalizeHomeModule dflags mod_name+ outer_mod' = mkHomeModule home_unit mod_name+ inner_mod = homeModuleNameInstantiation home_unit mod_name src_filename = ms_hspp_file mod_summary real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 keep_rn' = gopt Opt_WriteHie dflags || keep_rn- MASSERT( isHomeModule dflags outer_mod )+ MASSERT( isHomeModule home_unit outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else@@ -886,25 +887,25 @@ case recomp of UpToDate -> compilationProgressMsg (hsc_dflags hsc_env) $- "compilation IS NOT required"+ text "compilation IS NOT required" _ -> return () batchMsg :: Messager batchMsg hsc_env mod_index recomp mod_summary = case recomp of- MustCompile -> showMsg "Compiling " ""+ MustCompile -> showMsg (text "Compiling ") empty UpToDate- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""+ | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return ()- RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")+ RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]") where dflags = hsc_dflags hsc_env showMsg msg reason = compilationProgressMsg dflags $- (showModuleIndex mod_index ++- msg ++ showModMsg dflags (recompileRequired recomp) mod_summary)- ++ reason+ (showModuleIndex mod_index <>+ msg <> showModMsg dflags (recompileRequired recomp) mod_summary)+ <> reason -------------------------------------------------------------- -- Safe Haskell@@ -1115,10 +1116,11 @@ -> Hsc (Maybe UnitId, Set UnitId) hscCheckSafe' m l = do dflags <- getDynFlags+ let home_unit = mkHomeUnitFromFlags dflags (tw, pkgs) <- isModSafe m l case tw of- False -> return (Nothing, pkgs)- True | isHomeModule dflags m -> return (Nothing, pkgs)+ False -> return (Nothing, pkgs)+ True | isHomeModule home_unit m -> return (Nothing, pkgs) -- TODO: do we also have to check the trust of the instantiation? -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs)@@ -1172,7 +1174,8 @@ pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!"- , text "The package (" <> ppr (moduleUnit m)+ , text "The package ("+ <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $@@ -1193,7 +1196,7 @@ packageTrusted _ Sf_Safe False _ = True packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m- | isHomeModule dflags m = True+ | isHomeModule (mkHomeUnitFromFlags dflags) m = True | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface)@@ -1223,8 +1226,10 @@ = acc | otherwise = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)- $ text "The package (" <> ppr pkg <> text ") is required" <>- text " to be trusted but it isn't!"+ $ pprWithUnitState state+ $ text "The package ("+ <> ppr pkg+ <> text ") is required to be trusted but it isn't!" case errors of [] -> return () _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors@@ -1486,14 +1491,15 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do- let dflags = hsc_dflags hsc_env+ let dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename- cmm_mod = mkHomeModule dflags mod_name+ cmm_mod = mkHomeModule home_unit mod_name -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis.@@ -1937,9 +1943,9 @@ %* * %********************************************************************* -} -showModuleIndex :: (Int, Int) -> String-showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "+showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " where- n_str = show n- i_str = show i- padded = replicate (length n_str - length i_str) ' ' ++ i_str+ -- compute the length of x > 0 in base 10+ len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+ pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
compiler/GHC/Driver/Make.hs view
@@ -46,7 +46,7 @@ import GHC.Driver.Monad import GHC.Parser.Header import GHC.Driver.Types-import GHC.Unit.Module+import GHC.Unit import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Driver.Main@@ -66,7 +66,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Tc.Utils.Backpack-import GHC.Unit.State import GHC.Types.Unique.Set import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt@@ -655,10 +654,10 @@ old_ic = hsc_IC hsc_env empty_ic = emptyInteractiveContext dflags keep_external_name ic_name- | nameIsFromExternalPackage this_pkg old_name = old_name+ | nameIsFromExternalPackage home_unit old_name = old_name | otherwise = ic_name empty_ic where- this_pkg = homeUnit dflags+ home_unit = mkHomeUnitFromFlags dflags old_name = ic_name old_ic -- | If there is no -o option, guess the name of target executable@@ -1202,13 +1201,14 @@ let home_imps = map unLoc $ ms_home_imps mod let home_src_imps = map unLoc $ ms_home_srcimps mod+ let home_unit = mkHomeUnitFromFlags lcl_dflags -- All the textual imports of this module. let textual_deps = Set.fromList $ zipWith f home_imps (repeat NotBoot) ++ zipWith f home_src_imps (repeat IsBoot) where f mn isBoot = GWIB- { gwib_mod = mkHomeModule lcl_dflags mn+ { gwib_mod = mkHomeModule home_unit mn , gwib_isBoot = isBoot } @@ -2210,7 +2210,7 @@ backend dflags == NoBackend && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219.- homeUnitIsDefinite dflags+ isHomeUnitDefinite (mkHomeUnitFromFlags dflags) -- | Update the every ModSummary that is depended on -- by a module that needs unboxed tuples. We enable codegen to@@ -2499,6 +2499,7 @@ | otherwise = find_it where dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags check_timestamp old_summary location src_fn = checkSummaryTimestamp@@ -2557,12 +2558,12 @@ $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)- : homeUnitInstantiations dflags)+ : homeUnitInstantiations home_unit) ]) in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
compiler/GHC/Driver/MakeFile.hs view
@@ -20,6 +20,7 @@ import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Driver.Types import qualified GHC.SysTools as SysTools
compiler/GHC/Driver/Pipeline.hs view
@@ -40,7 +40,7 @@ import GHC.Prelude import GHC.Driver.Pipeline.Monad-import GHC.Unit.State+import GHC.Unit import GHC.Platform.Ways import GHC.Platform.ArchOS import GHC.Parser.Header@@ -51,10 +51,10 @@ import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) import GHC.Utils.Outputable-import GHC.Unit.Module import GHC.Utils.Error import GHC.Driver.Session import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )@@ -381,7 +381,8 @@ -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 empty_stub <- newTempName dflags TFL_CurrentModule "c"- let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;"+ let home_unit = mkHomeUnitFromFlags dflags+ src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env (empty_stub, Nothing, Nothing)@@ -473,7 +474,7 @@ return Succeeded else do - compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")+ compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of@@ -515,9 +516,9 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line.- let pkgstate = unitState dflags- let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)- | Just c <- map (lookupUnitId pkgstate) pkg_deps,+ let unit_state = unitState dflags+ let pkg_hslibs = [ (collectLibraryPaths (ways dflags) [c], lib)+ | Just c <- map (lookupUnitId unit_state) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs@@ -1226,6 +1227,7 @@ = do let platform = targetPlatform dflags hcc = cc_phase `eqPhase` HCc+ home_unit = mkHomeUnitFromFlags dflags let cmdline_include_paths = includePaths dflags @@ -1235,7 +1237,11 @@ -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :)- pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs+ pkg_include_dirs <- liftIO $ getUnitIncludePath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ pkgs let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -1263,11 +1269,19 @@ pkg_extra_cc_opts <- liftIO $ if hcc then return []- else getUnitExtraCcOpts dflags pkgs+ else getUnitExtraCcOpts+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ pkgs framework_paths <- if platformUsesFrameworks platform- then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs+ then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ pkgs let cmdlineFrameworkPaths = frameworkPaths dflags return $ map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)@@ -1314,7 +1328,7 @@ -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 &&- homeUnitId dflags == baseUnitId+ isHomeUnitId home_unit baseUnitId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1670,7 +1684,12 @@ then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn)- pkg_lib_paths <- getUnitLibraryPath dflags dep_units+ pkg_lib_paths <- getUnitLibraryPath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ (ways dflags)+ dep_units let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | osElfTarget (platformOS platform) &&@@ -1939,7 +1958,11 @@ output_exists <- doesFileExist full_output_fn (when output_exists) $ removeFile full_output_fn - pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units+ pkg_cfgs_init <- getPreloadUnitsAnd+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ dep_units let pkg_cfgs | gopt Opt_LinkRts dflags@@ -1968,7 +1991,11 @@ let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags - pkg_include_dirs <- getUnitIncludePath dflags []+ pkg_include_dirs <- getUnitIncludePath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ [] let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -2133,6 +2160,23 @@ Unfortunately the big object format is not supported on 32-bit targets so none of this can be used in that case.+++Note [Merging object files for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi can usually loads standard linkable object files using GHC's linker+implementation. However, most users build their projects with -split-sections,+meaning that such object files can have an extremely high number of sections.+As the linker must map each of these sections individually, loading such object+files is very inefficient.++To avoid this inefficiency, we use the linker's `-r` flag and a linker script+to produce a merged relocatable object file. This file will contain a singe+text section section and can consequently be mapped far more efficiently. As+gcc tends to do unpredictable things to our linker command line, we opt to+invoke ld directly in this case, in contrast to our usual strategy of linking+via gcc.+ -} joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()@@ -2140,34 +2184,13 @@ let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags)- ld_r args cc = GHC.SysTools.runLink dflags ([- GHC.SysTools.Option "-nostdlib",- GHC.SysTools.Option "-Wl,-r"- ]- -- See Note [No PIE while linking] in GHC.Driver.Session- ++ (if toolSettings_ccSupportsNoPie toolSettings'- then [GHC.SysTools.Option "-no-pie"]- else [])-- ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]- then []- else [GHC.SysTools.Option "-nodefaultlibs"])- ++ (if osInfo == OSFreeBSD- then [GHC.SysTools.Option "-L/usr/lib"]- else [])- -- gcc on sparc sets -Wl,--relax implicitly, but- -- -r and --relax are incompatible for ld, so- -- disable --relax explicitly.- ++ (if platformArch (targetPlatform dflags)- `elem` [ArchSPARC, ArchSPARC64]- && ldIsGnuLd- then [GHC.SysTools.Option "-Wl,-no-relax"]- else [])+ ld_r args = GHC.SysTools.runMergeObjects dflags ( -- See Note [Produce big objects on Windows]- ++ [ GHC.SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"- | OSMinGW32 == osInfo- , not $ target32Bit (targetPlatform dflags)- ]+ concat+ [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]+ | OSMinGW32 == osInfo+ , not $ target32Bit (targetPlatform dflags)+ ] ++ map GHC.SysTools.Option ld_build_id ++ [ GHC.SysTools.Option "-o", GHC.SysTools.FileOption "" output_fn ]@@ -2176,25 +2199,24 @@ -- suppress the generation of the .note.gnu.build-id section, -- which we don't need and sometimes causes ld to emit a -- warning:- ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"]+ ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] | otherwise = [] - ccInfo <- getCompilerInfo dflags if ldIsGnuLd then do script <- newTempName dflags TFL_CurrentModule "ldscript" cwd <- getCurrentDirectory let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"- ld_r [GHC.SysTools.FileOption "" script] ccInfo+ ld_r [GHC.SysTools.FileOption "" script] else if toolSettings_ldSupportsFilelist toolSettings' then do filelist <- newTempName dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files- ld_r [GHC.SysTools.Option "-Wl,-filelist",- GHC.SysTools.FileOption "-Wl," filelist] ccInfo+ ld_r [GHC.SysTools.Option "-filelist",+ GHC.SysTools.FileOption "" filelist] else do- ld_r (map (GHC.SysTools.FileOption "") o_files) ccInfo+ ld_r (map (GHC.SysTools.FileOption "") o_files) -- ----------------------------------------------------------------------------- -- Misc.@@ -2239,7 +2261,11 @@ candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map (</> "ghcversion.h")) <$>- (getUnitIncludePath dflags [rtsUnitId])+ (getUnitIncludePath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ [rtsUnitId]) found <- filterM doesFileExist candidates case found of
compiler/GHC/Hs/Stats.hs view
@@ -14,9 +14,11 @@ import GHC.Data.Bag import GHC.Hs-import GHC.Utils.Outputable import GHC.Types.SrcLoc++import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import Data.Char
compiler/GHC/HsToCore.hs view
@@ -50,7 +50,7 @@ import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make-import GHC.Unit.Module+import GHC.Unit import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.Rules@@ -61,6 +61,7 @@ import GHC.Data.FastString import GHC.Utils.Error import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.HsToCore.Coverage import GHC.Utils.Misc@@ -118,7 +119,11 @@ }) = do { let dflags = hsc_dflags hsc_env- print_unqual = mkPrintUnqualified dflags rdr_env+ home_unit = mkHomeUnitFromFlags dflags+ print_unqual = mkPrintUnqualified+ (unitState dflags)+ home_unit+ rdr_env ; withTiming dflags (text "Desugar"<+>brackets (ppr mod)) (const ()) $@@ -173,9 +178,9 @@ ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env- pluginModules =- map lpModule (cachedPlugins (hsc_dflags hsc_env))- ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env))+ pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ ; deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used
compiler/GHC/HsToCore/Arrows.hs view
@@ -52,6 +52,7 @@ import GHC.Types.Basic import GHC.Builtin.Names import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe )
compiler/GHC/HsToCore/Binds.hs view
@@ -33,7 +33,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )+import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs ) import GHC.Hs -- lots of things import GHC.Core -- lots of things@@ -63,6 +63,7 @@ import GHC.Types.Var.Env import GHC.Types.Var( EvVar ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Data.Maybe@@ -70,13 +71,13 @@ import GHC.Data.Bag import GHC.Types.Basic import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Utils.Misc import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import GHC.Utils.Monad import qualified GHC.LanguageExtensions as LangExt import Control.Monad-import Data.List.NonEmpty ( nonEmpty ) {-********************************************************************** * *@@ -181,10 +182,10 @@ return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss- , pat_ext = NPatBindTc _ ty+ , pat_ext = ty , pat_ticks = (rhs_tick, var_ticks) })- = do { rhss_deltas <- checkGuardMatches PatBindGuards grhss- ; body_expr <- dsGuarded grhss ty (nonEmpty rhss_deltas)+ = do { rhss_deltas <- checkGRHSs PatBindGuards grhss+ ; body_expr <- dsGuarded grhss ty rhss_deltas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
compiler/GHC/HsToCore/Coverage.hs view
@@ -23,8 +23,10 @@ import GHC.Hs import GHC.Unit import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Driver.Session import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Core.ConLike import Control.Monad import GHC.Types.SrcLoc
compiler/GHC/HsToCore/Expr.hs view
@@ -16,7 +16,6 @@ module GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr- , dsHandleMonadicFailure ) where @@ -32,7 +31,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )+import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType )@@ -67,10 +66,10 @@ import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Core.PatSyn import Control.Monad-import Data.List.NonEmpty ( nonEmpty ) {- ************************************************************************@@ -213,11 +212,11 @@ ; return (bindNonRec fun rhs' body) } dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss- , pat_ext = NPatBindTc _ ty }) body+ , pat_ext = ty }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body- do { rhs_deltas <- checkGuardMatches PatBindGuards grhss- ; rhs <- dsGuarded grhss ty (nonEmpty rhs_deltas)+ do { match_deltas <- checkGRHSs PatBindGuards grhss+ ; rhs <- dsGuarded grhss ty match_deltas ; let upat = unLoc pat eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource,@@ -487,8 +486,8 @@ | otherwise = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds)- ; rhss_deltas <- checkGuardMatches IfAlt grhss- ; match_result <- dsGRHSs IfAlt grhss res_ty (nonEmpty rhss_deltas)+ ; rhss_deltas <- checkGRHSs IfAlt grhss+ ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_deltas ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } where@@ -989,7 +988,7 @@ ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat ; match <- matchSinglePatVar var (StmtCtxt ctx) pat (xbstc_boundResultType xbs) (cantFailMatchResult body)- ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)+ ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } go _ (ApplicativeStmt body_ty args mb_join) stmts@@ -1010,7 +1009,7 @@ = do { var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var (StmtCtxt ctx) pat body_ty (cantFailMatchResult body)- ; match_code <- dsHandleMonadicFailure pat match fail_op+ ; match_code <- dsHandleMonadicFailure ctx pat match fail_op ; return (var:vs, match_code) } @@ -1064,31 +1063,6 @@ go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt"--dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr- -- In a do expression, pattern-match failure just calls- -- the monadic 'fail' rather than throwing an exception-dsHandleMonadicFailure pat match m_fail_op =- case shareFailureHandler match of- MR_Infallible body -> body- MR_Fallible body -> do- fail_op <- case m_fail_op of- -- Note that (non-monadic) list comprehension, pattern guards, etc could- -- have fallible bindings without an explicit failure op, but this is- -- handled elsewhere. See Note [Failing pattern matches in Stmts] the- -- breakdown of regular and special binds.- Nothing -> pprPanic "missing fail op" $- text "Pattern match:" <+> ppr pat <+>- text "is failable, and fail_expr was left unset"- Just fail_op -> pure fail_op- dflags <- getDynFlags- fail_msg <- mkStringExpr (mk_fail_msg dflags pat)- fail_expr <- dsSyntaxExpr fail_op [fail_msg]- body fail_expr--mk_fail_msg :: DynFlags -> Located e -> String-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++- showPpr dflags (getLoc pat) {- ************************************************************************
compiler/GHC/HsToCore/Expr.hs-boot view
@@ -1,6 +1,6 @@ module GHC.HsToCore.Expr where-import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )-import GHC.HsToCore.Monad ( DsM, MatchResult )+import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )+import GHC.HsToCore.Monad ( DsM ) import GHC.Core ( CoreExpr ) import GHC.Hs.Extension ( GhcTc) @@ -8,5 +8,3 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr--dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -50,6 +50,7 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import Data.Maybe
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -43,6 +43,7 @@ import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Types+import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types import GHC.Builtin.Types.Prim@@ -55,6 +56,7 @@ import GHC.Platform import GHC.Data.OrdList import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Utils.Encoding
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -25,11 +25,12 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas )+import GHC.HsToCore.PmCheck.Types ( Deltas ) import GHC.Core.Type ( Type ) import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )@@ -47,9 +48,9 @@ necessary. The type argument gives the type of the @ei@. -} -dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> Maybe (NonEmpty Deltas) -> DsM CoreExpr-dsGuarded grhss rhs_ty mb_rhss_deltas = do- match_result <- dsGRHSs PatBindRhs grhss rhs_ty mb_rhss_deltas+dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Deltas -> DsM CoreExpr+dsGuarded grhss rhs_ty rhss_deltas = do+ match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_deltas error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr @@ -58,25 +59,28 @@ dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs -> Type -- ^ Type of RHS- -> Maybe (NonEmpty Deltas) -- ^ Refined pattern match checking- -- models, one for each GRHS. Defaults- -- to 'initDeltas' if 'Nothing'.+ -> NonEmpty Deltas -- ^ Refined pattern match checking+ -- models, one for the pattern part and+ -- one for each GRHS. -> DsM (MatchResult CoreExpr)-dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_deltas = ASSERT( notNull grhss )- do { match_results <- case toList <$> mb_rhss_deltas of- Nothing -> mapM (dsGRHS hs_ctx rhs_ty initDeltas) grhss- Just rhss_deltas -> ASSERT( length grhss == length rhss_deltas )- zipWithM (dsGRHS hs_ctx rhs_ty) rhss_deltas grhss- ; let match_result1 = foldr1 combineMatchResults match_results- match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1+ do { match_results <- ASSERT( length grhss == length rhss_deltas )+ zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_deltas) grhss+ ; deltas <- getPmDeltas+ -- We need to remember the Deltas from the particular match context we+ -- are in, which might be different to when dsLocalBinds is actually+ -- called.+ ; let ds_binds = updPmDeltas deltas . dsLocalBinds binds+ match_result1 = foldr1 combineMatchResults match_results+ match_result2 = adjustMatchResultDs ds_binds match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs))- = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty)+ = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_deltas rhs rhs_ty {- ************************************************************************@@ -88,6 +92,7 @@ matchGuards :: [GuardStmt GhcTc] -- Guard -> HsStmtContext GhcRn -- Context+ -> Deltas -- The RHS's covered set for PmCheck -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM (MatchResult CoreExpr)@@ -95,8 +100,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ rhs _- = do { core_rhs <- dsLExpr rhs+matchGuards [] _ deltas rhs _+ = do { core_rhs <- updPmDeltas deltas (dsLExpr rhs) ; return (cantFailMatchResult core_rhs) } -- BodyStmts must be guards@@ -106,41 +111,41 @@ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx deltas rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do- match_result <- matchGuards stmts ctx rhs rhs_ty+ match_result <- matchGuards stmts ctx deltas rhs rhs_ty return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do- match_result <- matchGuards stmts ctx rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx deltas rhs rhs_ty = do+ match_result <- matchGuards stmts ctx deltas rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do- match_result <- matchGuards stmts ctx rhs rhs_ty+matchGuards (LetStmt _ binds : stmts) ctx deltas rhs rhs_ty = do+ match_result <- matchGuards stmts ctx deltas rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx deltas rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar Many upat -- We only allow unrestricted patterns in guard, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. - match_result <- matchGuards stmts ctx rhs rhs_ty+ match_result <- matchGuards stmts ctx deltas rhs rhs_ty core_rhs <- dsLExpr bind_rhs match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty match_result pure $ bindNonRec match_var core_rhs <$> match_result' -matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ =+matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"+matchGuards (ApplicativeStmt {} : _) _ _ _ _ = panic "matchGuards ApplicativeLastStmt" {-
compiler/GHC/HsToCore/ListComp.hs view
@@ -16,7 +16,7 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import GHC.Hs import GHC.Tc.Utils.Zonk@@ -35,6 +35,7 @@ import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth ) import GHC.Utils.Misc@@ -618,7 +619,7 @@ ; var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat res1_ty (cantFailMatchResult body)- ; match_code <- dsHandleMonadicFailure pat match fail_op+ ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } -- Desugar nested monad comprehensions, for example in `then..` constructs
compiler/GHC/HsToCore/Match.hs view
@@ -35,6 +35,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.PmCheck+import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) import GHC.Core import GHC.Types.Literal import GHC.Core.Utils@@ -59,12 +60,13 @@ import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad( unless )+import Control.Monad(zipWithM, unless ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map@@ -766,48 +768,46 @@ -- Pattern match check warnings for /this match-group/. -- @rhss_deltas@ is a flat list of covered Deltas for each RHS. -- Each Match will split off one Deltas for its RHSs from this.- ; rhss_deltas <- if isMatchContextPmChecked dflags origin ctxt+ ; matches_deltas <- if isMatchContextPmChecked dflags origin ctxt then addScrutTmCs mb_scr new_vars $- -- See Note [Type and Term Equality Propagation]- checkMatches (DsMatchContext ctxt locn) new_vars matches- else pure [] -- Ultimately this will result in passing Nothing- -- to dsGRHSs as match_deltas+ -- See Note [Type and Term Equality Propagation]+ checkMatches (DsMatchContext ctxt locn) new_vars matches+ else pure (initDeltasMatches matches) - ; eqns_info <- mk_eqn_infos matches rhss_deltas+ ; eqns_info <- zipWithM mk_eqn_info matches matches_deltas ; result_expr <- handleWarnings $ matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where- -- rhss_deltas is a flat list, whereas there are multiple GRHSs per match.- -- mk_eqn_infos will thread rhss_deltas as state through calls to- -- mk_eqn_info, distributing each rhss_deltas to a GRHS.- mk_eqn_infos (L _ match : matches) rhss_deltas- = do { (info, rhss_deltas') <- mk_eqn_info match rhss_deltas- ; infos <- mk_eqn_infos matches rhss_deltas'- ; return (info:infos) }- mk_eqn_infos [] _ = return [] -- Called once per equation in the match, or alternative in the case- mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas- | GRHSs _ grhss' _ <- grhss, let n_grhss = length grhss'+ mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Deltas, NonEmpty Deltas) -> DsM EquationInfo+ mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_deltas, rhss_deltas) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats- -- Split off one Deltas for each GRHS of the current Match from the- -- flat list of GRHS Deltas *for all matches* (see the call to- -- checkMatches above).- ; let (match_deltas, rhss_deltas') = splitAt n_grhss rhss_deltas- -- The list of Deltas is empty iff we don't perform any coverage- -- checking, in which case nonEmpty does the right thing by passing- -- Nothing.- ; match_result <- dsGRHSs ctxt grhss rhs_ty (NEL.nonEmpty match_deltas)- ; return ( EqnInfo { eqn_pats = upats- , eqn_orig = FromSource- , eqn_rhs = match_result }- , rhss_deltas' ) }+ -- pat_deltas is the covered set *after* matching the pattern, but+ -- before any of the GRHSs. We extend the environment with pat_deltas+ -- (via updPmDeltas) so that the where-clause of 'grhss' can profit+ -- from that knowledge (#18533)+ ; match_result <- updPmDeltas pat_deltas $+ dsGRHSs ctxt grhss rhs_ty rhss_deltas+ ; return EqnInfo { eqn_pats = upats+ , eqn_orig = FromSource+ , eqn_rhs = match_result } } handleWarnings = if isGenerated origin then discardWarningsDs else id++ initDeltasMatches :: [LMatch GhcTc b] -> [(Deltas, NonEmpty Deltas)]+ initDeltasMatches ms+ = map (\(L _ m) -> (initDeltas, initDeltasGRHSs (m_grhss m))) ms++ initDeltasGRHSs :: GRHSs GhcTc b -> NonEmpty Deltas+ initDeltasGRHSs m = expectJust "GRHSs non-empty"+ $ NEL.nonEmpty+ $ replicate (length (grhssGRHSs m)) initDeltas+ matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -36,6 +36,7 @@ import GHC.Types.FieldLabel ( flSelector ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))@@ -125,7 +126,7 @@ PatSynCon psyn -> alt{ alt_pat = psyn } _ -> panic "matchPatSyn: not PatSynCon" -type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))+type ConArgPats = HsConPatDetails GhcTc matchOneConLike :: [Id] -> Type
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -53,6 +53,7 @@ import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
compiler/GHC/HsToCore/Monad.hs view
@@ -84,7 +84,9 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Error+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly ) import GHC.Types.Literal ( mkLitString )@@ -292,7 +294,10 @@ gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_if_env = (if_genv, if_lenv)- , ds_unqual = mkPrintUnqualified dflags rdr_env+ , ds_unqual = mkPrintUnqualified+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ rdr_env , ds_msgs = msg_var , ds_complete_matches = completeMatchMap , ds_cc_st = cc_st_var@@ -405,7 +410,7 @@ -- | Set the pattern match oracle state within the scope of the given action. -- See 'dsl_deltas'. updPmDeltas :: Deltas -> DsM a -> DsM a-updPmDeltas delta = updLclEnv (\env -> env { dsl_deltas = delta })+updPmDeltas deltas = updLclEnv (\env -> env { dsl_deltas = deltas }) getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv
compiler/GHC/HsToCore/PmCheck.hs view
@@ -10,10 +10,11 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} module GHC.HsToCore.PmCheck ( -- Checking and printing- checkSingle, checkMatches, checkGuardMatches,+ checkSingle, checkMatches, checkGRHSs, isMatchContextPmChecked, -- See Note [Type and Term Equality Propagation]@@ -41,6 +42,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Types.Var (EvVar)@@ -65,6 +67,7 @@ import Control.Monad (when, forM_, zipWithM) import Data.List (elemIndex) import qualified Data.Semigroup as Semi+import Data.List.NonEmpty (NonEmpty(..)) {- This module checks pattern matches for:@@ -103,8 +106,12 @@ } -- | @PmBang x@ corresponds to a @seq x True@ guard.+ -- If the extra SrcInfo is present, the bang guard came from a source+ -- bang pattern, in which case we might want to report it as redundant,+ -- see Note [Dead bang patterns]. | PmBang {- pm_id :: !Id+ pm_id :: !Id,+ pm_loc :: !(Maybe SrcInfo) } -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually@@ -118,7 +125,7 @@ instance Outputable PmGrd where ppr (PmCon x alt _tvs _con_dicts con_args) = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]- ppr (PmBang x) = char '!' <> ppr x+ ppr (PmBang x _loc) = char '!' <> ppr x ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr] type GrdVec = [PmGrd]@@ -137,49 +144,84 @@ mempty = Precise mappend = (Semi.<>) --- | Means by which we identify a RHS for later pretty-printing in a warning--- message. 'SDoc' for the equation to show, 'Located' for the location.-type RhsInfo = Located SDoc+-- | Means by which we identify source location for later pretty-printing+-- in a warning message. 'SDoc' for the equation to show, 'Located' for+-- the location.+type SrcInfo = Located SDoc -- | A representation of the desugaring to 'PmGrd's of all clauses of a -- function definition/pattern match/etc. data GrdTree- = Rhs !RhsInfo+ = Rhs !SrcInfo | Guard !PmGrd !GrdTree -- ^ @Guard grd t@ will try to match @grd@ and on success continue to match -- @t@. Falls through if either match fails. Models left-to-right semantics -- of pattern matching.- | Sequence !GrdTree !GrdTree- -- ^ @Sequence l r@ first matches against @l@, and then matches all- -- fallen-through values against @r@. Models top-to-bottom semantics of- -- pattern matching.- | Empty- -- ^ A @GrdTree@ that always fails. Most useful for- -- Note [Checking EmptyCase]. A neutral element to 'Sequence'.+ | Sequence ![GrdTree]+ -- ^ @Sequence (t:ts)@ matches against @t@, and then matches all+ -- fallen-through values against @Sequence ts@. Models top-to-bottom semantics+ -- of pattern matching.+ -- @Sequence []@ always fails; it is useful for Note [Checking EmptyCase]. +{- Note [Dead bang patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++ f :: Bool -> Int+ f True = 1+ f !x = 2++Whenever we fall through to the second equation, we will already have evaluated+the argument. Thus, the bang pattern serves no purpose and should be warned+about. We call this kind of bang patterns "dead". Dead bangs are the ones+that under no circumstances can force a thunk that wasn't already forced.+Dead bangs are a form of redundant bangs; see below.++We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable+where the PmBang appears in 'checkGrdTree'. If not, then clearly the bang is+dead. Such a dead bang is then indicated in the annotated pattern-match tree by+a 'RedundantSrcBang' wrapping. In 'redundantAndInaccessibles', we collect+all dead bangs to warn about.++Note that we don't want to warn for a dead bang that appears on a redundant+clause. That is because in that case, we recommend to delete the clause wholly,+including its leading pattern match.++Dead bang patterns are redundant. But there are bang patterns which are+redundant that aren't dead, for example++ f !() = 0++the bang still forces the match variable, before we attempt to match on (). But+it is redundant with the forcing done by the () match. We currently don't+detect redundant bangs that aren't dead.+-}+ -- | The digest of 'checkGrdTree', representing the annotated pattern-match--- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper--- inaccessible RHSs from this.+-- tree. 'extractRedundancyInfo' can figure out redundant and proper+-- inaccessible RHSs from this, as well as dead bangs. data AnnotatedTree- = AccessibleRhs !Deltas !RhsInfo+ = AccessibleRhs !Deltas !SrcInfo -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered -- values.- | InaccessibleRhs !RhsInfo+ | InaccessibleRhs !SrcInfo -- ^ A RHS deemed inaccessible; it covers no value. | MayDiverge !AnnotatedTree -- ^ Asserts that the tree may force diverging values, so not all of its -- clauses can be redundant.- | SequenceAnn !AnnotatedTree !AnnotatedTree- -- ^ Mirrors 'Sequence' for preserving the skeleton of a 'GrdTree's.- | EmptyAnn- -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's.+ | SequenceAnn !Deltas ![AnnotatedTree]+ -- ^ @SequenceAnn inc ts@ mirrors @'Sequence' ts@ for preserving the+ -- skeleton of a 'GrdTree's @ts@. It also carries the set of incoming values+ -- @inc@.+ | RedundantSrcBang !SrcInfo !AnnotatedTree+ -- ^ For tracking redundant bangs. See Note [Dead bang patterns] -pprRhsInfo :: RhsInfo -> SDoc-pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss)-pprRhsInfo (L s _) = ppr s+pprSrcInfo :: SrcInfo -> SDoc+pprSrcInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss)+pprSrcInfo (L s _) = ppr s instance Outputable GrdTree where- ppr (Rhs info) = text "->" <+> pprRhsInfo info+ ppr (Rhs info) = text "->" <+> pprSrcInfo info -- Format guards as "| True <- x, let x = 42, !z" ppr g@Guard{} = fsep (prefix (map ppr grds)) <+> ppr t where@@ -188,23 +230,16 @@ collect_grds t = (t, []) prefix [] = [] prefix (s:sdocs) = char '|' <+> s : map (comma <+>) sdocs- -- Format nested Sequences in blocks "{ grds1; grds2; ... }"- ppr t@Sequence{} = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)- where- collect_seqs (Sequence l r) = collect_seqs l ++ collect_seqs r- collect_seqs t = [ppr t]- ppr Empty = text "<empty case>"+ ppr (Sequence []) = text "<empty case>"+ ppr (Sequence ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space) instance Outputable AnnotatedTree where- ppr (AccessibleRhs _ info) = pprRhsInfo info- ppr (InaccessibleRhs info) = text "inaccessible" <+> pprRhsInfo info+ ppr (AccessibleRhs _delta info) = parens (ppr _delta) <+> pprSrcInfo info+ ppr (InaccessibleRhs info) = text "inaccessible" <+> pprSrcInfo info ppr (MayDiverge t) = text "div" <+> ppr t- -- Format nested Sequences in blocks "{ grds1; grds2; ... }"- ppr t@SequenceAnn{} = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)- where- collect_seqs (SequenceAnn l r) = collect_seqs l ++ collect_seqs r- collect_seqs t = [ppr t]- ppr EmptyAnn = text "<empty case>"+ ppr (SequenceAnn _ []) = text "<empty case>"+ ppr (SequenceAnn _ ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space)+ ppr (RedundantSrcBang l t) = text "redundant bang" <+> pprSrcInfo l <+> ppr t -- | Lift 'addPmCts' over 'Deltas'. addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas@@ -263,7 +298,7 @@ -- Omitting checking this flag emits redundancy warnings twice in obscure -- cases like #17646. when (exhaustive dflags kind) $ do- -- TODO: This could probably call checkMatches, like checkGuardMatches.+ -- TODO: This could probably call checkMatches, like checkGRHSs. missing <- getPmDeltas tracePm "checkSingle: missing" (ppr missing) fam_insts <- dsGetFamInstEnvs@@ -273,12 +308,12 @@ -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Deltas' covered by the RHSs.-checkGuardMatches+checkGRHSs :: HsMatchContext GhcRn -- ^ Match context, for warning messages -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check- -> DsM [Deltas] -- ^ Covered 'Deltas' for each RHS, for long+ -> DsM (NonEmpty Deltas) -- ^ Covered 'Deltas' for each RHS, for long -- distance info-checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do+checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc match = L combinedLoc $@@ -286,7 +321,8 @@ , m_ctxt = hs_ctx , m_pats = [] , m_grhss = guards }- checkMatches dsMatchContext [] [match]+ [(_, deltas)] <- checkMatches dsMatchContext [] [match]+ pure deltas -- | Check a list of syntactic /match/es (part of case, functions, etc.), each -- with a /pat/ and one or more /grhss/:@@ -305,10 +341,9 @@ :: DsMatchContext -- ^ Match context, for warnings messages -> [Id] -- ^ Match variables, i.e. x and y above -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches- -> DsM [Deltas] -- ^ One covered 'Deltas' per RHS, for long+ -> DsM [(Deltas, NonEmpty Deltas)] -- ^ One covered 'Deltas' per RHS, for long -- distance info. checkMatches ctxt vars matches = do- dflags <- getDynFlags tracePm "checkMatches" (hang (vcat [ppr ctxt , ppr vars , text "Matches:"])@@ -321,26 +356,48 @@ [] | [var] <- vars -> addPmCtDeltas init_deltas (PmNotBotCt var) _ -> pure init_deltas fam_insts <- dsGetFamInstEnvs- grd_tree <- mkGrdTreeMany [] <$> mapM (translateMatch fam_insts vars) matches+ grd_tree <- translateMatches fam_insts vars matches res <- checkGrdTree grd_tree missing + dflags <- getDynFlags dsPmWarn dflags ctxt vars res - return (extractRhsDeltas init_deltas (cr_clauses res))+ return (extractRhsDeltas (cr_clauses res)) --- | Extract the 'Deltas' reaching the RHSs of the 'AnnotatedTree'.+-- | Extract the 'Deltas' reaching the RHSs of the 'AnnotatedTree' for a match+-- group. -- For 'AccessibleRhs's, this is stored in the tree node, whereas -- 'InaccessibleRhs's fall back to the supplied original 'Deltas'. -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@.-extractRhsDeltas :: Deltas -> AnnotatedTree -> [Deltas]-extractRhsDeltas orig_deltas = fromOL . go+extractRhsDeltas :: AnnotatedTree -> [(Deltas, NonEmpty Deltas)]+extractRhsDeltas = go_matches where- go (AccessibleRhs deltas _) = unitOL deltas- go (InaccessibleRhs _) = unitOL orig_deltas- go (MayDiverge t) = go t- go (SequenceAnn l r) = go l Semi.<> go r- go EmptyAnn = nilOL+ go_matches :: AnnotatedTree -> [(Deltas, NonEmpty Deltas)]+ go_matches (SequenceAnn def ts) = map (go_match def) ts -- -XEmptyCase handled here!+ go_matches t = pprPanic "extractRhsDeltas.go_matches" (text "Matches must start with SequenceAnn. But was" $$ ppr t) + go_match :: Deltas -> AnnotatedTree -> (Deltas, NonEmpty Deltas)+ -- There is no -XEmptyCase at this level, only at the Matches level. So @ts@+ -- is non-empty!+ go_match def (SequenceAnn pat ts) = (pat, foldMap1 (text "go_match: empty SequenceAnn") (go_grhss def) ts)+ go_match def (MayDiverge t) = go_match def t+ go_match def (RedundantSrcBang _ t) = go_match def t+ -- Even if there's only a single GRHS, we wrap it in a SequenceAnn for the+ -- Deltas covered by the pattern. So the remaining cases are impossible!+ go_match _ t = pprPanic "extractRhsDeltas.go_match" (text "Single GRHS must be wrapped in SequenceAnn. But got " $$ ppr t)++ go_grhss :: Deltas -> AnnotatedTree -> NonEmpty Deltas+ -- There is no -XEmptyCase at this level, only at the Matches level. So @ts@+ -- is non-empty!+ go_grhss def (SequenceAnn _ ts) = foldMap1 (text "go_grhss: empty SequenceAnn") (go_grhss def) ts+ go_grhss def (MayDiverge t) = go_grhss def t+ go_grhss def (RedundantSrcBang _ t) = go_grhss def t+ go_grhss _ (AccessibleRhs deltas _) = deltas :| []+ go_grhss def (InaccessibleRhs _) = def :| []++ foldMap1 msg _ [] = pprPanic "extractRhsDeltas.foldMap1" msg+ foldMap1 _ f (x:xs) = foldl' (\acc x -> acc Semi.<> f x) (f x) xs+ {- Note [Checking EmptyCase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -XEmptyCase is useful for matching on empty data types like 'Void'. For example,@@ -430,10 +487,11 @@ VarPat _ y -> pure (mkPmLetVar (unLoc y) x) ParPat _ p -> translateLPat fam_insts x p LazyPat _ _ -> pure [] -- like a wildcard- BangPat _ p ->+ BangPat _ p@(L l p') -> -- Add the bang in front of the list, because it will happen before any -- nested stuff.- (PmBang x :) <$> translateLPat fam_insts x p+ (PmBang x pm_loc :) <$> translateLPat fam_insts x p+ where pm_loc = Just (L l (ppr p')) -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var@@ -617,7 +675,8 @@ -- 2. bang strict fields let arg_is_banged = map isBanged $ conLikeImplBangs con- bang_grds = map PmBang $ filterByList arg_is_banged arg_ids+ noSrcPmBang i = PmBang {pm_id = i, pm_loc = Nothing}+ bang_grds = map noSrcPmBang (filterByList arg_is_banged arg_ids) -- 3. guards from field selector patterns let arg_grds = concat arg_grdss@@ -628,34 +687,43 @@ -- 1. 2. 3. pure (con_grd : bang_grds ++ arg_grds) -mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree-mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc)--mkGrdTreeMany :: GrdVec -> [GrdTree] -> GrdTree-mkGrdTreeMany _ [] = Empty-mkGrdTreeMany grds trees = foldr Guard (foldr1 Sequence trees) grds+-- | Translate a the 'Match'es of a 'MatchGroup'+translateMatches :: FamInstEnvs -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)]+ -> DsM GrdTree+translateMatches fam_insts vars matches =+ -- It's important that we wrap a 'Sequence' even if it only wraps a singleton.+ -- 'extractRhsDeltas' needs this to recover 'MatchGroup' structure.+ Sequence <$> traverse (translateMatch fam_insts vars) matches -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM GrdTree translateMatch fam_insts vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do- pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats- grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss)- -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss'])- return (mkGrdTreeMany pats' grhss')+ pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats+ grhss' <- translateGRHSs fam_insts match_loc (sep (map ppr pats)) grhss+ -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss'])+ return (foldr Guard grhss' pats') --- -------------------------------------------------------------------------- * Transform source guards (GuardStmt Id) to simpler PmGrds+mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree+mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc) +translateGRHSs :: FamInstEnvs -> SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM GrdTree+translateGRHSs fam_insts match_loc pp_pats grhss =+ -- It's important that we wrap a 'Sequence' even if it only wraps a singleton.+ -- 'extractRhsDeltas' needs this to recover 'GRHSs' structure.+ Sequence <$> traverse (translateLGRHS fam_insts match_loc pp_pats) (grhssGRHSs grhss)+ -- | Translate a guarded right-hand side to a single 'GrdTree'-translateLGRHS :: FamInstEnvs -> SrcSpan -> [LPat GhcTc] -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree-translateLGRHS fam_insts match_loc pats (L _loc (GRHS _ gs _)) =- -- _loc apparently points to the match separator that comes after the guards..+translateLGRHS :: FamInstEnvs -> SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree+translateLGRHS fam_insts match_loc pp_pats (L _loc (GRHS _ gs _)) =+ -- _loc points to the match separator (ie =, ->) that comes after the guards.. mkGrdTreeRhs loc_sdoc <$> concatMapM (translateGuard fam_insts . unLoc) gs where loc_sdoc- | null gs = L match_loc (sep (map ppr pats))- | otherwise = L grd_loc (sep (map ppr pats) <+> vbar <+> interpp'SP gs)+ -- pp_pats is the space-separated pattern of the current Match this+ -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@.+ | null gs = L match_loc pp_pats+ | otherwise = L grd_loc (pp_pats <+> vbar <+> interpp'SP gs) L grd_loc _ = head gs -- | Translate a guard statement to a 'GrdVec'@@ -937,8 +1005,9 @@ -- 'GrdTree'. Note that 'PmCon' guards are the only way in which values -- fall through from one 'Many' branch to the next. -- * An 'AnnotatedTree' that contains divergence and inaccessibility info--- for all clauses. Will be fed to 'redundantAndInaccessibleRhss' for--- presenting redundant and proper innaccessible RHSs to the user.+-- for all clauses. Will be fed to 'extractRedundancyInfo' for+-- presenting redundant and proper innaccessible RHSs, as well as dead+-- bangs to the user. checkGrdTree' :: GrdTree -> Deltas -> DsM CheckResult -- RHS: Check that it covers something and wrap Inaccessible if not checkGrdTree' (Rhs sdoc) deltas = do@@ -955,11 +1024,21 @@ deltas' <- addPmCtDeltas deltas (PmCoreCt x e) checkGrdTree' tree deltas' -- Bang x: Diverge on x ~ ⊥, refine with x /~ ⊥-checkGrdTree' (Guard (PmBang x) tree) deltas = do+checkGrdTree' (Guard (PmBang x src_bang_info) tree) deltas = do has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited deltas' <- addPmCtDeltas deltas (PmNotBotCt x) res <- checkGrdTree' tree deltas'- pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) }+ let clauses+ | not has_diverged+ , Just info <- src_bang_info+ = RedundantSrcBang info (cr_clauses res)+ | has_diverged+ = mayDiverge (cr_clauses res)+ | otherwise -- won't diverge and it wasn't a source bang+ = cr_clauses res++ pure res{ cr_clauses = clauses }+ -- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys -- and type info checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do@@ -970,6 +1049,7 @@ unc_this <- addPmCtDeltas deltas (PmNotConCt x con) deltas' <- addPmCtsDeltas deltas $ listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con tvs args+ -- tracePm "checkGrdTree:Con" (ppr deltas $$ ppr x $$ ppr con $$ ppr dicts $$ ppr deltas') CheckResult tree' unc_inner prec <- checkGrdTree' tree deltas' limit <- maxPmCheckModels <$> getDynFlags let (prec', unc') = throttle limit deltas (unc_this Semi.<> unc_inner)@@ -978,19 +1058,21 @@ , cr_uncov = unc' , cr_approx = prec Semi.<> prec' } -- Sequence: Thread residual uncovered sets from equation to equation-checkGrdTree' (Sequence l r) unc_0 = do- CheckResult l' unc_1 prec_l <- checkGrdTree' l unc_0- CheckResult r' unc_2 prec_r <- checkGrdTree' r unc_1- pure CheckResult- { cr_clauses = SequenceAnn l' r'- , cr_uncov = unc_2- , cr_approx = prec_l Semi.<> prec_r }--- Empty: Fall through for all values-checkGrdTree' Empty unc = do- pure CheckResult- { cr_clauses = EmptyAnn- , cr_uncov = unc- , cr_approx = Precise }+checkGrdTree' (Sequence ts) init_unc = go [] init_unc Precise ts+ where+ -- | Accumulates a CheckResult. Its type is more like+ -- @CheckResult -> [GrdTree] -> CheckResult@, but cr_clauses is a single+ -- 'AnnotatedTree', not a list thereof. Hence 3 parameters to thread the+ -- fields.+ go :: [AnnotatedTree] -> Deltas -> Precision -> [GrdTree] -> DsM CheckResult+ -- No cases left: Fall through for all values+ go ts' unc prec [] = pure CheckResult+ { cr_clauses = SequenceAnn init_unc (reverse ts')+ , cr_uncov = unc+ , cr_approx = prec }+ go ts' unc prec (t:ts) = do+ CheckResult t' unc_1 prec_t <- checkGrdTree' t unc+ go (t':ts') unc_1 (prec_t Semi.<> prec) ts -- | Print diagnostic info and actually call 'checkGrdTree''. checkGrdTree :: GrdTree -> Deltas -> DsM CheckResult@@ -1098,26 +1180,43 @@ | otherwise = notNull (filter (`wopt` dflags) allPmCheckWarnings) -redundantAndInaccessibleRhss :: AnnotatedTree -> ([RhsInfo], [RhsInfo])-redundantAndInaccessibleRhss tree = (fromOL ol_red, fromOL ol_inacc)+-- | A type for organising information to be used in warnings.+data RedundancyInfo+ = RedundancyInfo+ { redundant_rhss :: ![SrcInfo]+ , inaccessible_rhss :: ![SrcInfo]+ , redundant_bangs :: ![Located SDoc]+ }++extractRedundancyInfo :: AnnotatedTree -> RedundancyInfo+extractRedundancyInfo tree =+ RedundancyInfo { redundant_rhss = fromOL ol_red+ , inaccessible_rhss = fromOL ol_inacc+ , redundant_bangs = fromOL ol_bangs } where- (_ol_acc, ol_inacc, ol_red) = go tree- -- | Collects RHSs which are- -- 1. accessible- -- 2. proper inaccessible (so we can't delete them)- -- 3. hypothetically redundant (so not only inaccessible RHS, but we can+ (_ol_acc, ol_inacc, ol_red, ol_bangs) = go tree+ -- | Collects+ -- 1. accessible RHSs+ -- 2. proper inaccessible RHSs (so we can't delete them)+ -- 3. hypothetically redundant RHSs (so not only inaccessible, but we can -- even safely delete the equation without altering semantics)+ -- 4. 'Dead' bangs from the source, collected to be warned about -- See Note [Determining inaccessible clauses]- go :: AnnotatedTree -> (OrdList RhsInfo, OrdList RhsInfo, OrdList RhsInfo)- go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL)- go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info) -- presumably redundant+ -- See Note [Dead bang patterns]+ go :: AnnotatedTree -> (OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo)+ go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL , nilOL)+ go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info, nilOL) -- presumably redundant go (MayDiverge t) = case go t of -- See Note [Determining inaccessible clauses]- (acc, inacc, red)- | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL)+ (acc, inacc, red, bs)+ | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL, bs) res -> res- go (SequenceAnn l r) = go l Semi.<> go r- go EmptyAnn = (nilOL, nilOL, nilOL)+ go (SequenceAnn _ ts) = foldMap go ts+ go (RedundantSrcBang l t) = case go t of+ -- See Note [Dead bang patterns]+ res@(acc, inacc, _, _)+ | isNilOL acc, isNilOL inacc -> res+ | otherwise -> (nilOL, nilOL, nilOL, unitOL l) Semi.<> res {- Note [Determining inaccessible clauses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1146,26 +1245,31 @@ Clearly, it is enough if we say that we only degrade if *not all* of the child clauses are redundant. As long as there is at least one clause which we announce not to be redundant, the guard prefix responsible for the 'MayDiverge' will-survive. Hence we check for that in 'redundantAndInaccessibleRhss'.+survive. Hence we check for that in 'extractRedundancyInfo'. -} -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility) dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> CheckResult -> DsM () dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result- = when (flag_i || flag_u) $ do+ = when (flag_i || flag_u || flag_b) $ do unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered- let exists_r = flag_i && notNull redundant- exists_i = flag_i && notNull inaccessible+ let exists_r = flag_i && notNull redundant_rhss+ exists_i = flag_i && notNull inaccessible_rhss exists_u = flag_u && notNull unc_examples+ exists_b = flag_b && notNull redundant_bangs approx = precision == Approximate when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(L l q) -> do+ when exists_b $ forM_ redundant_bangs $ \(L l q) -> do+ putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)+ (pprEqn q "has redundant bang"))++ when exists_r $ forM_ redundant_rhss $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant"))- when exists_i $ forM_ inaccessible $ \(L l q) -> do+ when exists_i $ forM_ inaccessible_rhss $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) @@ -1176,10 +1280,12 @@ { cr_clauses = clauses , cr_uncov = uncovered , cr_approx = precision } = result- (redundant, inaccessible) = redundantAndInaccessibleRhss clauses+ RedundancyInfo{redundant_rhss, inaccessible_rhss, redundant_bangs}+ = extractRedundancyInfo clauses flag_i = overlapping dflags kind flag_u = exhaustive dflags kind+ flag_b = redundant_bang dflags flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) maxPatterns = maxUncoveredPatterns dflags@@ -1273,6 +1379,10 @@ -- | Check whether the exhaustiveness checker should run (exhaustiveness only) exhaustive :: DynFlags -> HsMatchContext id -> Bool exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Check whether unnecessary bangs should be warned about+redundant_bang :: DynFlags -> Bool+redundant_bang dflags = wopt Opt_WarnRedundantBangPatterns dflags -- | Denotes whether an exhaustiveness check is supported, and if so, -- via which 'WarningFlag' it's controlled.
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -33,6 +33,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Bag import GHC.Types.Unique.Set import GHC.Types.Unique.DSet@@ -1069,7 +1070,8 @@ = runMaybeT (set_tm_cs_env delta <$> traverseSDIE go env) where set_tm_cs_env delta env = delta{ delta_tm_st = TmSt env reps }- go vi = MaybeT (ensureInhabited delta vi)+ go vi = MaybeT $+ initPossibleMatches (delta_ty_st delta) vi >>= ensureInhabited delta -------------------------------------- -- * Term oracle unification procedure@@ -1667,7 +1669,7 @@ addCoreCt delta x e = do dflags <- getDynFlags let e' = simpleOptExpr dflags e- lift $ tracePm "addCoreCt" (ppr x $$ ppr e $$ ppr e')+ lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e') execStateT (core_expr x e') delta where -- | Takes apart a 'CoreExpr' and tries to extract as much information about
compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -20,6 +20,7 @@ import GHC.Core.DataCon import GHC.Builtin.Types import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad.Trans.RWS.CPS import GHC.Utils.Misc import GHC.Data.Maybe
compiler/GHC/HsToCore/Quote.hs view
@@ -62,6 +62,7 @@ import GHC.Types.Unique import GHC.Types.Basic import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Bag import GHC.Driver.Session import GHC.Data.FastString@@ -1839,7 +1840,7 @@ ; patSynD'' <- wrapGenArgSyms args ss patSynD' ; return (loc, patSynD'') } where- mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]+ mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind] -- for Record Pattern Synonyms we want to conflate the selector -- and the pattern-only names in order to provide a nicer TH -- API. Whereas inside GHC, record pattern synonym selectors and@@ -1858,7 +1859,7 @@ = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats , sel == sel' ] - wrapGenArgSyms :: HsPatSynDetails (Located Name)+ wrapGenArgSyms :: HsPatSynDetails GhcRn -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec)) wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec@@ -1871,7 +1872,7 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) = rep2 patSynDName [syn, args, dir, pat] -repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))+repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs)) repPatSynArgs (PrefixCon args) = do { args' <- repList nameTyConName lookupLOcc args ; repPrefixPatSynArgs args' }
compiler/GHC/HsToCore/Usage.hs view
@@ -25,6 +25,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Utils.Fingerprint+import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Driver.Finder @@ -59,7 +60,7 @@ -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. ----- The first argument is additional dependencies from plugins+-- The second argument is additional dependencies from plugins mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod,@@ -173,7 +174,7 @@ LookupFound _ pkg -> do -- The plugin is from an external package: -- search for the library files containing the plugin.- let searchPaths = collectLibraryPaths dflags [pkg]+ let searchPaths = collectLibraryPaths (ways dflags) [pkg] useDyn = WayDyn `elem` ways dflags suffix = if useDyn then soExt platform else "a" libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix@@ -251,7 +252,7 @@ where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env- this_pkg = homeUnit dflags+ home_unit = mkHomeUnitFromFlags dflags used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports@@ -277,7 +278,7 @@ Just mod -> -- See Note [Identity versus semantic module] let mod' = if isHoleModule mod- then mkModule this_pkg (moduleName mod)+ then mkHomeModule home_unit (moduleName mod) else mod -- This lambda function is really just a -- specialised (++); originally came about to@@ -297,7 +298,7 @@ -- things in *this* module = Nothing - | moduleUnit mod /= this_pkg+ | not (isHomeModule home_unit mod) = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe }
compiler/GHC/HsToCore/Utils.hs view
@@ -24,6 +24,7 @@ extractMatchResult, combineMatchResults, adjustMatchResultDs, shareFailureHandler,+ dsHandleMonadicFailure, mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,@@ -49,7 +50,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) import GHC.Hs import GHC.Tc.Utils.Zonk@@ -76,9 +77,11 @@ import GHC.Builtin.Names import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt @@ -895,9 +898,34 @@ it clear that sharing is not an issue. And that in turn makes it more CPR-friendly. This matters a lot: if you don't get it right, you lose the tail call property. For example, see #3403.+-} +dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+ -- In a do expression, pattern-match failure just calls+ -- the monadic 'fail' rather than throwing an exception+dsHandleMonadicFailure ctx pat match m_fail_op =+ case shareFailureHandler match of+ MR_Infallible body -> body+ MR_Fallible body -> do+ fail_op <- case m_fail_op of+ -- Note that (non-monadic) list comprehension, pattern guards, etc could+ -- have fallible bindings without an explicit failure op, but this is+ -- handled elsewhere. See Note [Failing pattern matches in Stmts] the+ -- breakdown of regular and special binds.+ Nothing -> pprPanic "missing fail op" $+ text "Pattern match:" <+> ppr pat <+>+ text "is failable, and fail_expr was left unset"+ Just fail_op -> pure fail_op+ dflags <- getDynFlags+ fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)+ fail_expr <- dsSyntaxExpr fail_op [fail_msg]+ body fail_expr -************************************************************************+mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> Located e -> String+mk_fail_msg dflags ctx pat+ = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)++{- ********************************************************************* * * Ticks * *
compiler/GHC/Iface/Ext/Ast.hs view
@@ -54,7 +54,7 @@ import GHC.Tc.Types.Evidence import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique ) import GHC.Types.Var.Env-import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Iface.Make ( mkIfaceExports ) import GHC.Utils.Panic import GHC.Data.Maybe
compiler/GHC/Iface/Ext/Binary.hs view
@@ -28,6 +28,7 @@ import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply ( takeUniqFromSupply )
compiler/GHC/Iface/Ext/Types.hs view
@@ -27,6 +27,7 @@ import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Misc+import GHC.Utils.Panic import qualified Data.Array as A import qualified Data.Map as M
compiler/GHC/Iface/Ext/Utils.hs view
@@ -10,6 +10,7 @@ import GHC.Core.Map import GHC.Driver.Session ( DynFlags )+import GHC.Driver.Ppr import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type import GHC.Core.Multiplicity@@ -54,7 +55,7 @@ this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast renderHieType :: DynFlags -> HieTypeFix -> String-renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)+renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht) resolveVisibility :: Type -> [Type] -> [(Bool,Type)] resolveVisibility kind ty_args
compiler/GHC/Iface/Load.hs view
@@ -42,6 +42,7 @@ import GHC.Driver.Session import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Iface.Syntax import GHC.Iface.Env import GHC.Driver.Types@@ -81,6 +82,7 @@ import GHC.Iface.Rename import GHC.Types.Unique.DSet import GHC.Driver.Plugins+import GHC.Unit.Home import Control.Monad import Control.Exception@@ -401,8 +403,9 @@ | isHoleModule mod -- Hole modules get special treatment = do dflags <- getDynFlags+ let home_unit = mkHomeUnitFromFlags dflags -- Redo search for our local hole module- loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from+ loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from | otherwise = withTimingSilentD (text "loading interface") (pure ()) $ do { -- Read the state@@ -413,6 +416,7 @@ -- Check whether we have the interface already ; dflags <- getDynFlags+ ; let home_unit = mkHomeUnitFromFlags dflags ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded@@ -422,7 +426,7 @@ _ -> do { -- READ THE MODULE IN- ; read_result <- case (wantHiBootFile dflags eps mod from) of+ ; read_result <- case (wantHiBootFile home_unit eps mod from) of Failed err -> return (Failed err) Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod ; case read_result of {@@ -493,7 +497,7 @@ ; WARN( bad_boot, ppr mod ) updateEps_ $ \ eps ->- if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface+ if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file]@@ -615,12 +619,12 @@ -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface.-is_external_sig :: DynFlags -> ModIface -> Bool-is_external_sig dflags iface =+is_external_sig :: HomeUnit -> ModIface -> Bool+is_external_sig home_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package- moduleUnit (mi_module iface) /= homeUnit dflags+ not (isHomeModule home_unit (mi_module iface)) -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only@@ -642,8 +646,9 @@ computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags+ let home_unit = mkHomeUnitFromFlags dflags case getModuleInstantiation mod0 of- (imod, Just indef) | homeUnitIsIndefinite dflags -> do+ (imod, Just indef) | isHomeUnitIndefinite home_unit -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do@@ -701,13 +706,13 @@ return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom+wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile dflags eps mod from+wantHiBootFile home_unit eps mod from = case from of ImportByUser usr_boot- | usr_boot == IsBoot && not this_package+ | usr_boot == IsBoot && notHomeModule home_unit mod -> Failed (badSourceImport mod) | otherwise -> Succeeded usr_boot @@ -715,10 +720,12 @@ -> Succeeded NotBoot ImportBySystem- | not this_package -- If the module to be imported is not from this package- -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed- -- on the ModuleName of *home-package* modules only.- -- We never import boot modules from other packages!+ | notHomeModule home_unit mod+ -> Succeeded NotBoot+ -- If the module to be imported is not from this package+ -- don't look it up in eps_is_boot, because that is keyed+ -- on the ModuleName of *home-package* modules only.+ -- We never import boot modules from other packages! | otherwise -> case lookupUFM (eps_is_boot eps) (moduleName mod) of@@ -728,8 +735,6 @@ Succeeded NotBoot -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules- where- this_package = homeUnit dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod@@ -910,6 +915,7 @@ nest 4 (text "reason:" <+> doc_str)]) -- Check for GHC.Prim, and return its static interface+ -- See Note [GHC.Prim] in primops.txt.pp. -- TODO: make this check a function if mod `installedModuleEq` gHC_PRIM then do@@ -921,6 +927,7 @@ -- Look for the file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod)+ let home_unit = mkHomeUnitFromFlags dflags case mb_found of InstalledFound loc mod -> do -- Found file, so read it@@ -928,7 +935,7 @@ (ml_hi_file loc) -- See Note [Home module load error]- if moduleUnit mod `unitIdEq` homeUnit dflags &&+ if isHomeInstalledModule home_unit mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path@@ -1019,8 +1026,8 @@ ********************************************************* -} -initExternalPackageState :: DynFlags -> ExternalPackageState-initExternalPackageState dflags+initExternalPackageState :: HomeUnit -> ExternalPackageState+initExternalPackageState home_unit = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable,@@ -1040,9 +1047,9 @@ } where enableBignumRules- | homeUnitId dflags == primUnitId = EnableBignumRules False- | homeUnitId dflags == bignumUnitId = EnableBignumRules False- | otherwise = EnableBignumRules True+ | isHomeUnitInstanceOf home_unit primUnitId = EnableBignumRules False+ | isHomeUnitInstanceOf home_unit bignumUnitId = EnableBignumRules False+ | otherwise = EnableBignumRules True builtinRules' = builtinRules enableBignumRules {-@@ -1053,6 +1060,7 @@ ********************************************************* -} +-- See Note [GHC.Prim] in primops.txt.pp. ghcPrimIface :: ModIface ghcPrimIface = empty_iface {@@ -1065,7 +1073,7 @@ where empty_iface = emptyFullModIface gHC_PRIM - -- The fixities listed here for @`seq`@ or @->@ should match+ -- The fixity listed here for @`seq`@ should match -- those in primops.txt.pp (from which Haddock docs are generated). fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) : mapMaybe mkFixity allThePrimOps@@ -1115,6 +1123,7 @@ showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do let dflags = hsc_dflags hsc_env+ unit_state = unitState dflags printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs.@@ -1130,7 +1139,9 @@ neverQualifyModules neverQualifyPackages putLogMsg dflags NoReason SevDump noSrcSpan- $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)+ $ withPprStyle (mkDumpStyle print_unqual)+ $ pprWithUnitState unit_state+ $ pprModIface iface -- Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT.
compiler/GHC/Iface/Make.hs view
@@ -49,6 +49,7 @@ import GHC.Driver.Types import GHC.Driver.Backend import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Types.Var.Env import GHC.Types.Var import GHC.Types.Name@@ -56,9 +57,10 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Unit.Module+import GHC.Unit import GHC.Utils.Error import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Utils.Misc hiding ( eqListBy ) import GHC.Data.FastString@@ -121,7 +123,9 @@ addFingerprints hsc_env partial_iface{ mi_decls = decls } -- Debug printing- dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)+ let unit_state = unitState (hsc_dflags hsc_env)+ dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText+ (pprWithUnitState unit_state $ pprModIface full_iface) return full_iface @@ -166,10 +170,9 @@ } = do let used_names = mkUsedNames tc_result- let pluginModules =- map lpModule (cachedPlugins (hsc_dflags hsc_env))- deps <- mkDependencies- (homeUnitId (hsc_dflags hsc_env))+ let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used@@ -224,7 +227,8 @@ -- to expose in the interface = do- let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+ let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) entities = typeEnvElts type_env show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) decls = [ tyThingToIfaceDecl show_linear_types entity
compiler/GHC/Iface/Recomp.hs view
@@ -27,10 +27,12 @@ import GHC.Driver.Types import GHC.Driver.Finder import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set import GHC.Unit.Module import GHC.Utils.Error+import GHC.Utils.Panic import GHC.Data.Graph.Directed import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable@@ -42,6 +44,7 @@ import GHC.Utils.Exception import GHC.Types.Unique.Set import GHC.Unit.State+import GHC.Unit.Home import Control.Monad import Data.Function@@ -213,7 +216,7 @@ -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04!- ; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env)+ ; if not (isHomeModule home_unit (mi_module iface)) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do {@@ -247,11 +250,12 @@ -- all the dependent modules should be in the HPT already, so it's -- quite redundant ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }- ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+ ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u+ | u <- mi_usages iface] ; return (recomp, Just iface) }}}}}}}}}} where- this_pkg = homeUnit (hsc_dflags hsc_env)+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) -- This is a bit of a hack really mod_deps :: ModuleNameEnv ModuleNameWithIsBoot mod_deps = mkModDeps (dep_mods (mi_deps iface))@@ -331,9 +335,10 @@ checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired checkHsig mod_summary iface = do dflags <- getDynFlags- let outer_mod = ms_mod mod_summary- inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)- MASSERT( moduleUnit outer_mod == homeUnit dflags )+ let home_unit = mkHomeUnitFromFlags dflags+ outer_mod = ms_mod mod_summary+ inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)+ MASSERT( isHomeModule home_unit outer_mod ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed")@@ -447,15 +452,14 @@ prev_dep_mods = dep_mods (mi_deps iface) prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface)-- this_pkg = homeUnit (hsc_dflags hsc_env)+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) dep_missing (mb_pkg, L _ mod) = do find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) let reason = moduleNameString mod ++ " changed" case find_res of Found _ mod- | pkg == this_pkg+ | isHomeUnit home_unit pkg -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <>@@ -481,7 +485,8 @@ isOldHomeDeps = flip Set.member old_deps checkForNewHomeDependency (L _ mname) = do let- mod = mkModule this_pkg mname+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)+ mod = mkHomeModule home_unit mname str_mname = moduleNameString mname reason = str_mname ++ " changed" -- We only want to look at home modules to check if any new home dependency@@ -1349,11 +1354,12 @@ -> (Name -> IO Fingerprint) mkHashFun hsc_env eps name | isHoleModule orig_mod- = lookup (mkHomeModule dflags (moduleName orig_mod))+ = lookup (mkHomeModule home_unit (moduleName orig_mod)) | otherwise = lookup orig_mod where dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags hpt = hsc_HPT hsc_env pit = eps_PIT eps occ = nameOccName name
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -36,7 +36,7 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing -- see #5878- -- pkgopts = (homeUnit dflags, sort $ packageFlags dflags)+ -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags
compiler/GHC/Iface/Rename.hs view
@@ -34,6 +34,7 @@ import GHC.Tc.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Fingerprint+import GHC.Utils.Panic import GHC.Types.Basic -- a bit vexing@@ -298,6 +299,7 @@ rnIfaceGlobal n = do hsc_env <- getTopEnv let dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst@@ -341,7 +343,7 @@ -- went from <A> to <B>. let m'' = if isHoleModule m' -- Pull out the local guy!!- then mkHomeModule dflags (moduleName m')+ then mkHomeModule home_unit (moduleName m') else m' iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env $ loadSysInterface (text "rnIfaceGlobal") m''
compiler/GHC/Iface/Tidy.hs view
@@ -19,6 +19,7 @@ import GHC.Tc.Types import GHC.Driver.Session import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Core import GHC.Core.Unfold import GHC.Core.FVs@@ -59,6 +60,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut )+import GHC.Utils.Panic import qualified GHC.Utils.Error as Err import Control.Monad@@ -366,7 +368,10 @@ (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags- ; print_unqual = mkPrintUnqualified dflags rdr_env+ ; print_unqual = mkPrintUnqualified+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ rdr_env ; implicit_binds = concatMap getImplicitBinds tcs }
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -135,6 +135,7 @@ import GHC.Unit.Module import GHC.Types.Name import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Builtin.Names import GHC.Tc.Utils.Env (lookupGlobal)
compiler/GHC/Iface/UpdateIdInfos.hs view
@@ -18,6 +18,7 @@ import GHC.Types.Var import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic #include "GhclibHsVersions.h"
compiler/GHC/IfaceToCore.hs view
@@ -73,6 +73,7 @@ import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps
compiler/GHC/Llvm/Ppr.hs view
@@ -41,6 +41,7 @@ import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Data.FastString
compiler/GHC/Llvm/Types.hs view
@@ -18,6 +18,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique -- from NCG
compiler/GHC/Plugins.hs view
@@ -26,6 +26,7 @@ , module GHC.Core.Rules , module GHC.Types.Annotations , module GHC.Driver.Session+ , module GHC.Driver.Ppr , module GHC.Unit.State , module GHC.Unit.Module , module GHC.Core.Type@@ -46,6 +47,7 @@ , module GHC.Serialized , module GHC.Types.SrcLoc , module GHC.Utils.Outputable+ , module GHC.Utils.Panic , module GHC.Types.Unique.Supply , module GHC.Data.FastString , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins@@ -111,6 +113,8 @@ import GHC.Serialized import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Driver.Ppr import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique, Uniquable(..) ) import GHC.Data.FastString
compiler/GHC/Rename/Bind.hs view
@@ -58,6 +58,7 @@ import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Set import GHC.Data.Maybe ( orElse ) import GHC.Data.OrdList
compiler/GHC/Rename/Env.hs view
@@ -75,6 +75,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Driver.Session import GHC.Data.FastString
compiler/GHC/Rename/Expr.hs view
@@ -58,6 +58,7 @@ import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error+import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc import GHC.Data.FastString
compiler/GHC/Rename/Fixity.hs view
@@ -30,6 +30,7 @@ defaultFixity, SourceText(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Maybe import Data.List import Data.Function ( on )
compiler/GHC/Rename/HsType.hs view
@@ -63,6 +63,7 @@ , Fixity(..), FixityDirection(..), LexicalFixity(..) , TypeOrKind(..) ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/Rename/Module.hs view
@@ -43,7 +43,7 @@ import GHC.Tc.Utils.Monad import GHC.Types.ForeignCall ( CCallTarget(..) )-import GHC.Unit.Module+import GHC.Unit import GHC.Driver.Types ( Warnings(..), plusWarns ) import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName@@ -61,6 +61,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith )+import GHC.Utils.Panic import GHC.Driver.Types ( HscEnv, hsc_dflags ) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)@@ -374,8 +375,8 @@ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package- ; let unitId = homeUnit $ hsc_dflags topEnv- spec' = patchForeignImport unitId spec+ ; let home_unit = mkHomeUnitFromFlags (hsc_dflags topEnv)+ spec' = patchForeignImport (homeUnitAsUnit home_unit) spec ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty'@@ -1856,7 +1857,6 @@ where h98_style = case condecls of -- Note [Stupid theta] (L _ (ConDeclGADT {})) : _ -> False- (L _ (XConDecl (ConDeclGADTPrefixPs {}))) : _ -> False _ -> True rn_derivs (L loc ds)@@ -2246,6 +2246,12 @@ ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + -- Ensure that there are no nested `forall`s or contexts, per+ -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)+ -- in GHC.Hs.Type.+ ; addNoNestedForallsContextsErr ctxt+ (text "GADT constructor type signature") new_res_ty+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 ; traceRn "rnConDecl (ConDeclGADT)"@@ -2256,47 +2262,6 @@ , con_doc = mb_doc' , con_forall = forall }, -- Remove when #18311 is fixed all_fvs) } }---- This case is only used for prefix GADT constructors generated by GHC's--- parser, where we do not know the argument types until type operator--- precedence has been resolved. See Note [GADT abstract syntax] in--- GHC.Hs.Decls for the full story.-rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty- , con_gp_doc = mb_doc }))- = do { mapM_ (addLocM checkConName) names- ; new_names <- mapM lookupLocatedTopBndrRn names- ; mb_doc' <- rnMbLHsDoc mb_doc-- ; let ctxt = ConDeclCtx new_names- ; (ty', fvs) <- rnHsSigType ctxt TypeLevel ty- ; linearTypes <- xopt LangExt.LinearTypes <$> getDynFlags-- -- Now that operator precedence has been resolved, we can split the- -- GADT type into its individual components below.- ; let HsIB { hsib_ext = implicit_tkvs, hsib_body = body } = ty'- (mb_explicit_tkvs, mb_cxt, tau) = splitLHsGADTPrefixTy body- lhas_forall = L (getLoc body) $ isJust mb_explicit_tkvs- explicit_tkvs = fromMaybe [] mb_explicit_tkvs- (arg_tys, res_ty) = splitHsFunType tau- arg_details | linearTypes = PrefixCon arg_tys- | otherwise = PrefixCon $ map (hsLinear . hsScaledThing) arg_tys-- -- NB: The only possibility here is PrefixCon. RecCon is handled- -- separately, through ConDeclGADT, from the parser onwards.-- -- Ensure that there are no nested `forall`s or contexts, per- -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)- -- in GHC.Hs.Type.- ; addNoNestedForallsContextsErr ctxt- (text "GADT constructor type signature") res_ty-- ; traceRn "rnConDecl (ConDeclGADTPrefixPs)"- (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)- ; pure (ConDeclGADT { con_g_ext = implicit_tkvs, con_names = new_names- , con_forall = lhas_forall, con_qvars = explicit_tkvs- , con_mb_cxt = mb_cxt, con_args = arg_details- , con_res_ty = res_ty, con_doc = mb_doc' },- fvs) } rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) -> RnM (Maybe (LHsContext GhcRn), FreeVars)
compiler/GHC/Rename/Names.hs view
@@ -4,7 +4,7 @@ Extracting imported and top-level names in scope -} -{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}+{-# LANGUAGE CPP, NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -35,6 +35,7 @@ import GHC.Prelude import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Core.TyCo.Ppr import GHC.Hs import GHC.Tc.Utils.Env@@ -44,7 +45,7 @@ import GHC.Iface.Load ( loadSrcInterface ) import GHC.Tc.Utils.Monad import GHC.Builtin.Names-import GHC.Unit.Module+import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set@@ -58,6 +59,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.FastString.Env import GHC.Types.Id@@ -70,7 +72,7 @@ import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing )-import Data.List ( partition, (\\), find, sortBy )+import Data.List ( partition, (\\), find, sortBy, groupBy, sortOn ) import Data.Function ( on ) import qualified Data.Set as S import System.FilePath ((</>))@@ -449,8 +451,10 @@ -- to be trusted? See Note [Trust Own Package] ptrust = trust == Sf_Trustworthy || trust_pkg + home_unit = mkHomeUnitFromFlags dflags+ (dependent_mods, dependent_pkgs, pkg_trust_req)- | pkg == homeUnit dflags =+ | isHomeUnit home_unit pkg = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged@@ -1566,7 +1570,7 @@ -} getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]-getMinimalImports = mapM mk_minimal+getMinimalImports = fmap combine . mapM mk_minimal where mk_minimal (L l decl, used_gres, unused) | null unused@@ -1618,6 +1622,25 @@ && all (`elem` fld_lbls) (map flLabel avail_flds) all_non_overloaded = all (not . flIsOverloaded)++ combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]+ combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey++ getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)+ getKey decl =+ ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first)+ , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad)+ , unLoc . ideclName $ idecl -- Module Name+ )+ where+ idecl :: ImportDecl GhcRn+ idecl = unLoc decl++ merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn+ merge [] = error "getMinimalImports: unexpected empty list"+ merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L l lies) })+ where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls+ printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () -- See Note [Printing minimal imports]
compiler/GHC/Rename/Pat.hs view
@@ -70,6 +70,7 @@ import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) import GHC.Builtin.Types ( nilDataCon )
compiler/GHC/Rename/Splice.hs view
@@ -43,6 +43,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) )+import GHC.Utils.Panic import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
compiler/GHC/Rename/Unbound.hs view
@@ -31,6 +31,7 @@ import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import Data.List import Data.Function ( on )
compiler/GHC/Rename/Utils.hs view
@@ -49,6 +49,7 @@ import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Basic ( TopLevelFlag(..) ) import GHC.Data.List.SetOps ( removeDups )
compiler/GHC/Runtime/Debugger.hs view
@@ -37,6 +37,7 @@ import GHC.Utils.Error import GHC.Utils.Monad import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Exception import Control.Monad
compiler/GHC/Runtime/Eval.hs view
@@ -80,11 +80,12 @@ import GHC.ByteCode.Types import GHC.Runtime.Linker as Linker import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.LanguageExtensions import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Utils.Monad-import GHC.Unit.Module+import GHC.Unit import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) import GHC.Builtin.Types ( isCTupleTyConName ) import GHC.Utils.Panic@@ -811,7 +812,7 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h ->- if not (isHomeModule (hsc_dflags h) modl)+ if notHomeModule (mkHomeUnitFromFlags (hsc_dflags h)) modl then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details)))@@ -1256,7 +1257,7 @@ withSession $ \hsc_env -> do interpreted <- moduleIsBootOrNotObjectLinkable mod_summary let dflags = hsc_dflags hsc_env- return (showModMsg dflags interpreted mod_summary)+ return (showSDoc dflags $ showModMsg dflags interpreted mod_summary) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -57,7 +57,9 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr+import GHC.Utils.Panic import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )
compiler/GHC/Runtime/Interpreter.hs view
@@ -70,7 +70,8 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Runtime.Eval.Types(BreakInfo(..))-import GHC.Utils.Outputable(brackets, ppr, showSDocUnqual)+import GHC.Utils.Outputable(brackets, ppr)+import GHC.Driver.Ppr (showSDoc) import GHC.Types.SrcLoc import GHC.Data.Maybe import GHC.Unit.Module@@ -413,7 +414,7 @@ | otherwise = Just (BreakInfo modl ix) sdocBpLoc = brackets . ppr . getSeqBpSpan putStrLn ("*** Ignoring breakpoint " ++- (showSDocUnqual (hsc_dflags hsc_env) $ sdocBpLoc bp))+ (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp)) -- resume the seq (:force) processing in the iserv process withForeignRef resume_ctxt_fhv $ \hval -> iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env
compiler/GHC/Runtime/Linker.hs view
@@ -47,9 +47,11 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Unit.Module+import GHC.Unit.Home import GHC.Data.List.SetOps import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..)) import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic@@ -655,7 +657,6 @@ ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env- this_pkg = homeUnit dflags -- The ModIface contains the transitive closure of the module dependencies -- within the current package, *except* for boot modules: if we encounter@@ -681,6 +682,7 @@ let pkg = moduleUnit mod deps = mi_deps iface+ home_unit = mkHomeUnitFromFlags dflags pkg_deps = dep_pkgs deps (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $@@ -693,9 +695,9 @@ acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps --- if pkg /= this_pkg+ if not (isHomeUnit home_unit pkg) then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))- else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)+ else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods) acc_mods' acc_pkgs' where msg = text "need to link module" <+> ppr mod <+>
compiler/GHC/Runtime/Loader.hs view
@@ -22,6 +22,7 @@ import GHC.Prelude import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Runtime.Linker ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole, withInterp )
compiler/GHC/Settings/IO.hs view
@@ -17,7 +17,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Settings import GHC.SysTools.BaseDir @@ -137,6 +137,8 @@ as_args = map Option cc_args ld_prog = cc_prog ld_args = map Option (cc_args ++ words cc_link_args_str)+ ld_r_prog <- getSetting "Merge objects command"+ ld_r_args <- getSetting "Merge objects flags" llvmTarget <- getSetting "LLVM target" @@ -183,6 +185,7 @@ , toolSettings_pgm_c = cc_prog , toolSettings_pgm_a = (as_prog, as_args) , toolSettings_pgm_l = (ld_prog, ld_args)+ , toolSettings_pgm_lm = (ld_r_prog, map Option $ words ld_r_args) , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) , toolSettings_pgm_T = touch_path , toolSettings_pgm_windres = windres_path@@ -201,6 +204,7 @@ , toolSettings_opt_cxx = cxx_args , toolSettings_opt_a = [] , toolSettings_opt_l = []+ , toolSettings_opt_lm = [] , toolSettings_opt_windres = [] , toolSettings_opt_lcc = [] , toolSettings_opt_lo = []
compiler/GHC/Stg/CSE.hs view
@@ -96,6 +96,7 @@ import GHC.Types.Id import GHC.Stg.Syntax import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..))
compiler/GHC/Stg/DepAnal.hs view
@@ -9,6 +9,7 @@ import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Types.Var.Set import GHC.Unit.Module (Module)
compiler/GHC/Stg/FVs.hs view
@@ -50,6 +50,7 @@ import GHC.Core ( Tickish(Breakpoint) ) import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import Data.Maybe ( mapMaybe )
compiler/GHC/Stg/Lift.hs view
@@ -29,6 +29,7 @@ import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing )
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -35,6 +35,7 @@ import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Var.Set
compiler/GHC/Stg/Lift/Monad.hs view
@@ -37,6 +37,7 @@ import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity
compiler/GHC/Stg/Pipeline.hs view
@@ -27,8 +27,10 @@ import GHC.Driver.Session import GHC.Utils.Error+import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict@@ -51,7 +53,7 @@ -> IO [StgTopBinding] -- output program stg2stg dflags this_mod binds- = do { dump_when Opt_D_dump_stg "STG:" binds+ = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass dflags "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $
compiler/GHC/Stg/Subst.hs view
@@ -9,8 +9,12 @@ import GHC.Types.Id import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict+ import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Driver.Ppr -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but
compiler/GHC/Stg/Unarise.hs view
@@ -214,6 +214,7 @@ import GHC.Types.Id.Make (voidPrimId, voidArgId) import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type
compiler/GHC/StgToCmm.hs view
@@ -47,6 +47,7 @@ import GHC.Core.Multiplicity import GHC.Unit.Module import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Stream import GHC.Types.Basic import GHC.Types.Var.Set ( isEmptyDVarSet )
compiler/GHC/StgToCmm/Bind.hs view
@@ -50,8 +50,10 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Driver.Session+import GHC.Driver.Ppr import Control.Monad
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -26,7 +26,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Utils.Outputable+import GHC.Utils.Panic -- ----------------------------------------------------------------------------- -- Information about global registers
compiler/GHC/StgToCmm/Closure.hs view
@@ -90,6 +90,7 @@ import GHC.Types.RepType import GHC.Types.Basic import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import Data.Coerce (coerce)
compiler/GHC/StgToCmm/DataCon.hs view
@@ -48,7 +48,7 @@ import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal import GHC.Builtin.Utils-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM)
compiler/GHC/StgToCmm/Env.hs view
@@ -37,17 +37,21 @@ import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils-import GHC.Driver.Session import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name-import GHC.Utils.Outputable import GHC.Stg.Syntax import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM-import GHC.Utils.Misc import GHC.Types.Var.Env++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Driver.Session+ ------------------------------------- -- Manipulating CgIdInfo
compiler/GHC/StgToCmm/Expr.hs view
@@ -50,6 +50,7 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad ( unless, void ) import Control.Arrow ( first )
compiler/GHC/StgToCmm/Foreign.hs view
@@ -44,7 +44,7 @@ import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall import GHC.Data.Maybe-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Supply import GHC.Types.Basic @@ -261,7 +261,7 @@ -- What we want to do here is create a new temporary for the foreign -- call argument if it is not safe to use the expression directly, -- because the expression mentions caller-saves GlobalRegs (see--- Note [Register Parameter Passing]).+-- Note [Register parameter passing]). -- -- However, we can't pattern-match on the expression here, because -- this is used in a loop by GHC.Cmm.Parser, and testing the expression
compiler/GHC/StgToCmm/Layout.hs view
@@ -34,6 +34,9 @@ import GHC.Prelude hiding ((<*>)) +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )@@ -52,7 +55,6 @@ import GHC.Types.Id import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity )-import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Unit@@ -60,6 +62,7 @@ import GHC.Utils.Misc import Data.List import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import Control.Monad
compiler/GHC/StgToCmm/Monad.hs view
@@ -82,6 +82,7 @@ import GHC.Types.Unique.Supply import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import Control.Monad
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} #if __GLASGOW_HASKELL__ <= 808 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it@@ -54,8 +53,8 @@ import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout import GHC.Data.FastString-import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import Data.Maybe import Data.Bits ((.&.), bit)@@ -1562,19 +1561,17 @@ -> FCode ()) -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do- regs <- if- | ReturnsPrim VoidRep <- result_info- -> pure []-- | ReturnsPrim rep <- result_info- -> do reg <- newTemp (primRepCmmType platform rep)- pure [reg]+ regs <- case result_info of+ ReturnsPrim VoidRep -> pure []+ ReturnsPrim rep+ -> do reg <- newTemp (primRepCmmType platform rep)+ pure [reg] - | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon- -> do (regs, _hints) <- newUnboxedTupleRegs res_ty- pure regs+ ReturnsAlg tycon | isUnboxedTupleTyCon tycon+ -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+ pure regs - | otherwise -> panic "cgOpApp"+ _ -> panic "cgOpApp" f regs pure $ map (CmmReg . CmmLocal) regs
compiler/GHC/StgToCmm/Prof.hs view
@@ -25,6 +25,9 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure@@ -38,10 +41,10 @@ import GHC.Cmm.CLabel import GHC.Types.CostCentre-import GHC.Driver.Session import GHC.Data.FastString import GHC.Unit.Module as Module import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad import Data.Char (ord)
compiler/GHC/StgToCmm/Ticky.hs view
@@ -122,9 +122,11 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Driver.Session+import GHC.Driver.Ppr -- Turgid imports for showTypeCategory import GHC.Builtin.Names
compiler/GHC/StgToCmm/Utils.hs view
@@ -76,6 +76,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.CostCentre @@ -243,7 +244,7 @@ -- shouldn't be doing the workaround at this point in the pipeline, see -- Note [Register parameter passing] and the ToDo on CmmCall in -- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across--- unsafe foreign calls in rewriteAssignments, but this is strictly+-- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly -- temporary. callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph) callerSaveVolatileRegs platform = (caller_save, caller_load)
compiler/GHC/SysTools.hs view
@@ -43,8 +43,9 @@ import GHC.Settings.Utils import GHC.Unit-import GHC.Utils.Outputable import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Outputable import GHC.Platform import GHC.Driver.Session import GHC.Platform.Ways@@ -246,9 +247,13 @@ verbFlags = getVerbFlags dflags o_file = outputFile dflags - pkgs <- getPreloadUnitsAnd dflags dep_packages+ pkgs <- getPreloadUnitsAnd+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ dep_packages - let pkg_lib_paths = collectLibraryPaths dflags pkgs+ let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | ( osElfTarget (platformOS (targetPlatform dflags)) ||@@ -426,11 +431,19 @@ getUnitFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do- pkg_framework_paths <- getUnitFrameworkPath dflags dep_packages+ pkg_framework_paths <- getUnitFrameworkPath+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ dep_packages return $ map ("-F" ++) pkg_framework_paths pkg_framework_opts <- do- pkg_frameworks <- getUnitFrameworks dflags dep_packages+ pkg_frameworks <- getUnitFrameworks+ (initSDocContext dflags defaultUserStyle)+ (unitState dflags)+ (mkHomeUnitFromFlags dflags)+ dep_packages return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] return (pkg_framework_path_opts ++ pkg_framework_opts)
compiler/GHC/SysTools/ExtraObj.hs view
@@ -16,6 +16,7 @@ import GHC.Utils.Asm import GHC.Utils.Error import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Unit.State import GHC.Platform import GHC.Utils.Outputable as Outputable@@ -171,8 +172,11 @@ getLinkInfo :: DynFlags -> [UnitId] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getUnitLinkOpts dflags dep_packages+ let unit_state = unitState dflags+ home_unit = mkHomeUnitFromFlags dflags+ ctx = initSDocContext dflags defaultUserStyle pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)- then getUnitFrameworks dflags dep_packages+ then getUnitFrameworks ctx unit_state home_unit dep_packages else return [] let extra_ld_inputs = ldInputs dflags let
compiler/GHC/SysTools/Process.hs view
@@ -45,6 +45,15 @@ enableProcessJobs opts = opts #endif +#if !MIN_VERSION_base(4,15,0)+-- TODO: This can be dropped with GHC 8.16+hGetContents' :: Handle -> IO String+hGetContents' hdl = do+ output <- hGetContents hdl+ _ <- evaluate $ length output+ return output+#endif+ -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is -- inherited from the parent process, and output to stderr is not captured. readCreateProcessWithExitCode'@@ -55,13 +64,19 @@ createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe } -- fork off a thread to start consuming the output- output <- hGetContents outh outMVar <- newEmptyMVar- _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()+ let onError :: SomeException -> IO ()+ onError exc = putMVar outMVar (Left exc)+ _ <- forkIO $ handle onError $ do+ output <- hGetContents' outh+ putMVar outMVar $ Right output -- wait on the output- takeMVar outMVar+ result <- takeMVar outMVar hClose outh+ output <- case result of+ Left exc -> throwIO exc+ Right output -> return output -- wait on the process ex <- waitForProcess pid
compiler/GHC/SysTools/Tasks.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- -- Tasks running external programs for SysTools@@ -299,6 +300,20 @@ ld_postfix = tail . snd . ld_warn_break ld_warning_found = not . null . snd . ld_warn_break +-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.+runMergeObjects :: DynFlags -> [Option] -> IO ()+runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do+ let (p,args0) = pgm_lm dflags+ optl_args = map Option (getOpts dflags opt_lm)+ args2 = args0 ++ args ++ optl_args+ -- N.B. Darwin's ld64 doesn't support response files. Consequently we only+ -- use them on Windows where they are truly necessary.+#if defined(mingw32_HOST_OS)+ mb_env <- getGccEnv args2+ runSomethingResponseFile dflags id "Merge objects" p args2 mb_env+#else+ runSomething dflags "Merge objects" p args2+#endif runLibtool :: DynFlags -> [Option] -> IO () runLibtool dflags args = traceToolCommand dflags "libtool" $ do
compiler/GHC/Tc/Deriv.hs view
@@ -61,6 +61,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -30,7 +30,7 @@ import GHC.Core.DataCon import GHC.Data.FastString import GHC.Hs-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -73,6 +73,7 @@ import GHC.Utils.Misc import GHC.Types.Var import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Lexeme import GHC.Data.FastString import GHC.Data.Pair
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -49,6 +49,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -25,6 +25,7 @@ import GHC.Utils.Error import GHC.Tc.Utils.Instantiate import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -38,6 +38,7 @@ import GHC.Unit.Module (getModule) import GHC.Types.Name import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate
compiler/GHC/Tc/Errors.hs view
@@ -58,8 +58,10 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.List.SetOps ( equivClasses ) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/Tc/Errors/Hole.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -29,6 +30,7 @@ import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Tc.Utils.Env (tcLookup) import GHC.Utils.Outputable import GHC.Driver.Session@@ -778,7 +780,9 @@ Just (dataConWrapId con, dataConNonlinearType con) _ -> Nothing } where name = case hfc of+#if __GLASGOW_HASKELL__ <= 810 IdHFCand id -> idName id+#endif GreHFCand gre -> gre_name gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -38,6 +38,7 @@ import GHC.Types.Basic( Arity ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import Control.Monad
compiler/GHC/Tc/Gen/Bind.hs view
@@ -65,6 +65,7 @@ import GHC.Utils.Misc import GHC.Types.Basic import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) import GHC.Tc.Validity (checkValidType) import GHC.Types.Unique.FM@@ -1273,20 +1274,15 @@ -> TcSigFun -> LetBndrSpec -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTc, [MonoBindInfo])++-- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings] tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name , fun_matches = matches })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature- = -- Note [Single function non-recursive binding special-case]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- In this very special case we infer the type of the- -- right hand side first (it may have a higher-rank type)- -- and *then* make the monomorphic Id for the LHS- -- e.g. f = \(x::forall a. a->a) -> <body>- -- We want to infer a higher-rank type for f- setSrcSpan b_loc $+ = setSrcSpan b_loc $ do { ((co_fn, matches'), rhs_ty) <- tcInfer $ \ exp_ty -> tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $@@ -1304,6 +1300,29 @@ , mbi_sig = Nothing , mbi_mono_id = mono_id }]) } +-- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings]+tcMonoBinds is_rec sig_fn no_gen+ [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]+ | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS+ , all (isNothing . sig_fn) bndrs+ = addErrCtxt (patMonoBindsCtxt pat grhss) $+ do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->+ tcGRHSsPat grhss exp_ty++ ; let exp_pat_ty :: Scaled ExpSigmaType+ exp_pat_ty = unrestricted (mkCheckExpType pat_ty)+ ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $+ mapM lookupMBI bndrs++ ; return ( unitBag $ L b_loc $+ PatBind { pat_lhs = pat', pat_rhs = grhss'+ , pat_ext = pat_ty, pat_ticks = ([],[]) }++ , mbis ) }+ where+ bndrs = collectPatBinders pat++-- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds @@ -1326,7 +1345,67 @@ ; return (listToBag binds', mono_infos) } +{- Note [Special case for non-recursive function bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the special case of+* A non-recursive FunBind+* With no type signature+we infer the type of the right hand side first (it may have a+higher-rank type) and *then* make the monomorphic Id for the LHS e.g.+ f = \(x::forall a. a->a) -> <body> +We want to infer a higher-rank type for f++Note [Special case for non-recursive pattern bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the special case of+* A pattern binding+* With no type signature for any of the binders+we can /infer/ the type of the RHS, and /check/ the pattern+against that type. For example (#18323)++ ids :: [forall a. a -> a]+ combine :: (forall a . [a] -> a) -> [forall a. a -> a]+ -> ((forall a . [a] -> a), [forall a. a -> a])++ (x,y) = combine head ids++with -XImpredicativeTypes we can infer a good type for+(combine head ids), and use that to tell us the polymorphic+types of x and y.++We don't need to check -XImpredicativeTypes beucase without it+these types like [forall a. a->a] are illegal anyway, so this+special case code only really has an effect if -XImpredicativeTypes+is on. Small exception:+ (x) = e+is currently treated as a pattern binding so, even absent+-XImpredicativeTypes, we will get a small improvement in behaviour.+But I don't think it's worth an extension flag.++Why do we require no type signatures on /any/ of the binders?+Consider+ x :: forall a. a->a+ y :: forall a. a->a+ (x,y) = (id,id)++Here we should /check/ the RHS with expected type+ (forall a. a->a, forall a. a->a).++If we have no signatures, we can the approach of this Note+to /infer/ the type of the RHS.++But what if we have some signatures, but not all? Say this:+ p :: forall a. a->a+ (p,q) = (id, (\(x::forall b. b->b). x True))++Here we want to push p's signature inwards, i.e. /checking/, to+correctly elaborate 'id'. But we want to /infer/ q's higher rank+type. There seems to be no way to do this. So currently we only+switch to inference when we have no signature for any of the binders.+-}++ ------------------------ -- tcLhs typechecks the LHS of the bindings, to construct the environment in which -- we typecheck the RHSs. Basically what we are doing is this: for each binder:@@ -1393,7 +1472,7 @@ -- The above inferred type get an unrestricted multiplicity. It may be -- worth it to try and find a finer-grained multiplicity here -- if examples warrant it.- mapM lookup_info nosig_names+ mapM lookupMBI nosig_names ; let mbis = sig_mbis ++ nosig_mbis @@ -1411,19 +1490,19 @@ Just (TcIdSig sig) -> Right (name, sig) _ -> Left name - -- After typechecking the pattern, look up the binder- -- names that lack a signature, which the pattern has brought- -- into scope.- lookup_info :: Name -> TcM MonoBindInfo- lookup_info name- = do { mono_id <- tcLookupId name- ; return (MBI { mbi_poly_name = name- , mbi_sig = Nothing- , mbi_mono_id = mono_id }) }- tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible +lookupMBI :: Name -> TcM MonoBindInfo+-- After typechecking the pattern, look up the binder+-- names that lack a signature, which the pattern has brought+-- into scope.+lookupMBI name+ = do { mono_id <- tcLookupId name+ ; return (MBI { mbi_poly_name = name+ , mbi_sig = Nothing+ , mbi_mono_id = mono_id }) }+ ------------------- tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo tcLhsSigId no_gen (name, sig)@@ -1466,15 +1545,9 @@ tcExtendIdBinderStackForRhs infos $ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $- tcScalingUsage Many $- -- Like in tcMatchesFun, this scaling happens because all- -- let bindings are unrestricted. A difference, here, is- -- that when this is not the case, any more, we will have to- -- make sure that the pattern is strict, otherwise this will- -- be desugar to incorrect code.- tcGRHSsPat grhss pat_ty+ tcGRHSsPat grhss (mkCheckExpType pat_ty) ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'- , pat_ext = NPatBindTc emptyNameSet pat_ty+ , pat_ext = pat_ty , pat_ticks = ([],[]) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
compiler/GHC/Tc/Gen/Default.hs view
@@ -22,6 +22,7 @@ import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/Tc/Gen/Export.hs view
@@ -30,6 +30,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Types import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn
compiler/GHC/Tc/Gen/Expr.hs view
@@ -80,6 +80,7 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon)
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -63,6 +63,7 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.SrcLoc import GHC.Data.Bag
compiler/GHC/Tc/Gen/HsType.hs view
@@ -114,6 +114,7 @@ import GHC.Utils.Misc import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session@@ -1078,7 +1079,9 @@ HsUnboxedTuple -> UnboxedTuple HsBoxedTuple -> BoxedTuple HsConstraintTuple -> ConstraintTuple+#if __GLASGOW_HASKELL__ <= 810 _ -> panic "tc_hs_type HsTupleTy"+#endif tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind = do { let arity = length hs_tys
compiler/GHC/Tc/Gen/Match.hs view
@@ -60,6 +60,7 @@ import GHC.Builtin.Types.Prim import GHC.Tc.Types.Evidence import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.SrcLoc @@ -156,10 +157,17 @@ -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType+tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings-tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)+tcGRHSsPat grhss res_ty+ = tcScalingUsage Many $+ -- Like in tcMatchesFun, this scaling happens because all+ -- let bindings are unrestricted. A difference, here, is+ -- that when this is not the case, any more, we will have to+ -- make sure that the pattern is strict, otherwise this will+ -- desugar to incorrect code.+ tcGRHSs match_ctxt grhss res_ty where match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody }
compiler/GHC/Tc/Gen/Match.hs-boot view
@@ -2,13 +2,13 @@ import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Types.Name ( Name )-import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType )+import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types ( TcM ) import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTc ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)- -> TcRhoType+ -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) tcMatchesFun :: Located Name
compiler/GHC/Tc/Gen/Pat.hs view
@@ -63,6 +63,7 @@ import GHC.Types.Var.Set import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import qualified GHC.LanguageExtensions as LangExt import Control.Arrow ( second ) import Control.Monad ( when )
compiler/GHC/Tc/Gen/Rule.hs view
@@ -34,6 +34,7 @@ import GHC.Types.Basic ( RuleName ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Bag
compiler/GHC/Tc/Gen/Sig.hs view
@@ -44,6 +44,7 @@ import GHC.Driver.Session import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import GHC.Builtin.Names( mkUnboundName )@@ -52,6 +53,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Misc( singleton ) import GHC.Data.Maybe( orElse )@@ -826,9 +828,13 @@ tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) = do { id <- tcLookupId name- ; unless (isAnyInlinePragma (idInlinePragma id))- (addWarnTc NoReason (impSpecErr name))- ; tcSpecPrag id prag }+ ; if isAnyInlinePragma (idInlinePragma id)+ then tcSpecPrag id prag+ else do { addWarnTc NoReason (impSpecErr name)+ ; return [] } }+ -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In+ -- that case, just delete the SPECIALISE pragma altogether, lest the+ -- desugarer fall over because it can't find the unfolding. See #18118. impSpecErr :: Name -> SDoc impSpecErr name
compiler/GHC/Tc/Instance/Class.hs view
@@ -42,6 +42,7 @@ import GHC.Core.Class import GHC.Driver.Session import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) import Data.Maybe
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -38,11 +38,13 @@ import GHC.Types.Var.Env import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen )-import GHC.Utils.FV+import GHC.Types.SrcLoc+ import GHC.Utils.Outputable+import GHC.Utils.FV import GHC.Utils.Error( Validity(..), allValid )-import GHC.Types.SrcLoc import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Pair ( Pair(..) ) import Data.List ( nubBy )
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -43,6 +43,7 @@ import GHC.Settings.Constants import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString ( FastString, mkFastString, fsLit ) import Control.Monad.Trans.State
compiler/GHC/Tc/Module.hs view
@@ -110,7 +110,7 @@ import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env-import GHC.Unit.Module+import GHC.Unit import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env@@ -121,6 +121,7 @@ import GHC.Driver.Types import GHC.Data.List.SetOps import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type@@ -180,15 +181,14 @@ where hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env- err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $+ home_unit = mkHomeUnitFromFlags dflags+ err_msg = mkPlainErrMsg dflags loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod - this_pkg = homeUnit (hsc_dflags hsc_env)- pair :: (Module, SrcSpan) pair@(this_mod,_) | Just (L mod_loc mod) <- hsmodName this_module- = (mkModule this_pkg mod, mod_loc)+ = (mkHomeModule home_unit mod, mod_loc) | otherwise -- 'module M where' is omitted = (mAIN, srcLocSpan (srcSpanStart loc))@@ -2838,12 +2838,12 @@ = initIfaceTcRn $ do mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where- this_pkg = homeUnit (hsc_dflags hsc_env)+ home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) , let name = gre_name gre- , nameIsFromExternalPackage this_pkg name+ , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified doc = text "Need interface for module whose export(s) are in scope unqualified"@@ -2866,11 +2866,12 @@ tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDynFlags ;+ unit_state <- unitState <$> getDynFlags ; -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)- "" FormatText short_dump) ;+ "" FormatText (pprWithUnitState unit_state short_dump)) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
compiler/GHC/Tc/Solver.hs view
@@ -53,6 +53,7 @@ import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Unique.Set
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -36,6 +36,7 @@ import GHC.Types.Var.Env( mkInScopeSet ) import GHC.Types.Var.Set( delVarSetList ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set import GHC.Types.Name.Reader
compiler/GHC/Tc/Solver/Flatten.hs view
@@ -28,6 +28,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Tc.Solver.Monad as TcS import GHC.Types.Basic( SwapFlag(..) )
compiler/GHC/Tc/Solver/Interact.hs view
@@ -37,6 +37,7 @@ import GHC.Tc.Types.Evidence import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Tc.Types import GHC.Tc.Types.Constraint
compiler/GHC/Tc/Solver/Monad.hs view
@@ -162,6 +162,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Bag as Bag import GHC.Types.Unique.Supply import GHC.Utils.Misc
compiler/GHC/Tc/TyCl.hs view
@@ -61,12 +61,12 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Unit.Module-import GHC.Unit.State+import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Core.Unify import GHC.Utils.Misc@@ -74,7 +74,6 @@ import GHC.Data.List.SetOps import GHC.Driver.Session import GHC.Types.Unique-import GHC.Core.ConLike( ConLike(..) ) import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt @@ -174,8 +173,8 @@ -- Step 1.5: Make sure we don't have any type synonym cycles ; traceTc "Starting synonym cycle check" (ppr tyclss)- ; this_uid <- fmap homeUnit getDynFlags- ; checkSynCycles this_uid tyclss tyclds+ ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags+ ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds ; traceTc "Done synonym cycle check" (ppr tyclss) -- Step 2: Perform the validity check on those types/classes@@ -3819,16 +3818,15 @@ where recovery_code -- See Note [Recover from validity error] = do { traceTc "Aborted validity for tycon" (ppr tc)- ; return (concatMap mk_fake_tc $- ATyCon tc : implicitTyConThings tc) }+ ; return (map mk_fake_tc $+ tc : child_tycons tc) } - mk_fake_tc (ATyCon tc)- | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error]- | otherwise = [makeRecoveryTyCon tc]- mk_fake_tc (AConLike (RealDataCon dc))- = [makeRecoveryTyCon (promoteDataCon dc)]- mk_fake_tc _ = []+ mk_fake_tc tc+ | isClassTyCon tc = tc -- Ugh! Note [Recover from validity error]+ | otherwise = makeRecoveryTyCon tc + child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc)+ {- Note [Recover from validity error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We recover from a validity error in a type or class, which allows us@@ -3852,6 +3850,8 @@ and so there was an internal error when we met 'MkT' in the body of 'S'. + Similarly for associated types.+ * Painfully, we *don't* want to do this for classes. Consider tcfail041: class (?x::Int) => C a where ...@@ -3864,6 +3864,14 @@ This is really bogus; now we have in scope a Class that is invalid in some way, with unknown downstream consequences. A better alternative might be to make a fake class TyCon. A job for another day.++* Previously, we used implicitTyConThings to snaffle out the parts+ to add to the context. The problem is that this also grabs data con+ wrapper Ids. These could be filtered out. But, painfully, getting+ the wrapper Ids checks the DataConRep, and forcing the DataConRep+ can panic if there is a levity-polymorphic argument. This is #18534.+ We don't need the wrapper Ids here anyway. So the code just takes what+ it needs, via child_tycons. -} -------------------------@@ -4050,8 +4058,13 @@ -- regardless of whether or not UnliftedNewtypes is enabled. A -- later check in checkNewDataCon handles this, producing a -- better error message than checkForLevPoly would.- ; unless (isNewTyCon tc)- (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con))+ ; unless (isNewTyCon tc) $+ checkNoErrs $+ mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)+ -- the checkNoErrs is to prevent a panic in isVanillaDataCon+ -- (called a a few lines down), which can fall over if there is a+ -- bang on a levity-polymorphic argument. This is #18534,+ -- typecheck/should_fail/T18534 -- Extra checks for newtype data constructors. Importantly, these -- checks /must/ come before the call to checkValidType below. This@@ -4122,7 +4135,7 @@ -- when we actually fill in the abstract type. As such, don't -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!)- , homeUnitIsDefinite dflags+ , isHomeUnitDefinite (mkHomeUnitFromFlags dflags) = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of
compiler/GHC/Tc/TyCl/Build.hs view
@@ -43,6 +43,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
compiler/GHC/Tc/TyCl/Class.hs view
@@ -59,6 +59,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Data.Maybe
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -65,6 +65,7 @@ import GHC.Data.Bag import GHC.Types.Basic import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Error import GHC.Data.FastString import GHC.Types.Id@@ -72,6 +73,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -558,7 +558,7 @@ a bad idea. -} -collectPatSynArgInfo :: HsPatSynDetails (Located Name)+collectPatSynArgInfo :: HsPatSynDetails GhcRn -> ([Name], [Name], Bool) collectPatSynArgInfo details = case details of
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -59,8 +59,9 @@ import GHC.Core.Coercion ( ltRole ) import GHC.Types.Basic import GHC.Types.SrcLoc-import GHC.Types.Unique ( mkBuiltinUnique )+import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.Bag
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -21,9 +21,10 @@ import GHC.Prelude import GHC.Types.Basic (defaultFixity, TypeOrKind(..))-import GHC.Unit.State+import GHC.Unit import GHC.Tc.Gen.Export import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad@@ -41,7 +42,6 @@ import GHC.Rename.Names import GHC.Utils.Error import GHC.Types.Id-import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set@@ -49,6 +49,7 @@ import GHC.Types.SrcLoc import GHC.Driver.Types import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Data.FastString@@ -233,16 +234,15 @@ -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]-requirementMerges pkgstate mod_name =- fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))+requirementMerges unit_state mod_name =+ fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext unit_state)) where -- update IndefUnitId ppr info as they may have changed since the -- time the IndefUnitId was created fixupModule (Module iud name) = Module iud' name where- iud' = iud { instUnitInstanceOf = cid' }+ iud' = iud { instUnitInstanceOf = cid } cid = instUnitInstanceOf iud- cid' = updateIndefUnitId pkgstate cid -- | For a module @modname@ of type 'HscSource', determine the list -- of extra "imports" of other requirements which should be considered part of@@ -275,8 +275,8 @@ $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where- pkgstate = unitState (hsc_dflags hsc_env)- reqs = requirementMerges pkgstate modname+ unit_state = unitState (hsc_dflags hsc_env)+ reqs = requirementMerges unit_state modname findExtraSigImports' _ _ _ = return emptyUniqDSet @@ -310,10 +310,11 @@ forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of- Found _ mod | not (isHomeModule dflags mod) ->+ Found _ mod | not (isHomeModule home_unit mod) -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where dflags = hsc_dflags hsc_env+ home_unit = mkHomeUnitFromFlags dflags -- | Given a 'Unit', make sure it is well typed. This is because -- unit IDs come from Cabal, which does not know if things are well-typed or@@ -533,16 +534,17 @@ }) $ do tcg_env <- getGblEnv - let outer_mod = tcg_mod tcg_env- inner_mod = tcg_semantic_mod tcg_env- mod_name = moduleName (tcg_mod tcg_env)- pkgstate = unitState dflags+ let outer_mod = tcg_mod tcg_env+ inner_mod = tcg_semantic_mod tcg_env+ mod_name = moduleName (tcg_mod tcg_env)+ unit_state = unitState dflags+ home_unit = mkHomeUnitFromFlags dflags -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in.- let reqs = requirementMerges pkgstate mod_name+ let reqs = requirementMerges unit_state mod_name - addErrCtxt (merge_msg mod_name reqs) $ do+ addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do -- STEP 2: Read in the RAW forms of all of these interfaces ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->@@ -569,7 +571,7 @@ let insts = instUnitInsts iuid isFromSignaturePackage = let inst_uid = instUnitInstanceOf iuid- pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid)+ pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid) in null (unitExposedModules pkg) -- 3(a). Rename the exports according to how the dependency -- was instantiated. The resulting export list will be accurate@@ -732,7 +734,7 @@ -- STEP 4: Rename the interfaces ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface- lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0+ lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0 let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env@@ -754,7 +756,7 @@ let infos = zip ifaces detailss -- Test for cycles- checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) []+ checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) [] -- NB on type_env: it contains NO dfuns. DFuns are recorded inside -- detailss, and given a Name that doesn't correspond to anything real. See@@ -897,18 +899,21 @@ exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map occName . availNames) -impl_msg :: Module -> InstantiatedModule -> SDoc-impl_msg impl_mod (Module req_uid req_mod_name) =- text "while checking that" <+> ppr impl_mod <+>- text "implements signature" <+> ppr req_mod_name <+>- text "in" <+> ppr req_uid+impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc+impl_msg unit_state impl_mod (Module req_uid req_mod_name)+ = pprWithUnitState unit_state $+ text "while checking that" <+> ppr impl_mod <+>+ text "implements signature" <+> ppr req_mod_name <+>+ text "in" <+> ppr req_uid -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv-checkImplements impl_mod req_mod@(Module uid mod_name) =- addErrCtxt (impl_msg impl_mod req_mod) $ do+checkImplements impl_mod req_mod@(Module uid mod_name) = do+ dflags <- getDynFlags+ let unit_state = unitState dflags+ addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid -- STEP 1: Load the implementing interface, and make a RdrEnv@@ -928,7 +933,6 @@ loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") (dep_orphs (mi_deps impl_iface)) - dflags <- getDynFlags let avails = calculateAvails dflags impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)@@ -966,9 +970,8 @@ forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of [] -> addErr $ quotes (ppr occ)- <+> text "is exported by the hsig file, but not"- <+> text "exported by the implementing module"- <+> quotes (ppr impl_mod)+ <+> text "is exported by the hsig file, but not exported by the implementing module"+ <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) _ -> return () failIfErrsM @@ -998,16 +1001,14 @@ dflags <- getDynFlags let outer_mod = tcg_mod tcg_env inner_mod = tcg_semantic_mod tcg_env+ home_unit = mkHomeUnitFromFlags dflags -- TODO: setup the local RdrEnv so the error messages look a little better. -- But this information isn't stored anywhere. Should we RETYPECHECK -- the local one just to get the information? Hmm...- MASSERT( isHomeModule dflags outer_mod )- MASSERT( isJust (homeUnitInstanceOfId dflags) )- let uid = fromJust (homeUnitInstanceOfId dflags)- -- we need to fetch the most recent ppr infos from the unit- -- database because we might have modified it- uid' = updateIndefUnitId (unitState dflags) uid+ MASSERT( isHomeModule home_unit outer_mod )+ MASSERT( isHomeUnitInstantiating home_unit)+ let uid = Indefinite (homeUnitInstanceOf home_unit) inner_mod `checkImplements` Module- (mkInstantiatedUnit uid' (homeUnitInstantiations dflags))+ (mkInstantiatedUnit uid (homeUnitInstantiations home_unit)) (moduleName outer_mod)
compiler/GHC/Tc/Utils/Env.hs view
@@ -106,7 +106,9 @@ import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Unit.Module+import GHC.Unit.Home import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Encoding import GHC.Data.FastString import GHC.Data.Bag@@ -145,7 +147,8 @@ = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) dflags = hsc_dflags hsc_env- tcg_semantic_mod = canonicalizeModuleIfHome dflags mod+ home_unit = mkHomeUnitFromFlags dflags+ tcg_semantic_mod = homeModuleInstantiation home_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name then (return
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -76,9 +76,11 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.State import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless )@@ -971,9 +973,10 @@ [ispec, dup_ispec] addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()-addClsInstsErr herald ispecs- = setSrcSpan (getSrcSpan (head sorted)) $- addErr (hang herald 2 (pprInstances sorted))+addClsInstsErr herald ispecs = do+ unit_state <- unitState <$> getDynFlags+ setSrcSpan (getSrcSpan (head sorted)) $+ addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) where sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs -- The sortBy just arranges that instances are displayed in order
compiler/GHC/Tc/Utils/Monad.hs view
@@ -149,6 +149,8 @@ import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Tc.Types -- Re-export all import GHC.Data.IOEnv -- Re-export all import GHC.Tc.Types.Constraint@@ -178,6 +180,7 @@ import GHC.Types.Name.Set import GHC.Data.Bag import GHC.Utils.Outputable as Outputable+import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Data.FastString@@ -239,6 +242,7 @@ th_remote_state_var <- newIORef Nothing ; let { dflags = hsc_dflags hsc_env ;+ home_unit = mkHomeUnitFromFlags dflags ; maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val@@ -264,8 +268,7 @@ tcg_th_remote_state = th_remote_state_var, tcg_mod = mod,- tcg_semantic_mod =- canonicalizeModuleIfHome dflags mod,+ tcg_semantic_mod = homeModuleInstantiation home_unit mod, tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv,@@ -771,7 +774,9 @@ getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified getPrintUnqualified dflags = do { rdr_env <- getGlobalRdrEnv- ; return $ mkPrintUnqualified dflags rdr_env }+ ; let unit_state = unitState dflags+ ; let home_unit = mkHomeUnitFromFlags dflags+ ; return $ mkPrintUnqualified unit_state home_unit rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn ()@@ -972,13 +977,19 @@ mkLongErrAt loc msg extra = do { dflags <- getDynFlags ; printer <- getPrintUnqualified dflags ;- return $ mkLongErrMsg dflags loc printer msg extra }+ unit_state <- unitState <$> getDynFlags ;+ let msg' = pprWithUnitState unit_state msg in+ return $ mkLongErrMsg dflags loc printer msg' extra } mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg mkErrDocAt loc errDoc = do { dflags <- getDynFlags ; printer <- getPrintUnqualified dflags ;- return $ mkErrDoc dflags loc printer errDoc }+ unit_state <- unitState <$> getDynFlags ;+ let f = pprWithUnitState unit_state+ errDoc' = mapErrDoc f errDoc+ in+ return $ mkErrDoc dflags loc printer errDoc' } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError@@ -1935,10 +1946,10 @@ = do { tcg_env <- getGblEnv ; dflags <- getDynFlags ; let !mod = tcg_semantic_mod tcg_env+ home_unit = mkHomeUnitFromFlags dflags -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie.- is_instantiate = homeUnitIsDefinite dflags &&- not (null (homeUnitInstantiations dflags))+ is_instantiate = isHomeUnitInstantiating home_unit ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types =
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -120,11 +120,13 @@ import GHC.Types.Name.Env import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair import GHC.Types.Unique.Set import GHC.Driver.Session+import GHC.Driver.Ppr import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Basic ( TypeOrKind(..) )
compiler/GHC/Tc/Utils/Unify.hs view
@@ -71,6 +71,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import Control.Monad import Control.Arrow ( second )
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -79,6 +79,7 @@ import GHC.Data.Bag import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Unique.FM import GHC.Core.Multiplicity import GHC.Core@@ -532,12 +533,12 @@ zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss- , pat_ext = NPatBindTc fvs ty})+ , pat_ext = ty}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; new_grhss <- zonkGRHSs env zonkLExpr grhss ; new_ty <- zonkTcTypeToTypeX env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss- , pat_ext = NPatBindTc fvs new_ty }) }+ , pat_ext = new_ty }) } zonk_bind env (VarBind { var_ext = x , var_id = var, var_rhs = expr })@@ -625,8 +626,8 @@ , psb_dir = dir' } } zonkPatSynDetails :: ZonkEnv- -> HsPatSynDetails (Located TcId)- -> HsPatSynDetails (Located Id)+ -> HsPatSynDetails GhcTc+ -> HsPatSynDetails GhcTc zonkPatSynDetails env (PrefixCon as) = PrefixCon (map (zonkLIdOcc env) as) zonkPatSynDetails env (InfixCon a1 a2)@@ -1449,10 +1450,8 @@ zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) ----------------------------zonkConStuff :: ZonkEnv- -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))- -> TcM (ZonkEnv,- HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))+zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc+ -> TcM (ZonkEnv, HsConPatDetails GhcTc) zonkConStuff env (PrefixCon pats) = do { (env', pats') <- zonkPats env pats ; return (env', PrefixCon pats') }
compiler/GHC/Tc/Validity.hs view
@@ -66,7 +66,8 @@ import GHC.Data.List.SetOps import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable-import GHC.Types.Unique ( mkAlphaTyVarUnique )+import GHC.Utils.Panic+import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) import GHC.Data.Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/ThToHs.hs view
@@ -50,6 +50,7 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import qualified Data.ByteString as BS import Control.Monad( unless, ap )@@ -610,14 +611,6 @@ , con_mb_cxt = add_cxt cxt' cxt } where all_tvs = tvs' ++ ex_tvs-- -- The GadtC and RecGadtC cases of cvtConstr will always return a- -- ConDeclGADT, not a ConDeclGADTPrefixPs, so this case is unreachable.- -- See Note [GADT abstract syntax] in GHC.Hs.Decls for more on the- -- distinction between ConDeclGADT and ConDeclGADTPrefixPs.- add_forall _ _ con@(XConDecl (ConDeclGADTPrefixPs {})) =- pprPanic "cvtConstr.add_forall: Unexpected ConDeclGADTPrefixPs"- (Outputable.ppr con) cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name")
compiler/GHC/Types/Name/Shape.hs view
@@ -26,6 +26,7 @@ import GHC.Types.Name.Env import GHC.Tc.Utils.Monad import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Iface.Env import Control.Monad
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200801+version: 0.20200901 license: BSD3 license-file: LICENSE category: Development@@ -51,7 +51,6 @@ library default-language: Haskell2010- default-extensions: NoImplicitPrelude exposed: False include-dirs: includes@@ -81,7 +80,7 @@ process >= 1 && < 1.7, hpc == 0.6.*, exceptions == 0.10.*,- ghc-lib-parser == 0.20200801+ ghc-lib-parser == 0.20200901 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -116,6 +115,10 @@ TypeSynonymInstances UnboxedTuples UndecidableInstances+ default-extensions:+ BangPatterns+ NoImplicitPrelude+ ScopedTypeVariables hs-source-dirs: ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build@@ -146,6 +149,7 @@ GHC.Cmm.Node, GHC.Cmm.Switch, GHC.Cmm.Type,+ GHC.CmmToAsm.CFG.Weight, GHC.CmmToAsm.Config, GHC.Core, GHC.Core.Class,@@ -209,6 +213,7 @@ GHC.Driver.Phases, GHC.Driver.Pipeline.Monad, GHC.Driver.Plugins,+ GHC.Driver.Ppr, GHC.Driver.Session, GHC.Driver.Types, GHC.Exts.Heap,@@ -317,6 +322,7 @@ GHC.UniqueSubdir, GHC.Unit, GHC.Unit.Database,+ GHC.Unit.Home, GHC.Unit.Info, GHC.Unit.Module, GHC.Unit.Module.Env,@@ -405,6 +411,7 @@ GHC.CmmToAsm.Instr GHC.CmmToAsm.Monad GHC.CmmToAsm.PIC+ GHC.CmmToAsm.PPC GHC.CmmToAsm.PPC.CodeGen GHC.CmmToAsm.PPC.Cond GHC.CmmToAsm.PPC.Instr@@ -435,6 +442,7 @@ GHC.CmmToAsm.Reg.Liveness GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils+ GHC.CmmToAsm.SPARC GHC.CmmToAsm.SPARC.AddrMode GHC.CmmToAsm.SPARC.Base GHC.CmmToAsm.SPARC.CodeGen@@ -452,6 +460,9 @@ GHC.CmmToAsm.SPARC.Regs GHC.CmmToAsm.SPARC.ShortcutJump GHC.CmmToAsm.SPARC.Stack+ GHC.CmmToAsm.Types+ GHC.CmmToAsm.Utils+ GHC.CmmToAsm.X86 GHC.CmmToAsm.X86.CodeGen GHC.CmmToAsm.X86.Cond GHC.CmmToAsm.X86.Instr@@ -470,11 +481,11 @@ GHC.Core.Opt.CallArity GHC.Core.Opt.CprAnal GHC.Core.Opt.DmdAnal- GHC.Core.Opt.Driver GHC.Core.Opt.Exitify GHC.Core.Opt.FloatIn GHC.Core.Opt.FloatOut GHC.Core.Opt.LiberateCase+ GHC.Core.Opt.Pipeline GHC.Core.Opt.SetLevels GHC.Core.Opt.Simplify GHC.Core.Opt.Simplify.Env
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -1,6 +1,5 @@ primOpDocs =- [ ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits levity-polymorphism in both @a@ and\n @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n ")- , ("*#","Low word of signed integer multiply.")+ [ ("*#","Low word of signed integer multiply.") , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n the high and low bits of the double-word result. isHighNeeded is a cheap way\n to test if the high word is a sign-extension of the low word (isHighNeeded =\n 0#) or not (isHighNeeded = 1#).") , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n signed integer multiply might contain useful information. Return\n zero only if you are completely sure that no overflow can occur.\n On a 32-bit platform, the recommended implementation is to do a\n 32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n (result[31] >>signed 31). If this is zero, meaning that the\n upper word is merely a sign extension of the lower one, no\n overflow can occur.\n\n On a 64-bit platform it is not always possible to\n acquire the top 64 bits of the result. Therefore, a recommended\n implementation is to take the absolute value of both operands, and\n return 0 iff bits[63:31] of them are zero, since that means that their\n magnitudes fit within 31 bits, so the magnitude of the product must fit\n into 62 bits.\n\n If in doubt, return non-zero, but do make an effort to create the\n correct answer for small args, since otherwise the performance of\n @(*) :: Integer -> Integer -> Integer@ will be poor.\n ") , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n zero.\n ")@@ -224,6 +223,10 @@ , ("closureSize#"," @closureSize\\# closure@ returns the size of the given closure in\n machine words. ") , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n not profiling). Takes a dummy argument which can be used to\n avoid the call to @getCurrentCCS\\#@ being floated out by the\n simplifier, which would result in an uninformative stack\n (\"CAF\"). ") , ("clearCCS#"," Run the supplied IO action with an empty CCS. For example, this\n is used by the interpreter to run an interpreted computation\n without the call stack showing that it was invoked from GHC. ")+ , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits levity-polymorphism in both @a@ and\n @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n ")+ , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n It does not pass any information at runtime.\n See also @GHC.Magic.runRW\\#@. ")+ , ("void#"," This is an alias for the unboxed unit tuple constructor.\n In earlier versions of GHC, @void\\#@ was a value\n of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n ")+ , ("magicDict"," @magicDict@ is a special-purpose placeholder value.\n It is used internally by modules such as @GHC.TypeNats@ to cast a typeclass\n dictionary with a single method. It is eliminated by a rule during compilation.\n For the details, see Note [magicDictId magic] in GHC. ") , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A @Proxy#@\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") , ("proxy#"," Witness for an unboxed @Proxy#@ value, which has no runtime\n representation. ") , ("seq"," The value of @seq a b@ is bottom if @a@ is bottom, and\n otherwise equal to @b@. In other words, it evaluates the first\n argument @a@ to weak head normal form (WHNF). @seq@ is usually\n introduced to improve performance by avoiding unneeded laziness.\n\n A note on evaluation order: the expression @seq a b@ does\n /not/ guarantee that @a@ will be evaluated before @b@.\n The only guarantee given by @seq@ is that the both @a@\n and @b@ will be evaluated before @seq@ returns a value.\n In particular, this means that @b@ may be evaluated before\n @a@. If you need to guarantee a specific order of evaluation,\n you must use the function @pseq@ from the \"parallel\" package. ")
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -7,12 +7,12 @@ primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#") [] [charPrimTy] (intPrimTy) primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#") [] [int8PrimTy] (intPrimTy) primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#") [] [intPrimTy] (int8PrimTy)-primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy-primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy-primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy-primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy-primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy-primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy+primOpInfo Int8NegOp = mkGenPrimOp (fsLit "negateInt8#") [] [int8PrimTy] (int8PrimTy)+primOpInfo Int8AddOp = mkGenPrimOp (fsLit "plusInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy)+primOpInfo Int8SubOp = mkGenPrimOp (fsLit "subInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy)+primOpInfo Int8MulOp = mkGenPrimOp (fsLit "timesInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy)+primOpInfo Int8QuotOp = mkGenPrimOp (fsLit "quotInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy)+primOpInfo Int8RemOp = mkGenPrimOp (fsLit "remInt8#") [] [int8PrimTy, int8PrimTy] (int8PrimTy) primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#") [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy])) primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy@@ -22,12 +22,12 @@ primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#") [] [word8PrimTy] (wordPrimTy) primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#") [] [wordPrimTy] (word8PrimTy)-primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy-primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy-primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy-primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy-primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy-primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy+primOpInfo Word8NotOp = mkGenPrimOp (fsLit "notWord8#") [] [word8PrimTy] (word8PrimTy)+primOpInfo Word8AddOp = mkGenPrimOp (fsLit "plusWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy)+primOpInfo Word8SubOp = mkGenPrimOp (fsLit "subWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy)+primOpInfo Word8MulOp = mkGenPrimOp (fsLit "timesWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy)+primOpInfo Word8QuotOp = mkGenPrimOp (fsLit "quotWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy)+primOpInfo Word8RemOp = mkGenPrimOp (fsLit "remWord8#") [] [word8PrimTy, word8PrimTy] (word8PrimTy) primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#") [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy])) primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy@@ -37,12 +37,12 @@ primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#") [] [int16PrimTy] (intPrimTy) primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#") [] [intPrimTy] (int16PrimTy)-primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy-primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy-primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy-primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy-primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy-primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy+primOpInfo Int16NegOp = mkGenPrimOp (fsLit "negateInt16#") [] [int16PrimTy] (int16PrimTy)+primOpInfo Int16AddOp = mkGenPrimOp (fsLit "plusInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy)+primOpInfo Int16SubOp = mkGenPrimOp (fsLit "subInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy)+primOpInfo Int16MulOp = mkGenPrimOp (fsLit "timesInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy)+primOpInfo Int16QuotOp = mkGenPrimOp (fsLit "quotInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy)+primOpInfo Int16RemOp = mkGenPrimOp (fsLit "remInt16#") [] [int16PrimTy, int16PrimTy] (int16PrimTy) primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#") [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy])) primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy@@ -52,12 +52,12 @@ primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#") [] [word16PrimTy] (wordPrimTy) primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#") [] [wordPrimTy] (word16PrimTy)-primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy-primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy-primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy-primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy-primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy-primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy+primOpInfo Word16NotOp = mkGenPrimOp (fsLit "notWord16#") [] [word16PrimTy] (word16PrimTy)+primOpInfo Word16AddOp = mkGenPrimOp (fsLit "plusWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy)+primOpInfo Word16SubOp = mkGenPrimOp (fsLit "subWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy)+primOpInfo Word16MulOp = mkGenPrimOp (fsLit "timesWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy)+primOpInfo Word16QuotOp = mkGenPrimOp (fsLit "quotWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy)+primOpInfo Word16RemOp = mkGenPrimOp (fsLit "remWord16#") [] [word16PrimTy, word16PrimTy] (word16PrimTy) primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#") [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy])) primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy@@ -65,19 +65,19 @@ primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy-primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy-primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy-primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy+primOpInfo IntAddOp = mkGenPrimOp (fsLit "+#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntSubOp = mkGenPrimOp (fsLit "-#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntMulOp = mkGenPrimOp (fsLit "*#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo IntMul2Op = mkGenPrimOp (fsLit "timesInt2#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy]))-primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy-primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy-primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy+primOpInfo IntMulMayOfloOp = mkGenPrimOp (fsLit "mulIntMayOflo#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntQuotOp = mkGenPrimOp (fsLit "quotInt#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo IntRemOp = mkGenPrimOp (fsLit "remInt#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy-primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy-primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy-primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy-primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy+primOpInfo AndIOp = mkGenPrimOp (fsLit "andI#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo OrIOp = mkGenPrimOp (fsLit "orI#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo XorIOp = mkGenPrimOp (fsLit "xorI#") [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo NotIOp = mkGenPrimOp (fsLit "notI#") [] [intPrimTy] (intPrimTy)+primOpInfo IntNegOp = mkGenPrimOp (fsLit "negateInt#") [] [intPrimTy] (intPrimTy) primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy@@ -95,21 +95,21 @@ primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#") [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy+primOpInfo WordAddOp = mkGenPrimOp (fsLit "plusWord#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy-primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy+primOpInfo WordSubOp = mkGenPrimOp (fsLit "minusWord#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordMulOp = mkGenPrimOp (fsLit "timesWord#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy-primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy+primOpInfo WordQuotOp = mkGenPrimOp (fsLit "quotWord#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo WordRemOp = mkGenPrimOp (fsLit "remWord#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#") [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy-primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy-primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy-primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy+primOpInfo AndOp = mkGenPrimOp (fsLit "and#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo OrOp = mkGenPrimOp (fsLit "or#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo XorOp = mkGenPrimOp (fsLit "xor#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo NotOp = mkGenPrimOp (fsLit "not#") [] [wordPrimTy] (wordPrimTy) primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy)@@ -119,78 +119,78 @@ primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy-primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy-primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy-primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy+primOpInfo PopCnt8Op = mkGenPrimOp (fsLit "popCnt8#") [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCnt16Op = mkGenPrimOp (fsLit "popCnt16#") [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCnt32Op = mkGenPrimOp (fsLit "popCnt32#") [] [wordPrimTy] (wordPrimTy) primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#") [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy-primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy-primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy-primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy+primOpInfo PopCntOp = mkGenPrimOp (fsLit "popCnt#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Pdep8Op = mkGenPrimOp (fsLit "pdep8#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pdep16Op = mkGenPrimOp (fsLit "pdep16#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pdep32Op = mkGenPrimOp (fsLit "pdep32#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy-primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy-primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy-primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy+primOpInfo PdepOp = mkGenPrimOp (fsLit "pdep#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext8Op = mkGenPrimOp (fsLit "pext8#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext16Op = mkGenPrimOp (fsLit "pext16#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Pext32Op = mkGenPrimOp (fsLit "pext32#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy-primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy-primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy-primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy+primOpInfo PextOp = mkGenPrimOp (fsLit "pext#") [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo Clz8Op = mkGenPrimOp (fsLit "clz8#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Clz16Op = mkGenPrimOp (fsLit "clz16#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Clz32Op = mkGenPrimOp (fsLit "clz32#") [] [wordPrimTy] (wordPrimTy) primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#") [] [wordPrimTy] (wordPrimTy)-primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy-primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy-primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy-primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy+primOpInfo ClzOp = mkGenPrimOp (fsLit "clz#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz8Op = mkGenPrimOp (fsLit "ctz8#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz16Op = mkGenPrimOp (fsLit "ctz16#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Ctz32Op = mkGenPrimOp (fsLit "ctz32#") [] [wordPrimTy] (wordPrimTy) primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#") [] [wordPrimTy] (wordPrimTy)-primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy-primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy-primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy-primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy-primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy-primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy-primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy-primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy-primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy-primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy-primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy-primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy-primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy-primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy-primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy-primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy+primOpInfo CtzOp = mkGenPrimOp (fsLit "ctz#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap16Op = mkGenPrimOp (fsLit "byteSwap16#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap32Op = mkGenPrimOp (fsLit "byteSwap32#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwap64Op = mkGenPrimOp (fsLit "byteSwap64#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BSwapOp = mkGenPrimOp (fsLit "byteSwap#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev8Op = mkGenPrimOp (fsLit "bitReverse8#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev16Op = mkGenPrimOp (fsLit "bitReverse16#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev32Op = mkGenPrimOp (fsLit "bitReverse32#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BRev64Op = mkGenPrimOp (fsLit "bitReverse64#") [] [wordPrimTy] (wordPrimTy)+primOpInfo BRevOp = mkGenPrimOp (fsLit "bitReverse#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow8IntOp = mkGenPrimOp (fsLit "narrow8Int#") [] [intPrimTy] (intPrimTy)+primOpInfo Narrow16IntOp = mkGenPrimOp (fsLit "narrow16Int#") [] [intPrimTy] (intPrimTy)+primOpInfo Narrow32IntOp = mkGenPrimOp (fsLit "narrow32Int#") [] [intPrimTy] (intPrimTy)+primOpInfo Narrow8WordOp = mkGenPrimOp (fsLit "narrow8Word#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow16WordOp = mkGenPrimOp (fsLit "narrow16Word#") [] [wordPrimTy] (wordPrimTy)+primOpInfo Narrow32WordOp = mkGenPrimOp (fsLit "narrow32Word#") [] [wordPrimTy] (wordPrimTy) primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy-primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy-primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy-primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy-primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy-primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy-primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy+primOpInfo DoubleAddOp = mkGenPrimOp (fsLit "+##") [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleSubOp = mkGenPrimOp (fsLit "-##") [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleMulOp = mkGenPrimOp (fsLit "*##") [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleDivOp = mkGenPrimOp (fsLit "/##") [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleNegOp = mkGenPrimOp (fsLit "negateDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleFabsOp = mkGenPrimOp (fsLit "fabsDouble#") [] [doublePrimTy] (doublePrimTy) primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy) primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy)-primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy-primOpInfo DoubleExpM1Op = mkMonadic (fsLit "expm1Double#") doublePrimTy-primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy-primOpInfo DoubleLog1POp = mkMonadic (fsLit "log1pDouble#") doublePrimTy-primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy-primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy-primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy-primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy-primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy-primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy-primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy-primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy-primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy-primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy-primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy-primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy-primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy-primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy+primOpInfo DoubleExpOp = mkGenPrimOp (fsLit "expDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleExpM1Op = mkGenPrimOp (fsLit "expm1Double#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleLogOp = mkGenPrimOp (fsLit "logDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleLog1POp = mkGenPrimOp (fsLit "log1pDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSqrtOp = mkGenPrimOp (fsLit "sqrtDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSinOp = mkGenPrimOp (fsLit "sinDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleCosOp = mkGenPrimOp (fsLit "cosDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleTanOp = mkGenPrimOp (fsLit "tanDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAsinOp = mkGenPrimOp (fsLit "asinDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAcosOp = mkGenPrimOp (fsLit "acosDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAtanOp = mkGenPrimOp (fsLit "atanDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleSinhOp = mkGenPrimOp (fsLit "sinhDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleCoshOp = mkGenPrimOp (fsLit "coshDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleTanhOp = mkGenPrimOp (fsLit "tanhDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAsinhOp = mkGenPrimOp (fsLit "asinhDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAcoshOp = mkGenPrimOp (fsLit "acoshDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoubleAtanhOp = mkGenPrimOp (fsLit "atanhDouble#") [] [doublePrimTy] (doublePrimTy)+primOpInfo DoublePowerOp = mkGenPrimOp (fsLit "**##") [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy])) primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy@@ -199,31 +199,31 @@ primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy-primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy-primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy-primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy-primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy-primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy-primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy+primOpInfo FloatAddOp = mkGenPrimOp (fsLit "plusFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatSubOp = mkGenPrimOp (fsLit "minusFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatMulOp = mkGenPrimOp (fsLit "timesFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatDivOp = mkGenPrimOp (fsLit "divideFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatNegOp = mkGenPrimOp (fsLit "negateFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatFabsOp = mkGenPrimOp (fsLit "fabsFloat#") [] [floatPrimTy] (floatPrimTy) primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy)-primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy-primOpInfo FloatExpM1Op = mkMonadic (fsLit "expm1Float#") floatPrimTy-primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy-primOpInfo FloatLog1POp = mkMonadic (fsLit "log1pFloat#") floatPrimTy-primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy-primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy-primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy-primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy-primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy-primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy-primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy-primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy-primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy-primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy-primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy-primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy-primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy-primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy+primOpInfo FloatExpOp = mkGenPrimOp (fsLit "expFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatExpM1Op = mkGenPrimOp (fsLit "expm1Float#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatLogOp = mkGenPrimOp (fsLit "logFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatLog1POp = mkGenPrimOp (fsLit "log1pFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSqrtOp = mkGenPrimOp (fsLit "sqrtFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSinOp = mkGenPrimOp (fsLit "sinFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatCosOp = mkGenPrimOp (fsLit "cosFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatTanOp = mkGenPrimOp (fsLit "tanFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAsinOp = mkGenPrimOp (fsLit "asinFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAcosOp = mkGenPrimOp (fsLit "acosFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAtanOp = mkGenPrimOp (fsLit "atanFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatSinhOp = mkGenPrimOp (fsLit "sinhFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatCoshOp = mkGenPrimOp (fsLit "coshFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatTanhOp = mkGenPrimOp (fsLit "tanhFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAsinhOp = mkGenPrimOp (fsLit "asinhFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAcoshOp = mkGenPrimOp (fsLit "acoshFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatAtanhOp = mkGenPrimOp (fsLit "atanhFloat#") [] [floatPrimTy] (floatPrimTy)+primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))@@ -670,168 +670,168 @@ primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy-primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy-primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy-primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy-primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy-primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy-primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy-primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy-primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy-primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy-primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy-primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy-primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy-primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy-primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy-primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy-primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy-primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy-primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy-primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy-primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy-primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy-primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy-primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy-primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy-primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy-primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy-primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy-primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy-primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy-primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy-primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy-primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy-primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy-primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy-primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy-primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy-primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy-primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy-primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy-primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy-primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy-primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy-primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy-primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy-primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy-primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy-primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy-primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy-primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy-primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy-primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy-primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy-primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy-primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy-primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy-primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy-primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy-primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy-primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy-primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy-primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy-primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy-primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy-primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy-primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy-primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy-primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy-primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy-primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy-primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy-primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy-primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy-primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy-primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy-primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy-primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy-primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy-primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy-primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy-primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy-primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy-primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy-primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy-primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy-primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy-primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy-primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy-primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy-primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy-primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy-primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy-primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy-primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy-primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy-primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy-primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy-primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy-primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy-primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy-primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy-primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy-primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy-primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy-primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy-primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy-primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy-primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy-primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy-primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy-primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy-primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy-primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy-primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy-primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy-primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy-primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy-primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy-primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy-primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy-primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy-primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy-primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy-primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy-primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy-primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy-primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy-primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy-primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy-primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy-primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy-primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy-primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy-primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy-primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy-primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy-primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy-primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy-primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy-primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy-primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy-primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy-primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy-primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy-primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy-primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy-primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy-primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy-primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy-primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy-primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy-primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy-primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy-primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy-primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy-primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy+primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#") [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#") [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#") [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#") [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#") [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#") [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#") [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#") [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#") [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#") [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#") [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#") [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#") [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#") [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#") [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#") [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#") [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#") [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#") [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#") [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#") [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#") [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#") [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#") [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#") [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#") [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#") [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#") [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#") [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#") [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#") [] [int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#") [] [int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#") [] [int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#") [] [int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#") [] [int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#") [] [int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#") [] [int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#") [] [int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#") [] [int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#") [] [int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#") [] [int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#") [] [int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#") [] [floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#") [] [doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#") [] [floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#") [] [doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#") [] [floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#") [] [doubleX8PrimTy] (doubleX8PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,11 +5,11 @@ #define __GLASGOW_HASKELL__ 811 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ "8.11.0.20200801"+#define __GLASGOW_HASKELL_FULL_VERSION__ "8.11.0.20200901" #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200801+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200901 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/llvm-targets view
@@ -24,6 +24,9 @@ ,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux-musl", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i686-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i686-unknown-linux-musl", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i686-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-musl", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
ghc-lib/stage0/lib/settings view
@@ -12,6 +12,8 @@ ,("ld supports build-id", "NO") ,("ld supports filelist", "YES") ,("ld is GNU ld", "NO")+,("Merge objects command", "ld")+,("Merge objects flags", "-r") ,("ar command", "ar") ,("ar flags", "qcls") ,("ar supports at file", "NO")
includes/stg/MachRegs.h view
@@ -61,6 +61,8 @@ are the RX, FX, DX and USER registers; as a result, if you decide to caller save a system register (e.g. SP, HP, etc), note that this code path is completely untested! -- EZY++ See Note [Register parameter passing] for details. -------------------------------------------------------------------------- */ /* -----------------------------------------------------------------------------