ghc-lib 0.20211101 → 0.20211201
raw patch · 106 files changed
+4059/−3135 lines, 106 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +8/−8
- compiler/GHC/Builtin/Utils.hs +0/−8
- compiler/GHC/Cmm/Info.hs +1/−2
- compiler/GHC/Cmm/Info/Build.hs +30/−7
- compiler/GHC/Cmm/Pipeline.hs +1/−1
- compiler/GHC/Cmm/Sink.hs +57/−3
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +21/−14
- compiler/GHC/CmmToLlvm/Base.hs +1/−1
- compiler/GHC/Core/Opt/CSE.hs +5/−6
- compiler/GHC/Core/Opt/Pipeline.hs +2/−4
- compiler/GHC/Core/Opt/Simplify.hs +8/−5
- compiler/GHC/Core/Opt/SpecConstr.hs +153/−33
- compiler/GHC/Core/Opt/WorkWrap.hs +44/−29
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +1/−1
- compiler/GHC/CoreToStg/Prep.hs +7/−1
- compiler/GHC/Data/Graph/Base.hs +1/−1
- compiler/GHC/Driver/Backpack.hs +4/−18
- compiler/GHC/Driver/Main.hs +20/−17
- compiler/GHC/Driver/Make.hs +287/−230
- compiler/GHC/Driver/MakeFile.hs +7/−6
- compiler/GHC/Driver/Pipeline.hs +3/−4
- compiler/GHC/Driver/Pipeline/Execute.hs +5/−5
- compiler/GHC/Hs/Syn/Type.hs +1/−1
- compiler/GHC/HsToCore.hs +1/−1
- compiler/GHC/HsToCore/Arrows.hs +1/−1
- compiler/GHC/HsToCore/Coverage.hs +10/−10
- compiler/GHC/HsToCore/Expr.hs +1/−1
- compiler/GHC/HsToCore/Match/Literal.hs +1/−1
- compiler/GHC/HsToCore/Pmc.hs +43/−19
- compiler/GHC/HsToCore/Pmc/Solver.hs +96/−38
- compiler/GHC/HsToCore/Quote.hs +13/−9
- compiler/GHC/Iface/Errors.hs +5/−4
- compiler/GHC/Iface/Ext/Ast.hs +40/−40
- compiler/GHC/Iface/Load.hs +36/−32
- compiler/GHC/Iface/Recomp.hs +9/−7
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs +2/−10
- compiler/GHC/IfaceToCore.hs +6/−4
- compiler/GHC/Linker/Loader.hs +13/−11
- compiler/GHC/Linker/Static.hs +1/−1
- compiler/GHC/Rename/Bind.hs +7/−4
- compiler/GHC/Rename/Expr.hs +23/−29
- compiler/GHC/Rename/HsType.hs +5/−3
- compiler/GHC/Rename/Module.hs +17/−10
- compiler/GHC/Rename/Names.hs +1/−1
- compiler/GHC/Rename/Pat.hs +16/−14
- compiler/GHC/Rename/Utils.hs +8/−0
- compiler/GHC/Runtime/Heap/Inspect.hs +3/−0
- compiler/GHC/Runtime/Loader.hs +28/−22
- compiler/GHC/Settings/IO.hs +18/−16
- compiler/GHC/Stg/DepAnal.hs +0/−146
- compiler/GHC/Stg/FVs.hs +202/−95
- compiler/GHC/Stg/Lift.hs +8/−7
- compiler/GHC/Stg/Lint.hs +1/−1
- compiler/GHC/Stg/Pipeline.hs +11/−8
- compiler/GHC/Stg/Unarise.hs +6/−6
- compiler/GHC/StgToByteCode.hs +5/−5
- compiler/GHC/StgToCmm/Closure.hs +4/−4
- compiler/GHC/StgToCmm/Expr.hs +4/−4
- compiler/GHC/StgToCmm/Layout.hs +1/−1
- compiler/GHC/SysTools/Tasks.hs +5/−6
- compiler/GHC/Tc/Deriv.hs +23/−32
- compiler/GHC/Tc/Deriv/Functor.hs +21/−18
- compiler/GHC/Tc/Deriv/Generate.hs +223/−52
- compiler/GHC/Tc/Deriv/Generics.hs +89/−107
- compiler/GHC/Tc/Deriv/Infer.hs +49/−51
- compiler/GHC/Tc/Deriv/Utils.hs +78/−103
- compiler/GHC/Tc/Errors.hs +153/−47
- compiler/GHC/Tc/Errors/Hole.hs +2/−4
- compiler/GHC/Tc/Gen/Arrow.hs +6/−6
- compiler/GHC/Tc/Gen/Expr.hs +11/−12
- compiler/GHC/Tc/Gen/Head.hs +7/−5
- compiler/GHC/Tc/Gen/HsType.hs +4/−4
- compiler/GHC/Tc/Gen/Match.hs +3/−3
- compiler/GHC/Tc/Gen/Pat.hs +19/−12
- compiler/GHC/Tc/Gen/Rule.hs +3/−3
- compiler/GHC/Tc/Instance/Typeable.hs +3/−12
- compiler/GHC/Tc/Module.hs +3/−1
- compiler/GHC/Tc/Plugin.hs +8/−7
- compiler/GHC/Tc/Solver.hs +81/−33
- compiler/GHC/Tc/Solver/Canonical.hs +20/−13
- compiler/GHC/Tc/Solver/Interact.hs +129/−66
- compiler/GHC/Tc/TyCl.hs +15/−6
- compiler/GHC/Tc/TyCl/Build.hs +2/−0
- compiler/GHC/Tc/TyCl/Instance.hs +6/−5
- compiler/GHC/Tc/TyCl/PatSyn.hs +1/−1
- compiler/GHC/Tc/TyCl/Utils.hs +5/−3
- compiler/GHC/Tc/Utils/Backpack.hs +21/−18
- compiler/GHC/Tc/Utils/Env.hs +3/−2
- compiler/GHC/Tc/Utils/Monad.hs +17/−8
- compiler/GHC/Tc/Utils/TcMType.hs +63/−48
- compiler/GHC/Tc/Utils/Zonk.hs +14/−14
- compiler/GHC/Tc/Validity.hs +2/−2
- compiler/GHC/ThToHs.hs +43/−52
- compiler/GHC/Unit/Finder.hs +20/−10
- compiler/MachDeps.h +0/−119
- compiler/ghc-llvm-version.h +11/−0
- ghc-lib.cabal +7/−7
- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +302/−0
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +53/−53
- ghc-lib/stage0/lib/GhclibDerivedConstants.h +0/−559
- ghc-lib/stage0/lib/ghcautoconf.h +0/−632
- ghc-lib/stage0/lib/ghcplatform.h +0/−28
- ghc-lib/stage0/lib/settings +1/−1
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +559/−0
- ghc-lib/stage0/rts/build/include/ghcautoconf.h +635/−0
- ghc-lib/stage0/rts/build/include/ghcplatform.h +26/−0
compiler/GHC.hs view
@@ -1643,25 +1643,25 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do- let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags+ let fc = hsc_FC hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ let units = hsc_units hsc_env+ let dflags = hsc_dflags hsc_env+ let fopts = initFinderOpts dflags case pkgqual of ThisPkg _ -> do home <- lookupLoadedHomeModule mod_name case home of Just m -> return m Nothing -> liftIO $ do- res <- findImportedModule fc fopts units home_unit mod_name pkgqual+ res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual case res of- Found loc m | not (isHomeModule home_unit m) -> return m+ Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do- res <- findImportedModule fc fopts units home_unit mod_name pkgqual+ res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
compiler/GHC/Builtin/Utils.hs view
@@ -62,7 +62,6 @@ import GHC.Core.TyCon import GHC.Types.Avail-import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env@@ -130,13 +129,6 @@ = all_names where all_names =- -- We exclude most tuples from this list—see- -- Note [Infinite families of known-key names] in GHC.Builtin.Names.- -- We make an exception for Solo (i.e., the boxed 1-tuple), since it does- -- not use special syntax like other tuples.- -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)- -- in GHC.Builtin.Types.- tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 : concat [ concatMap wired_tycon_kk_names primTyCons , concatMap wired_tycon_kk_names wiredInTyCons , concatMap wired_tycon_kk_names typeNatTyCons
compiler/GHC/Cmm/Info.hs view
@@ -283,8 +283,7 @@ -- See the section "Referring to an SRT from the info table" in -- Note [SRTs] in "GHC.Cmm.Info.Build" inlineSRT :: Platform -> Bool-inlineSRT platform = platformArch platform == ArchX86_64- && platformTablesNextToCode platform+inlineSRT = pc_USE_INLINE_SRT_FIELD . platformConstants ------------------------------------------------------------------------- --
compiler/GHC/Cmm/Info/Build.hs view
@@ -55,6 +55,7 @@ import GHC.Types.Name.Set {- Note [SRTs]+ ~~~~~~~~~~~ SRTs are the mechanism by which the garbage collector can determine the live CAFs in the program.@@ -112,9 +113,15 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.+In each case, the info table points to the SRT. There are three ways which we+may encode the location of the SRT in the info table, described below. -- info->srt is zero if there's no SRT, otherwise:+USE_SRT_OFFSET+--------------+In this case we use the info->srt to encode whether or not there is an+SRT and if so encode the offset to its location in info->f.srt_offset:++- info->srt is 0 if there's no SRT, otherwise, - info->srt == 1 and info->f.srt_offset points to the SRT e.g. for a FUN with an SRT:@@ -128,12 +135,27 @@ info->type | ... | |------| -On x86_64, we optimise the info table representation further. The-offset to the SRT can be stored in 32 bits (all code lives within a-2GB region in x86_64's small memory model), so we can save a word in-the info table by storing the srt_offset in the srt field, which is-half a word.+USE_SRT_POINTER+---------------+When tables-next-to-code isn't in use we rather encode an absolute pointer to+the SRT in info->srt. e.g. for a FUN with an SRT: +StgFunInfoTable +------++ info->f.srt_offset | ------------> pointer to SRT object+StgStdInfoTable +------++ info->layout.ptrs | ... |+ info->layout.nptrs | ... |+ info->srt | 1 |+ info->type | ... |+ |------|+USE_INLINE_SRT_FIELD+--------------------+When using TNTC on x86_64 (and other platforms using the small memory model),+we optimise the info table representation further. The offset to the SRT can+be stored in 32 bits (all code lives within a 2GB region in x86_64's small+memory model), so we can save a word in the info table by storing the+srt_offset in the srt field, which is half a word.+ On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169): - info->srt is zero if there's no SRT, otherwise:@@ -368,6 +390,7 @@ -- --------------------------------------------------------------------- {- Note [Invalid optimisation: shortcutting]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ You might think that if we have something like
compiler/GHC/Cmm/Pipeline.hs view
@@ -142,7 +142,7 @@ ----------- Control-flow optimisations ----------------------------- g <- {-# SCC "cmmCfgOpts(2)" #-}- return $ if optLevel dflags >= 1+ return $ if gopt Opt_CmmControlFlow dflags then map (cmmCfgOptsProc splitting_proc_points) g else g g <- return (map removeUnreachableBlocksProc g)
compiler/GHC/Cmm/Sink.hs view
@@ -318,21 +318,65 @@ where go [] block as = (block, as) go ((live,node):ns) block as+ -- discard nodes representing dead assignment | shouldDiscard node live = go ns block as- -- discard dead assignment+ -- sometimes only after simplification we can tell we can discard the node.+ -- See Note [Discard simplified nodes]+ | noOpAssignment node2 = go ns block as+ -- Pick up interesting assignments | Just a <- shouldSink platform node2 = go ns block (a : as1)+ -- Try inlining, drop assignments and move on | otherwise = go ns block' as' where+ -- Simplify node node1 = constantFoldNode platform node + -- Inline assignments (node2, as1) = tryToInline platform live node1 as + -- Drop any earlier assignments conflicting with node2 (dropped, as') = dropAssignmentsSimple platform (\a -> conflicts platform a node2) as1 + -- Walk over the rest of the block. Includes dropped assignments block' = foldl' blockSnoc block dropped `blockSnoc` node2 +{- Note [Discard simplified nodes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a sequence like this: + _c1::P64 = R1;+ _c3::I64 = I64[_c1::P64 + 1];+ R1 = _c1::P64;+ P64[Sp - 72] = _c1::P64;+ I64[Sp - 64] = _c3::I64;++If we discard assignments *before* simplifying nodes when we get to `R1 = _c1`.+This is then simplified into `R1 = `R1` and as a consequence prevents sinking of+loads from R1. What happens is that we:+ * Check if we can discard the node `R1 = _c1 (no)+ * Simplify the node to R1 = R1+ * We check all remaining assignments for conflicts.+ * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup)+ conflicts with R1 = R1, because it reads `R1` and the node writes+ to R1+ * This is clearly no-sensical because `R1 = R1` doesn't affect R1's value.++The solutions is to check if we can discard nodes before and *after* simplifying+them. We could only do it after as well, but I assume doing it early might save+some work.++That is if we process a assignment node we now:+ * Check if it can be discarded (because it's dead or a no-op)+ * Simplify the rhs of the assignment.+ * New: Check again if it might be a no-op now.+ * ...++This can help with problems like the one reported in #20334. For a full example see the test+cmm_sink_sp.++-}+ -- -- Heuristic to decide whether to pick up and sink an assignment -- Currently we pick up all assignments to local registers. It might@@ -358,11 +402,20 @@ shouldDiscard :: CmmNode e x -> LRegSet -> Bool shouldDiscard node live = case node of+ -- r = r CmmAssign r (CmmReg r') | r == r' -> True+ -- r = e, r is dead after assignment CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live) _otherwise -> False +noOpAssignment :: CmmNode e x -> Bool+noOpAssignment node+ = case node of+ -- r = r+ CmmAssign r (CmmReg r') | r == r' -> True+ _otherwise -> False + toNode :: Assignment -> CmmNode O O toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs @@ -379,7 +432,9 @@ go _ [] dropped kept = (dropped, kept) go state (assig : rest) dropped kept- | conflict = go state' rest (toNode assig : dropped) kept+ | conflict =+ let !node = toNode assig+ in go state' rest (node : dropped) kept | otherwise = go state' rest dropped (assig:kept) where (dropit, state') = should_drop assig state@@ -394,7 +449,6 @@ tryToInline :: forall x. Platform -> LRegSet -- set of registers live after this- -- -> LocalRegSet -- set of registers live after this -- node. We cannot inline anything -- that is live after the node, unless -- it is small enough to duplicate.
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1875,12 +1875,16 @@ ChildCode64 code2 r2 <- iselExpr64 e2 let cond = machOpToCond mop :: Cond - let cmpCode = intComparison cond true false r1 r2+ -- we mustn't clobber r1/r2 so we use temporaries+ tmp1 <- getNewRegNat II32+ tmp2 <- getNewRegNat II32++ let cmpCode = intComparison cond true false r1 r2 tmp1 tmp2 return $ code1 `appOL` code2 `appOL` cmpCode where- intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock- intComparison cond true false r1_lo r2_lo =+ intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> Reg -> Reg -> InstrBlock+ intComparison cond true false r1_lo r2_lo tmp1 tmp2 = case cond of -- Impossible results of machOpToCond ALWAYS -> panic "impossible"@@ -1897,29 +1901,32 @@ GE -> cmpGE GEU -> cmpGE -- [x > y] <==> ![y >= x]- GTT -> intComparison GE false true r2_lo r1_lo- GU -> intComparison GEU false true r2_lo r1_lo+ GTT -> intComparison GE false true r2_lo r1_lo tmp1 tmp2+ GU -> intComparison GEU false true r2_lo r1_lo tmp1 tmp2 -- [x <= y] <==> [y >= x]- LE -> intComparison GE true false r2_lo r1_lo- LEU -> intComparison GEU true false r2_lo r1_lo+ LE -> intComparison GE true false r2_lo r1_lo tmp1 tmp2+ LEU -> intComparison GEU true false r2_lo r1_lo tmp1 tmp2 -- [x < y] <==> ![x >= x]- LTT -> intComparison GE false true r1_lo r2_lo- LU -> intComparison GEU false true r1_lo r2_lo+ LTT -> intComparison GE false true r1_lo r2_lo tmp1 tmp2+ LU -> intComparison GEU false true r1_lo r2_lo tmp1 tmp2 where r1_hi = getHiVRegFromLo r1_lo r2_hi = getHiVRegFromLo r2_lo cmpExact :: OrdList Instr cmpExact = toOL- [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)- , XOR II32 (OpReg r2_lo) (OpReg r1_lo)- , OR II32 (OpReg r1_hi) (OpReg r1_lo)+ [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+ , MOV II32 (OpReg r1_lo) (OpReg tmp2)+ , XOR II32 (OpReg r2_hi) (OpReg tmp1)+ , XOR II32 (OpReg r2_lo) (OpReg tmp2)+ , OR II32 (OpReg tmp1) (OpReg tmp2) , JXX cond true , JXX ALWAYS false ] cmpGE = toOL- [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)- , SBB II32 (OpReg r2_hi) (OpReg r1_hi)+ [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+ , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+ , SBB II32 (OpReg r2_hi) (OpReg tmp1) , JXX cond true , JXX ALWAYS false ]
compiler/GHC/CmmToLlvm/Base.hs view
@@ -39,7 +39,7 @@ aliasify, llvmDefLabel ) where -#include "ghcautoconf.h"+#include "ghc-llvm-version.h" import GHC.Prelude import GHC.Utils.Panic
compiler/GHC/Core/Opt/CSE.hs view
@@ -20,7 +20,7 @@ , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma , isJoinId, isJoinId_maybe )-import GHC.Core.Utils ( mkAltExpr, eqExpr+import GHC.Core.Utils ( mkAltExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) import GHC.Core.FVs ( exprFreeVars )@@ -652,7 +652,7 @@ cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr cseCase env scrut bndr ty alts = Case scrut1 bndr3 ty' $- combineAlts alt_env (map cse_alt alts)+ combineAlts (map cse_alt alts) where ty' = substTy (csEnvSubst env) ty (cse_done, scrut1) = try_for_cse env scrut@@ -684,9 +684,9 @@ where (env', args') = addBinders alt_env args -combineAlts :: CSEnv -> [OutAlt] -> [OutAlt]+combineAlts :: [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives]-combineAlts env alts+combineAlts alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts , Alt _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts@@ -697,7 +697,6 @@ | otherwise = alts where- in_scope = substInScope (csEnvSubst env) find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) -- The (Just alt) is a binder-free alt@@ -709,7 +708,7 @@ | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs+ identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -221,10 +221,8 @@ core_todo = if opt_level == 0 then- [ static_ptrs_float_outwards,- CoreDoSimplify max_iter- (base_mode { sm_phase = FinalPhase- , sm_names = ["Non-opt simplification"] })+ [ static_ptrs_float_outwards+ , simplify "Non-opt simplification" , add_caller_ccs ]
compiler/GHC/Core/Opt/Simplify.hs view
@@ -932,7 +932,7 @@ -- substitution will happen, since we are going to discard the binding else -- Keep the binding; do cast worker/wrapper- -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $+ -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs } addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId@@ -1082,7 +1082,7 @@ -> SimplM OutExpr -- Simplify an expression, given a continuation simplExprC env expr cont- = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $+ = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ do { (floats, expr') <- simplExprF env expr cont ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $@@ -1584,8 +1584,11 @@ | isSimplified dup_flag = return (dup_flag, arg_env, arg) | otherwise- = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg- ; return (Simplified, zapSubstEnv arg_env, arg') }+ = do { let arg_env' = arg_env `setInScopeFromE` env+ ; arg' <- simplExpr arg_env' arg+ ; return (Simplified, zapSubstEnv arg_env', arg') }+ -- Return a StaticEnv that includes the in-scope set from 'env',+ -- because arg' may well mention those variables (#20639) {- ************************************************************************@@ -3012,7 +3015,7 @@ -- by the caller (rebuildCase) in the missingAlt function ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts- ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $+-- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () ; let alts_ty' = contResultType cont' -- See Note [Avoiding space leaks in OutType]
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -62,6 +62,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic.Plain+import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad import GHC.Utils.Trace@@ -625,6 +626,37 @@ that we have ForceSpecConstr, this NoSpecConstr is probably redundant. (Used only for PArray, TODO: remove?) +Note [SpecConstr and evaluated unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+SpecConstr will attach evaldUnfolding unfoldings to function+arguments representing things that should be fully evaluated+by the time we execute the RHS.++This primarily concerns strict fields. To give an example in the+containers package we have a merge function with this specialization:++ "SC:$wmerge01" [2]+ forall (sc_s5lX :: ghc-prim:GHC.Prim.Int#)+ (sc_s5lY :: ghc-prim:GHC.Prim.Int#)+ (sc_s5lZ+ :: IntMap a_s4UX+ Unf=OtherCon [])+ (sc_s5m0+ :: IntMap a_s4UX+ Unf=OtherCon [])+ (sc_s5lW :: ghc-prim:GHC.Prim.Int#)+ (sc_s5lU :: ghc-prim:GHC.Prim.Int#)+ (sc_s5lV :: a_s4UX).+ $wmerge0_s4UK (Data.IntMap.Internal.Tip @a_s4UX sc_s5lU sc_s5lV)+ (ghc-prim:GHC.Types.I# sc_s5lW)+ (Data.IntMap.Internal.Bin+ @a_s4UX sc_s5lX sc_s5lY sc_s5lZ sc_s5m0)+ = $s$wmerge0_s5m2+ sc_s5lX sc_s5lY sc_s5lZ sc_s5m0 sc_s5lW sc_s5lU sc_s5lV]++We give sc_s5lZ and sc_s5m0 a evaluated unfolding since they come out of+strict field fields in the Bin constructor.+ ----------------------------------------------------- Stuff not yet handled -----------------------------------------------------@@ -1149,8 +1181,6 @@ | ScrutOcc -- See Note [ScrutOcc] (DataConEnv [ArgOcc]) -- How the sub-components are used -type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon- {- Note [ScrutOcc] ~~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,@@ -1296,9 +1326,14 @@ -- the parent function (see Note [Forcing specialisation]) ; (spec_usg, specs) <- specNonRec env body_usg rhs_info + -- Specialized + original binding+ ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'+ -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)+ ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg]- mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+ spec_bnds+ ) } @@ -1698,6 +1733,10 @@ (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs) -- Remember, there may be fewer pats than arg_bndrs -- See Note [SpecConstr call patterns]+ -- extra_bndrs will then be arguments in the specialized version+ -- which are *not* applied to arguments immediately at the call sites.+ -- e.g. let f x y = ... in map (f True) xs+ -- will result in y becoming an extra_bndr fn_name = idName fn fn_loc = nameSrcSpan fn_name@@ -1719,6 +1758,7 @@ -- return () -- Specialise the body+ -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env) ; (spec_usg, spec_body) <- scExpr body_env body -- ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $@@ -1726,16 +1766,16 @@ -- And build the results ; let spec_body_ty = exprType spec_body- (spec_lam_args1, spec_sig, spec_arity, spec_join_arity) = calcSpecInfo fn call_pat extra_bndrs -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders]) (spec_lam_args, spec_call_args) = mkWorkerArgs fn False- spec_lam_args1 spec_body_ty+ spec_lam_args1+ spec_body_ty -- mkWorkerArgs: usual w/w hack to avoid generating- -- a spec_rhs of unlifted type and no args+ -- a spec_rhs of unlifted type and no args. spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args spec_body_ty)@@ -1782,7 +1822,8 @@ where DmdSig (DmdType _ fn_dmds div) = idDmdSig fn - val_pats = filterOut isTypeArg pats+ val_pats = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop+ -- from the original functions demand and for setting up dmd_env. qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] extra_dmds = dropList val_pats fn_dmds @@ -2138,7 +2179,7 @@ callToPats env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScope (sc_subst env) - ; pairs <- zipWithM (argToPat env in_scope con_env) args bndr_occs+ ; pairs <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) -- This zip trims the args to be no longer than -- the lambdas in the function definition (bndr_occs) @@ -2188,7 +2229,11 @@ ( text "SpecConstr: bad covars:" <+> ppr bad_covars $$ ppr call) $ if interesting && isEmptyVarSet bad_covars- then return (Just (CP { cp_qvars = qvars', cp_args = pats }))+ then+ -- pprTraceM "callToPatsOut" (+ -- text "fun" <> ppr fn $$+ -- ppr (CP { cp_qvars = qvars', cp_args = pats })) >>+ return (Just (CP { cp_qvars = qvars', cp_args = pats })) else return Nothing } -- argToPat takes an actual argument, and returns an abstracted@@ -2202,6 +2247,8 @@ -> ValueEnv -- ValueEnv at the call site -> CoreArg -- A call arg (or component thereof) -> ArgOcc+ -> StrictnessMark -- Tells us if this argument is a strict field of a data constructor+ -- See Note [SpecConstr and evaluated unfoldings] -> UniqSM (Bool, CoreArg) -- Returns (interesting, pat),@@ -2214,11 +2261,25 @@ -- lvl7 --> (True, lvl7) if lvl7 is bound -- somewhere further out -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ+argToPat env in_scope val_env arg arg_occ arg_str+ = do+ -- pprTraceM "argToPatIn" (ppr arg)+ !res <- argToPat1 env in_scope val_env arg arg_occ arg_str+ -- pprTraceM "argToPatOut" (ppr res)+ return res++argToPat1 :: ScEnv+ -> InScopeSet+ -> ValueEnv+ -> Expr CoreBndr+ -> ArgOcc+ -> StrictnessMark+ -> UniqSM (Bool, Expr CoreBndr)+argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str = return (False, arg) -argToPat env in_scope val_env (Tick _ arg) arg_occ- = argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env (Tick _ arg) arg_occ _arg_str+ = argToPat env in_scope val_env arg arg_occ _arg_str -- Note [Tick annotations in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes@@ -2226,8 +2287,8 @@ -- ride roughshod over them all for now. --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules -argToPat env in_scope val_env (Let _ arg) arg_occ- = argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str+ = argToPat env in_scope val_env arg arg_occ arg_str -- See Note [Matching lets] in "GHC.Core.Rules" -- Look through let expressions -- e.g. f (let v = rhs in (v,w))@@ -2240,11 +2301,11 @@ = argToPat env in_scope val_env rhs arg_occ -} -argToPat env in_scope val_env (Cast arg co) arg_occ+argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str | not (ignoreType env ty2)- = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+ = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ arg_str ; if not interesting then- wildCardPat ty2+ wildCardPat ty2 arg_str else do { -- Make a wild-card pattern for the coercion uniq <- getUniqueM@@ -2270,22 +2331,52 @@ -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs-argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env arg arg_occ _arg_str | Just (ConVal (DataAlt dc) args) <- isValue val_env arg , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args- ; prs <- zipWithM (argToPat env in_scope val_env) rest_args arg_occs- ; let args' = map snd prs+ con_str, matched_str :: [StrictnessMark]+ -- con_str corrresponds 1-1 with the /value/ arguments+ -- matched_str corresponds 1-1 with /all/ arguments+ con_str = dataConRepStrictness dc+ matched_str = match_vals con_str rest_args+ -- ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$+ -- ppr dc $$+ -- ppr con_str $$+ -- ppr rest_args $$+ -- ppr (map isTypeArg rest_args))+ ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str+ ; let args' = map snd prs :: [CoreArg]+ ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))+ ( ppr con_str $$ ppr rest_args $$+ ppr (length con_str) $$ ppr (length rest_args)+ ) $ return ()+ -- ; assert (length con_str == length rest_args) $+ -- pprTraceM "argToPat"+ -- ( parens (int $ length con_str) <> ppr con_str $$+ -- ppr rest_args $$+ -- ppr prs) ; return (True, mkConApp dc (ty_args ++ args')) } where mb_scrut dc = case arg_occ of- ScrutOcc bs | Just occs <- lookupUFM bs dc- -> Just (occs) -- See Note [Reboxing]- _other | sc_force env || sc_keen env- -> Just (repeat UnkOcc)- | otherwise- -> Nothing+ ScrutOcc bs | Just occs <- lookupUFM bs dc+ -> Just (occs) -- See Note [Reboxing]+ _other | sc_force env || sc_keen env+ -> Just (repeat UnkOcc)+ | otherwise+ -> Nothing+ match_vals bangs (arg:args)+ | isTypeArg arg+ = NotMarkedStrict : match_vals bangs args+ | (b:bs) <- bangs+ = b : match_vals bs args+ match_vals [] [] = []+ match_vals as bs =+ pprPanic "spec-constr:argToPat - Bangs don't match value arguments"+ (text "arg:" <> ppr arg $$+ text "remaining args:" <> ppr as $$+ text "remaining bangs:" <> ppr bs) -- Check if the argument is a variable that -- (a) is used in an interesting way in the function body@@ -2294,7 +2385,7 @@ -- business of absence analysis, not SpecConstr.) -- (b) we know what its value is -- In that case it counts as "interesting"-argToPat env in_scope val_env (Var v) arg_occ+argToPat1 env in_scope val_env (Var v) arg_occ _arg_str | sc_force env || case arg_occ of { ScrutOcc {} -> True ; UnkOcc -> False ; NoOcc -> False } -- (a)@@ -2303,7 +2394,7 @@ -- So sc_keen focused just on f (I# x), where we have freshly-allocated -- box that we can eliminate in the caller , not (ignoreType env (varType v))- = return (True, Var v)+ = return (True, Var (setStrUnfolding v MarkedStrict)) where is_value | isLocalId v = v `elemInScopeSet` in_scope@@ -2332,13 +2423,42 @@ -- The default case: make a wild-card -- We use this for coercions too-argToPat _env _in_scope _val_env arg _arg_occ- = wildCardPat (exprType arg)+argToPat1 _env _in_scope _val_env arg _arg_occ arg_str+ = wildCardPat (exprType arg) arg_str -wildCardPat :: Type -> UniqSM (Bool, CoreArg)-wildCardPat ty+-- We want the given id to be passed call-by-value if it's MarkedCbv.+-- For some, but not all ids this can be achieved by giving them an OtherCon unfolding.+-- Doesn't touch existing value unfoldings.+-- See Note [SpecConstr and evaluated unfoldings]+setStrUnfolding :: Id -> StrictnessMark -> Id+-- setStrUnfolding id str = id+setStrUnfolding id str+ -- | pprTrace "setStrUnfolding"+ -- (ppr id <+> ppr (isMarkedCbv str) $$+ -- ppr (idType id) $$+ -- text "boxed:" <> ppr (isBoxedType (idType id)) $$+ -- text "unlifted:" <> ppr (isUnliftedType (idType id))+ -- )+ -- False+ -- = undefined+ | not (isId id) || isEvaldUnfolding (idUnfolding id)+ = id+ | isMarkedStrict str+ , not (isUnliftedType (idType id)) -- Pointless to stick an evald unfolding on unlifted types+ = -- trace "setStrUnfolding2" $+ assert (isId id) $+ assert (not $ hasCoreUnfolding $ idUnfolding id) $+ id `setIdUnfolding` evaldUnfolding+ | otherwise+ = -- trace "setStrUnfolding3"+ id++wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg)+wildCardPat ty str = do { uniq <- getUniqueM- ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty+ ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty `setStrUnfolding` str+ -- See Note [SpecConstr and evaluated unfoldings]+ -- ; pprTraceM "wildCardPat" (ppr id <+> ppr (idUnfolding id)) ; return (False, varToCoreExpr id) } isValue :: ValueEnv -> CoreExpr -> Maybe Value
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -463,28 +463,40 @@ In module Bar we want to give specialisations a chance to fire before inlining f's wrapper. - Historical note: At one stage I tried making the wrapper inlining+ (Historical note: At one stage I tried making the wrapper inlining always-active, and that had a very bad effect on nofib/imaginary/x2n1;- a wrapper was inlined before the specialisation fired.+ a wrapper was inlined before the specialisation fired.) +4a. If we have+ {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-}+ {-# NOINLINE [n] foo #-}+ then specialisation will generate a SPEC rule active from Phase n.+ See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise+ This SPEC specialisation rule will compete with inlining, but we don't+ mind that, because if inlining succeeds, it should be better.++ Now, if we w/w foo, we must ensure that the wrapper (which is very+ keen to inline) has a phase /after/ 'n', else it'll always "win" over+ the SPEC rule -- disaster (#20709).++Conclusion: the activation for the wrapper should be the /later/ of+ (a) the current activation of the function, or FinalPhase if it is NOINLINE+ (b) one phase /after/ the activation of any rules+This is implemented by mkStrWrapperInlinePrag.+ Reminder: Note [Don't w/w INLINE things], so we don't need to worry about INLINE things here. -Conclusion:- - If the user said NOINLINE[n] or INLINABLE[n], respect that by putting- INLINE[n] on the wrapper (and NOINLINE[n]/INLINABLE[n] on the worker). - - If the user said NOINLINE, inline the wrapper only in- FinalPhase, which is after all the numbered, user-visible phases (and put- the original pragma on the worker). That means that all rules will have had- a chance to fire.- NB: Similar to InitialPhase, users can't write INLINE[Final] f;- it's syntactically illegal. See Note [Compiler phases].+What if `foo` has no specialiations, is worker/wrappered (with the+wrapper inlining very early), and exported; and then in an importing+module we have {-# SPECIALISE foo : ... #-}? - - Otherwise (no pragma or INLINABLE) inline the wrapper in the first phase- *after* InitialPhase. We run InitialPhase before the specialiser so that- will not inline the wrapper before specialisation; but it will do so- immediately afterwards.+Well then, we'll specialise foo's wrapper, which will expose a+specialisation for foo's worker, which we will do too. That seems+fine. (To work reliably, `foo` would need an INLINABLE pragma,+in which case we don't unpack dictionaries for the worker; see+see Note [Do not unbox class dictionaries].) Note [Wrapper NoUserInlinePrag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -814,7 +826,7 @@ | otherwise = topDmd wrap_rhs = wrap_fn work_id- wrap_prag = mkStrWrapperInlinePrag fn_inl_prag+ wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules wrap_unf = mkWrapperUnfolding simpl_opts wrap_rhs arity wrap_id = fn_id `setIdUnfolding` wrap_unf@@ -826,25 +838,28 @@ fn_inl_prag = inlinePragInfo fn_info fn_inline_spec = inl_inline fn_inl_prag fn_unfolding = realUnfoldingInfo fn_info+ fn_rules = ruleInfoRules (ruleInfo fn_info) -mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma-mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma+-- See Note [Wrapper activation]+mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline] , inl_sat = Nothing- , inl_act = wrap_act+ , inl_act = activeAfter wrapper_phase , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected where- wrap_act = case act of -- See Note [Wrapper activation]- NeverActive -> activateDuringFinal- FinalActive -> act- ActiveAfter {} -> act- ActiveBefore {} -> activateAfterInitial- AlwaysActive -> activateAfterInitial- -- For the last two cases, see (4) in Note [Wrapper activation]- -- NB: the (ActiveBefore n) isn't quite right. We really want- -- it to be active *after* Initial but *before* n. We don't have- -- a way to say that, alas.+ -- See Note [Wrapper activation]+ wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules+ earliest_inline_phase = beginPhase act `laterPhase` nextPhase InitialPhase+ -- laterPhase (nextPhase InitialPhase) is a temporary hack+ -- to inline no earlier than phase 2. I got regressions in+ -- 'mate', due to changes in full laziness due to Note [Case+ -- MFEs], when I did earlier inlining.++ get_rule_phase :: CoreRule -> CompilerPhase+ -- The phase /after/ the rule is first active+ get_rule_phase rule = nextPhase (beginPhase (ruleActivation rule)) {- Note [Demand on the worker]
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -271,7 +271,7 @@ only_one_void_argument | [d] <- demands , [v] <- filter isId arg_vars- , isAbsDmd d && isVoidTy (idType v)+ , isAbsDmd d && isZeroBitTy (idType v) = True | otherwise = False
compiler/GHC/CoreToStg/Prep.hs view
@@ -1527,7 +1527,13 @@ ok _ _ = False -- We can't eta reduce something which must be saturated.- ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f))+ ok_to_eta_reduce (Var f) = not (hasNoBinding f) &&+ not (isLinearType (idType f)) && -- Unsure why this is unsafe.+ (not (isJoinId f) || idJoinArity f <= n_remaining)+ -- Don't undersaturate join points.+ -- See Note [Invariants on join points] in GHC.Core, and #20599++ ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
compiler/GHC/Data/Graph/Base.hs view
@@ -42,7 +42,7 @@ -- There used to be more fields, but they were turfed out in a previous revision. -- maybe we'll want more later.. ---data Graph k cls color+newtype Graph k cls color = Graph { -- | All active nodes in the graph. graphMap :: UniqFM k (Node k cls color) }
compiler/GHC/Driver/Backpack.hs view
@@ -719,8 +719,8 @@ -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature.- let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =- Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod+ let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =+ Just `fmap` summariseDecl pn hsc_src lmodname hsmod get_decl _ = return Nothing nodes <- catMaybes `fmap` mapM get_decl decls @@ -806,23 +806,9 @@ summariseDecl :: PackageName -> HscSource -> Located ModuleName- -> Maybe (Located HsModule)+ -> Located HsModule -> BkpM ExtendedModSummary-summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod-summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing- = do hsc_env <- getSession- -- TODO: this looks for modules in the wrong place- r <- liftIO $ summariseModule hsc_env- emptyModNodeMap -- GHC API recomp not supported- (hscSourceToIsBoot hsc_src)- lmodname- Nothing -- GHC API buffer support not supported- [] -- No exclusions- case r of- Nothing -> throwOneError $ fmap GhcDriverMessage- $ mkPlainErrorMsgEnvelope loc (DriverBackpackModuleNotFound modname)- Just (Left err) -> throwErrors (fmap GhcDriverMessage err)- Just (Right summary) -> return summary+summariseDecl pn hsc_src (L _ modname) hsmod = hsModuleToModSummary pn hsc_src modname hsmod -- | Up until now, GHC has assumed a single compilation target per source file. -- Backpack files with inline modules break this model, since a single file
compiler/GHC/Driver/Main.hs view
@@ -74,6 +74,7 @@ , hscTcRnLookupRdrName , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls+ , hscParseModuleWithLocation , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType , hscParseExpr , hscParseType@@ -159,7 +160,6 @@ import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax-import GHC.Stg.FVs ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg ) import GHC.Builtin.Utils@@ -1766,24 +1766,22 @@ (5-10%). -} -doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]- -> CollectedCCs- -> [StgTopBinding]- -> HpcInfo- -> IO (Stream IO CmmGroupSRTs CgInfos)+doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+ -> CollectedCCs+ -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+ -> HpcInfo+ -> IO (Stream IO CmmGroupSRTs CgInfos) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. doCodeGen hsc_env this_mod denv data_tycons- cost_centre_info stg_binds hpc_info = do+ cost_centre_info stg_binds_w_fvs hpc_info = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env let tmpfs = hsc_tmpfs hsc_env let platform = targetPlatform dflags - let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds- putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let stg_to_cmm = case stgToCmmHook hooks of@@ -1828,7 +1826,7 @@ -> Bool -> Module -> ModLocation -> CoreExpr -> IO ( Id- , [StgTopBinding]+ , [CgStgTopBinding] , InfoTableProvMap , CollectedCCs ) myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do@@ -1851,7 +1849,7 @@ myCoreToStg :: Logger -> DynFlags -> InteractiveContext -> Bool -> Module -> ModLocation -> CoreProgram- -> IO ( [StgTopBinding] -- output program+ -> IO ( [CgStgTopBinding] -- output program , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do@@ -1859,11 +1857,11 @@ = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod ml prepd_binds - stg_binds2+ stg_binds_with_fvs <- {-# SCC "Stg2Stg" #-} stg2stg logger dflags ictxt for_bytecode this_mod stg_binds - return (stg_binds2, denv, cost_centre_info)+ return (stg_binds_with_fvs, denv, cost_centre_info) {- ********************************************************************** %* *@@ -1937,12 +1935,17 @@ -> IO ([TyThing], InteractiveContext) hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1 -hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]-hscParseDeclsWithLocation hsc_env source line_num str = do- L _ (HsModule{ hsmodDecls = decls }) <-+hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule+hscParseModuleWithLocation hsc_env source line_num str = do+ L _ mod <- runInteractiveHsc hsc_env $ hscParseThingWithLocation source line_num parseModule str- return decls+ return mod++hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]+hscParseDeclsWithLocation hsc_env source line_num str = do+ HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str+ return decls -- | Compile a decls hscDeclsWithLocation :: HscEnv
compiler/GHC/Driver/Make.hs view
@@ -43,7 +43,7 @@ implicitRequirementsShallow, noModError, cyclicModuleErr,- moduleGraphNodes, SummaryNode,+ SummaryNode, IsBootInterface(..), mkNodeKey, ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert@@ -53,7 +53,7 @@ import GHC.Platform import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad ( initIfaceLoad )+import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Runtime.Interpreter import qualified GHC.Linker.Loader as Linker@@ -107,10 +107,10 @@ import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import GHC.Types.Name-import GHC.Types.Name.Env import GHC.Types.PkgQual import GHC.Unit+import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface@@ -414,8 +414,18 @@ . unitId +-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+ = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]++instance Outputable ModuleGraphNodeWithBootFile where+ ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode+getNode (ModuleGraphNodeWithBootFile mgn _) = mgn data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle- | ResolvedCycle [ModuleGraphNode] -- A resolved cycle, linearised by hs-boot files+ | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -- A resolved cycle, linearised by hs-boot files | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files instance Outputable BuildPlan where@@ -454,21 +464,41 @@ mresolved_cycle = collapseSCC (topSortWithBoot nodes) in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] - -- An environment mapping a module to its hs-boot file, if one exists+ (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)+ trans_deps_map = allReachable mg (mkNodeKey . node_payload)+ boot_path mn =+ map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $+ Set.delete (NodeKey_Module (GWIB mn IsBoot)) $+ expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn NotBoot)) trans_deps_map)+ `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn IsBoot)) trans_deps_map))+++ -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists boot_modules = mkModuleEnv- [ (ms_mod ms, m) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]+ [ (ms_mod ms, (m, boot_path (ms_mod_name ms))) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot] select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]- select_boot_modules = mapMaybe (\m -> case m of ModuleNode (ExtendedModSummary ms _) -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing )+ select_boot_modules = mapMaybe (fmap fst . get_boot_module) + get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))+ get_boot_module m = case m of ModuleNode (ExtendedModSummary ms _) | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing+ -- Any cycles should be resolved now- collapseSCC :: [SCC ModuleGraphNode] -> Maybe [ModuleGraphNode]+ collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle- collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [node1, node2]- collapseSCC (AcyclicSCC node : nodes) = (node :) <$> collapseSCC nodes+ collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]+ collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes -- Cyclic collapseSCC _ = Nothing + toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)+ toNodeWithBoot mn =+ case get_boot_module mn of+ -- The node doesn't have a boot file+ Nothing -> Left mn+ -- The node does have a boot file+ Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))+ -- The toposort and accumulation of acyclic modules is solely to pick-up -- hs-boot files which are **not** part of cycles. collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]@@ -814,30 +844,28 @@ ``` data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle- | ResolvedCycle [ModuleGraphNode] -- A resolved cycle, linearised by hs-boot files+ | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files ``` The plan is computed in two steps: -Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains- cycles.-Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should- result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.-+Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains+ cycles.+Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should+ result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.+Step 2a: For each module in the cycle, if the module has a boot file then compute the+ modules on the path between it and the hs-boot file. This information is+ stored in ModuleGraphNodeWithBoot. The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function. * SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.-* ResolvedCycles need to compiled "together" so that the information which ends up in- the interface files at the end is accurate (and doesn't contain temporary information from- the hs-boot files.)- - During the initial compilation, a `KnotVars` is created which stores an IORef TypeEnv for- each module of the loop. These IORefs are gradually updated as the loop completes and provide- the required laziness to typecheck the module loop.- - At the end of typechecking, all the interface files are typechecked again in- the retypecheck loop. This time, the knot-tying is done by the normal laziness- based tying, so the environment is run without the KnotVars.+* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented+ with a consistent knot-tied version of modules at the end.+ - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration+ is performed both before and after the module in question is compiled.+ See Note [Hydrating Modules] for more information. * UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files and are reported as an error to the user. @@ -871,8 +899,8 @@ As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which can be queried at the end to get the result of all modules at the end, with their proper visibility. For example, if any module in a loop fails then all modules in that loop will-report as failed because the visible node at the end will be the result of retypechecking-those modules together.+report as failed because the visible node at the end will be the result of checking+these modules together. -} @@ -982,8 +1010,10 @@ -- Can't continue past this point as the cycle is unresolved. UnresolvedCycle ns -> return (Just ns, []) - buildSingleModule :: Maybe (ModuleEnv (IORef TypeEnv)) -> ModuleGraphNode -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))- buildSingleModule knot_var mod = do+ buildSingleModule :: Maybe [ModuleGraphNode] -- Modules we need to rehydrate before compiling this module+ -> ModuleGraphNode -- The node we are compiling+ -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))+ buildSingleModule rehydrate_nodes mod = do mod_idx <- nodeId home_mod_map <- getBuildMap hpt_var <- gets hpt_var@@ -992,16 +1022,22 @@ doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps build_deps = map snd doc_build_deps -- 2. Set the default way to build this node, not in a loop here- let build_action =+ let build_action = do+ hsc_env <- asks hsc_env case mod of InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu ModuleNode ms -> do let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt- hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms)+ rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes+ hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) rehydrate_mods (emsModSummary ms) -- This global MVar is incrementally modified in order to avoid having to -- recreate the HPT before compiling each module which leads to a quadratic amount of work.- liftIO $ modifyMVar_ hpt_var (\hpt -> return $! addHomeModInfoToHpt hmi hpt)- return (Just hmi)+ hmi' <- liftIO $ modifyMVar hpt_var (\hpt -> do+ let new_hpt = addHomeModInfoToHpt hmi hpt+ new_hsc = setHPT new_hpt hsc_env+ maybeRehydrateAfter hmi new_hsc rehydrate_mods+ )+ return (Just hmi') res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var@@ -1009,33 +1045,26 @@ return $ (MakeAction build_action res_var, result_var) - buildModuleLoop :: [ModuleGraphNode] -> BuildM [MakeAction]- buildModuleLoop ms = do- let ms_mods = mapMaybe (\case InstantiationNode {} -> Nothing; ModuleNode ems -> Just (ms_mod (emsModSummary ems))) ms- knot_var <- liftIO $ mkModuleEnv <$> mapM (\m -> (m,) <$> newIORef emptyNameEnv) ms_mods+ buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))+ buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =+ buildSingleModule (Just deps) mn - -- 1. Build all the dependencies in this loop- (build_modules, wait_modules) <- mapAndUnzipM (buildSingleModule (Just knot_var)) ms- hpt_var <- gets hpt_var+ buildModuleLoop :: [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -> BuildM [MakeAction]+ buildModuleLoop ms = do+ (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms res_var <- liftIO newEmptyMVar- let loop_action = do- !hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules)- liftIO $ modifyMVar_ hpt_var (\hpt -> return $! foldl' (flip addHomeModInfoToHpt) hpt hmis)- return hmis--+ let loop_action = wait_deps wait_modules let fanout i = Just . (!! i) <$> mkResultVar res_var -- From outside the module loop, anyone must wait for the loop to finish and then- -- use the result of the retypechecked iface.+ -- use the result of the rehydrated iface. This makes sure that things not in the+ -- module loop will see the updated interfaces for all the identifiers in the loop. let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i) - let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModule) ms) [0..]+ let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModSum . either id getNode) ms) [0..] mapM update_module_pipeline ms_i return $ build_modules ++ [MakeAction loop_action res_var] -- upsweep :: Int -- ^ The number of workers we wish to run in parallel -> HscEnv -- ^ The base HscEnv, which is augmented for each module@@ -1227,52 +1256,6 @@ -- -- ------------------------------------------------------------------------------ Typecheck module loops-{--See bug #930. This code fixes a long-standing bug in --make. The-problem is that when compiling the modules *inside* a loop, a data-type that is only defined at the top of the loop looks opaque; but-after the loop is done, the structure of the data type becomes-apparent.--The difficulty is then that two different bits of code have-different notions of what the data type looks like.--The idea is that after we compile a module which also has an .hs-boot-file, we re-generate the ModDetails for each of the modules that-depends on the .hs-boot file, so that everyone points to the proper-TyCons, Ids etc. defined by the real module, not the boot module.-Fortunately re-generating a ModDetails from a ModIface is easy: the-function GHC.IfaceToCore.typecheckIface does exactly that.--Following this fix, GHC can compile itself with --make -O2.--}--typecheckLoop :: HscEnv -> [HomeModInfo] -> IO [(ModuleName, HomeModInfo)]-typecheckLoop hsc_env hmis = do- debugTraceMsg logger 2 $- text "Re-typechecking loop: "- fixIO $ \new_mods -> do- let new_hpt = addListToHpt old_hpt new_mods- let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env- -- Crucial, crucial: initIfaceLoad clears the if_rec_types field.- -- See [KnotVars invariants]- -- Note [GHC Heap Invariants]- mds <- initIfaceLoad new_hsc_env $- mapM (typecheckIface . hm_iface) hmis- let new_mods = [ (mn,hmi{ hm_details = details })- | (hmi,details) <- zip hmis mds- , let mn = moduleName (mi_module (hm_iface hmi)) ]- return new_mods-- where- logger = hsc_logger hsc_env- to_delete = (map (moduleName . mi_module . hm_iface) hmis)- -- Filter out old modules before tying the knot, otherwise we can end- -- up with a thunk which keeps reference to the old HomeModInfo.- !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete---- --------------------------------------------------------------------------- -- -- | Topological sort of the module graph topSortModuleGraph@@ -1322,80 +1305,17 @@ = throwGhcException (ProgramError "module does not exist") in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) -type SummaryNode = Node Int ModuleGraphNode--summaryNodeKey :: SummaryNode -> Int-summaryNodeKey = node_key--summaryNodeSummary :: SummaryNode -> ModuleGraphNode-summaryNodeSummary = node_payload---- | Collect the immediate dependencies of a ModuleGraphNode,--- optionally avoiding hs-boot dependencies.--- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is--- an equivalent .hs-boot, add a link from the former to the latter. This--- has the effect of detecting bogus cases where the .hs-boot depends on the--- .hs, by introducing a cycle. Additionally, it ensures that we will always--- process the .hs-boot before the .hs, and so the HomePackageTable will always--- have the most up to date information.-unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]-unfilteredEdges drop_hs_boot_nodes = \case- InstantiationNode iuid ->- NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)- ModuleNode (ExtendedModSummary ms bds) ->- [ NodeKey_Unit inst_unit | inst_unit <- bds ] ++- (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++- [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot- | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile- ] ++- (NodeKey_Module . flip GWIB NotBoot . unLoc <$> ms_home_imps ms)- where- -- Drop hs-boot nodes by using HsSrcFile as the key- hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature- | otherwise = IsBoot--moduleGraphNodes :: Bool -> [ModuleGraphNode]- -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)-moduleGraphNodes drop_hs_boot_nodes summaries =- (graphFromEdgedVerticesUniq nodes, lookup_node)- where- numbered_summaries = zip summaries [1..]-- lookup_node :: NodeKey -> Maybe SummaryNode- lookup_node key = Map.lookup key (unNodeMap node_map)-- lookup_key :: NodeKey -> Maybe Int- lookup_key = fmap summaryNodeKey . lookup_node-- node_map :: NodeMap SummaryNode- node_map = NodeMap $- Map.fromList [ (mkNodeKey s, node)- | node <- nodes- , let s = summaryNodeSummary node- ]-- -- We use integers as the keys for the SCC algorithm- nodes :: [SummaryNode]- nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s- | (s, key) <- numbered_summaries- -- Drop the hi-boot ones if told to do so- , case s of- InstantiationNode _ -> True- ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes- ]-- out_edge_keys :: [NodeKey] -> [Int]- out_edge_keys = mapMaybe lookup_key- -- If we want keep_hi_boot_nodes, then we do lookup_key with- -- IsBoot; else False- -- The nodes of the graph are keyed by (mod, is boot?) pairs for the current -- modules, and indefinite unit IDs for dependencies which are instantiated with -- our holes. -- -- NB: hsig files show up as *normal* nodes (not boot!), since they don't -- participate in cycles (for now)-type ModNodeKey = ModuleNameWithIsBoot++mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary+mkNodeMap summaries = ModNodeMap $ Map.fromList+ [ (ms_mnwib $ emsModSummary s, s) | s <- summaries]+ newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } deriving (Functor, Traversable, Foldable) @@ -1411,37 +1331,6 @@ modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a modNodeMapLookup k (ModNodeMap m) = Map.lookup k m -data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey- deriving (Eq, Ord)--instance Outputable NodeKey where- ppr nk = pprNodeKey nk--newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }- deriving (Functor, Traversable, Foldable)--mkNodeKey :: ModuleGraphNode -> NodeKey-mkNodeKey = \case- InstantiationNode x -> NodeKey_Unit x- ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)--mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot-mkHomeBuildModule0 ms = GWIB- { gwib_mod = moduleName $ ms_mod ms- , gwib_isBoot = isBootSummary ms- }--msKey :: ModSummary -> ModuleNameWithIsBoot-msKey = mkHomeBuildModule0--pprNodeKey :: NodeKey -> SDoc-pprNodeKey (NodeKey_Unit iu) = ppr iu-pprNodeKey (NodeKey_Module mk) = ppr mk--mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary-mkNodeMap summaries = ModNodeMap $ Map.fromList- [ (mkHomeBuildModule0 $ emsModSummary s, s) | s <- summaries]- -- | Efficiently construct a map from a NodeKey to its list of transitive dependencies mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey]) mkDepsMap nodes =@@ -1909,11 +1798,11 @@ | otherwise = find_it where- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags- home_unit = hsc_home_unit hsc_env- fc = hsc_FC hsc_env- units = hsc_units hsc_env+ dflags = hsc_dflags hsc_env+ fopts = initFinderOpts dflags+ mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ fc = hsc_FC hsc_env+ units = hsc_units hsc_env check_hash old_summary location src_fn = checkSummaryHash@@ -1922,7 +1811,7 @@ old_summary location find_it = do- found <- findImportedModule fc fopts units home_unit wanted_mod NoPkgQual+ found <- findImportedModule fc fopts units mhome_unit wanted_mod NoPkgQual case found of Found location mod | isJust (ml_hs_file location) ->@@ -1970,10 +1859,10 @@ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ DriverFileModuleNameMismatch pi_mod_name wanted_mod - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $- let instantiations = homeUnitInstantiations home_unit- in throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc- $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations+ let instantiations = fromMaybe [] (homeUnitInstantiations <$> mhome_unit)+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+ $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn@@ -2270,33 +2159,26 @@ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) return res + executeCompileNode :: Int -> Int -> Maybe HomeModInfo -> RunMakeM HomePackageTable- -> Maybe (ModuleEnv (IORef TypeEnv))+ -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling -> ModSummary -> RunMakeM HomeModInfo-executeCompileNode k n !old_hmi wait_deps mknot_var mod = do+executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do MakeEnv{..} <- ask- let mk_mod = case ms_hsc_src mod of- HsigFile ->- -- MP: It is probably a bit of a misimplementation in backpack that- -- compiling a signature requires an knot_var for that unit.- -- If you remove this then a lot of backpack tests fail.- let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (ms_mod mod)- in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv- _ -> return emptyModuleEnv- knot_var <- liftIO $ maybe mk_mod return mknot_var deps <- wait_deps+ -- Rehydrate any dependencies if this module had a boot file or is a signature file. withLoggerHsc k $ \hsc_env -> do+ hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHPT deps hsc_env) mod fixed_mrehydrate_mods let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas lcl_dynflags = ms_hspp_opts mod let lcl_hsc_env = -- Localise the hsc_env to use the cached flags- setHPT deps $ hscSetFlags lcl_dynflags $- hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }+ hydrated_hsc_env -- Compile the module, locking with a semphore to avoid too many modules -- being compiled at the same time leading to high memory usage. lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do@@ -2304,18 +2186,193 @@ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags return res) -executeTypecheckLoop :: IO HomePackageTable -- Dependencies of the loop- -> RunMakeM [HomeModInfo] -- The loop itself- -> RunMakeM [HomeModInfo]-executeTypecheckLoop wait_other_deps wait_local_deps = do- hsc_env <- asks hsc_env- hmis <- wait_local_deps- other_deps <- liftIO wait_other_deps- let lcl_hsc_env = setHPT other_deps hsc_env- -- Notice that we do **not** have to pass the knot variables into this function.- -- That's the whole point of typecheckLoop, to replace the IORef calls with normal- -- knot-tying.- lift $ MaybeT $ Just . map snd <$> typecheckLoop lcl_hsc_env hmis+ where+ fixed_mrehydrate_mods =+ case ms_hsc_src mod of+ -- MP: It is probably a bit of a misimplementation in backpack that+ -- compiling a signature requires an knot_var for that unit.+ -- If you remove this then a lot of backpack tests fail.+ HsigFile -> Just []+ _ -> mrehydrate_mods++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating.+ -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+ -> IO HscEnv+rehydrate hsc_env hmis = do+ debugTraceMsg logger 2 $+ text "Re-hydrating loop: "+ new_mods <- fixIO $ \new_mods -> do+ let new_hpt = addListToHpt old_hpt new_mods+ let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env+ mds <- initIfaceCheck (text "rehydrate") new_hsc_env $+ mapM (typecheckIface . hm_iface) hmis+ let new_mods = [ (mn,hmi{ hm_details = details })+ | (hmi,details) <- zip hmis mds+ , let mn = moduleName (mi_module (hm_iface hmi)) ]+ return new_mods+ return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env++ where+ logger = hsc_logger hsc_env+ to_delete = (map (moduleName . mi_module . hm_iface) hmis)+ -- Filter out old modules before tying the knot, otherwise we can end+ -- up with a thunk which keeps reference to the old HomeModInfo.+ !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mod (Just mns) = do+ knot_var <- initialise_knot_var hsc_env+ let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns+ rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis++ where+ initialise_knot_var hsc_env = liftIO $+ let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)+ in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++maybeRehydrateAfter :: HomeModInfo+ -> HscEnv+ -> Maybe [ModuleName]+ -> IO (HomePackageTable, HomeModInfo)+maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HPT new_hsc, hmi)+maybeRehydrateAfter hmi new_hsc (Just mns) = do+ let new_hpt = hsc_HPT new_hsc+ hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns+ new_mod_name = moduleName (mi_module (hm_iface hmi))+ final_hpt <- hsc_HPT <$> rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)+ return (final_hpt, expectJust "rehydrate" $ lookupHpt final_hpt new_mod_name)++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+| On-disk M.hi |+------------------------------+ | ^+ | Read file | Write file+ V |+-------------------------------+| ByteString |+-------------------------------+ | ^+ | Binary.get | Binary.put+ V |+--------------------------------+| ModIface (an acyclic AST) |+--------------------------------+ | ^+ | hydrate | mkIfaceTc+ V |+---------------------------------+| ModDetails (lots of cycles) |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+ the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot: module R where+ data T+ g :: T -> T++A.hs: module A( f, T, g ) where+ import {-# SOURCE #-} R+ data S = MkS T+ f :: T -> S = ...g...++R.hs: module R where+ import A+ data T = T1 | T2 S+ g = ...f...+```++## Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it. But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call+`rehydrateIface` to convert it to a ModDetails. It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++## Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++## Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++## Modules "above" the loop++This dark corner is the subject of #14092.++Suppose we add to our example+```+X.hs module X where+ import A+ data XT = MkX T+ fx = ...g...+```+If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the the argument type of `MkX`. So:++* Either we should delay compiling X until after R has beeen compiled. (This is what we do)+* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.++Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.+#20200 has lots of issues, many of them now fixed;+this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).++The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.+Also closely related are+ * #14092+ * #14103++-}+ -- | Wait for some dependencies to finish and then read from the given MVar. wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
compiler/GHC/Driver/MakeFile.hs view
@@ -36,6 +36,7 @@ import GHC.Iface.Load (cannotFindModule) +import GHC.Unit.Env import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph@@ -290,14 +291,14 @@ -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do- let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags+ let fc = hsc_FC hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ let units = hsc_units hsc_env+ let dflags = hsc_dflags hsc_env+ let fopts = initFinderOpts dflags -- Find the module; this will be fast because -- we've done it once during downsweep- r <- findImportedModule fc fopts units home_unit imp pkg+ r <- findImportedModule fc fopts units mhome_unit imp pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file
compiler/GHC/Driver/Pipeline.hs view
@@ -48,7 +48,6 @@ ) where -#include "ghcplatform.h" import GHC.Prelude import GHC.Platform@@ -635,7 +634,7 @@ setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv setDumpPrefix pipe_env hsc_env =- hscUpdateFlags (\dflags -> dflags { dumpPrefix = Just (src_basename pipe_env ++ ".")}) hsc_env+ hscUpdateFlags (\dflags -> dflags { dumpPrefix = src_basename pipe_env ++ "."}) hsc_env {- The Pipelines -} @@ -796,8 +795,8 @@ llvmManglePipeline pipe_env hsc_env location llc_fn = do mangled_fn <- if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)- then use (T_LlvmMangle pipe_env hsc_env llc_fn)- else return llc_fn+ then return llc_fn+ else use (T_LlvmMangle pipe_env hsc_env llc_fn) asPipeline False pipe_env hsc_env location mangled_fn cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-#include "ghcplatform.h"+#include <ghcplatform.h> {- Functions for providing the default interpretation of the 'TPhase' actions -}@@ -216,7 +216,7 @@ -- let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env- llvmOpts = case optLevel dflags of+ llvmOpts = case llvmOptLevel dflags of 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. 1 -> "-O1" _ -> "-O2"@@ -250,7 +250,7 @@ logger = hsc_logger hsc_env let -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate- optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2]+ optIdx = max 0 $ min 2 $ llvmOptLevel dflags -- ensure we're in [0,2] llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of Just passes -> passes Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "@@ -410,8 +410,8 @@ | otherwise = [] - let cc_opt | optLevel dflags >= 2 = [ "-O2" ]- | optLevel dflags >= 1 = [ "-O" ]+ let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ]+ | llvmOptLevel dflags >= 1 = [ "-O" ] | otherwise = [] -- Decide next phase
compiler/GHC/Hs/Syn/Type.hs view
@@ -112,7 +112,7 @@ hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t hsExprType (HsMultiIf ty _) = ty-hsExprType (HsLet _ _ body) = lhsExprType body+hsExprType (HsLet _ _ _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
compiler/GHC/HsToCore.hs view
@@ -740,7 +740,7 @@ (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy runtimeRep1Ty runtimeRep2Ty- (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty)+ (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty) (openAlphaTy `mkCastTy` alpha_co) openBetaTy
compiler/GHC/HsToCore/Arrows.hs view
@@ -567,7 +567,7 @@ -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars
compiler/GHC/HsToCore/Coverage.hs view
@@ -575,11 +575,11 @@ = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x binds e) =- bindLocals (collectLocalBinders CollNoDictBinders binds) $- liftM2 (HsLet x)- (addTickHsLocalBinds binds) -- to think about: !patterns.- (addTickLHsExprLetBody e)+addTickHsExpr (HsLet x tkLet binds tkIn e) =+ bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+ binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+ e' <- addTickLHsExprLetBody e+ return (HsLet x tkLet binds' tkIn e') addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) ; return (HsDo srcloc cxt (L l stmts')) }@@ -884,11 +884,11 @@ (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x binds c) =- bindLocals (collectLocalBinders CollNoDictBinders binds) $- liftM2 (HsCmdLet x)- (addTickHsLocalBinds binds) -- to think about: !patterns.- (addTickLHsCmd c)+addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =+ bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+ binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+ c' <- addTickLHsCmd c+ return (HsCmdLet x tkLet binds' tkIn c') addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) ; return (HsCmdDo srcloc (L l stmts')) }
compiler/GHC/HsToCore/Expr.hs view
@@ -360,7 +360,7 @@ -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints-dsExpr (HsLet _ binds body) = do+dsExpr (HsLet _ _ binds _ body) = do body' <- dsLExpr body dsLocalBinds binds body'
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -568,7 +568,7 @@ _ -> Nothing tidyNPat over_lit mb_neg eq outer_ty- = NPat outer_ty (noLoc over_lit) mb_neg eq+ = NPat outer_ty (noLocA over_lit) mb_neg eq {- ************************************************************************
compiler/GHC/HsToCore/Pmc.hs view
@@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-} -- | This module coverage checks pattern matches. It finds --@@ -105,7 +106,7 @@ tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) result <- unCA (checkPatBind pat_bind) missing tracePm "}: " (ppr (cr_uncov result))- formatReportWarnings cirbsPatBind ctxt [var] result+ formatReportWarnings ReportPatBind ctxt [var] result pmcPatBind _ _ _ = pure () -- | Exhaustive for guard matches, is used for guards in pattern bindings and@@ -116,7 +117,7 @@ -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long -- distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do- let combined_loc = foldl1 combineSrcSpans (map getLoc grhss)+ let combined_loc = foldl1 combineSrcSpans (map getLocA grhss) ctxt = DsMatchContext hs_ctxt combined_loc !missing <- getLdiNablas matches <- noCheckDs $ desugarGRHSs combined_loc empty guards@@ -126,7 +127,7 @@ (pprGRHSs hs_ctxt guards $$ ppr missing)) result <- unCA (checkGRHSs matches) missing tracePm "}: " (ppr (cr_uncov result))- formatReportWarnings cirbsGRHSs ctxt [] result+ formatReportWarnings ReportGRHSs ctxt [] result return (ldiGRHSs (cr_ret result)) -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each@@ -166,7 +167,7 @@ empty_case <- noCheckDs $ desugarEmptyCase var result <- unCA (checkEmptyCase empty_case) missing tracePm "}: " (ppr (cr_uncov result))- formatReportWarnings cirbsEmptyCase ctxt vars result+ formatReportWarnings ReportEmptyCase ctxt vars result return [] Just matches -> do matches <- {-# SCC "desugarMatches" #-}@@ -174,7 +175,7 @@ result <- {-# SCC "checkMatchGroup" #-} unCA (checkMatchGroup matches) missing tracePm "}: " (ppr (cr_uncov result))- {-# SCC "formatReportWarnings" #-} formatReportWarnings cirbsMatchGroup ctxt vars result+ {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result return (NE.toList (ldiMatchGroup (cr_ret result))) {- Note [pmcPatBind only checks PatBindRhs]@@ -317,25 +318,45 @@ -- * Formatting and reporting warnings -- --- | Given a function that collects 'CIRB's, this function will emit warnings+-- | A datatype to accomodate the different call sites of+-- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann'+-- through 'collectInMode'. Since this is only possible for a couple of+-- well-known 'ann's, this is a GADT.+data FormatReportWarningsMode ann where+ ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)+ ReportGRHSs :: FormatReportWarningsMode (PmGRHSs Post)+ ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)+ ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase++deriving instance Eq (FormatReportWarningsMode ann)++-- | A function collecting 'CIRB's for each of the different+-- 'FormatReportWarningsMode's.+collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB+collectInMode ReportPatBind = cirbsPatBind+collectInMode ReportGRHSs = cirbsGRHSs+collectInMode ReportMatchGroup = cirbsMatchGroup+collectInMode ReportEmptyCase = cirbsEmptyCase++-- | Given a 'FormatReportWarningsMode', this function will emit warnings -- for a 'CheckResult'.-formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()-formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do- cov_info <- collect ann+formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()+formatReportWarnings report_mode ctx vars cr@CheckResult { cr_ret = ann } = do+ cov_info <- collectInMode report_mode ann dflags <- getDynFlags- reportWarnings dflags ctx vars cr{cr_ret=cov_info}+ reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info} -- | Issue all the warnings -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).-reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()-reportWarnings dflags (DsMatchContext kind loc) vars+reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()+reportWarnings dflags report_mode (DsMatchContext kind loc) vars CheckResult { cr_ret = CIRB { cirb_inacc = inaccessible_rhss , cirb_red = redundant_rhss , cirb_bangs = redundant_bangs } , cr_uncov = uncovered , cr_approx = precision } = when (flag_i || flag_u || flag_b) $ do- unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered+ unc_examples <- getNFirstUncovered gen_mode vars (maxPatterns + 1) uncovered let exists_r = flag_i && notNull redundant_rhss exists_i = flag_i && notNull inaccessible_rhss exists_u = flag_u && notNull unc_examples@@ -360,16 +381,19 @@ flag_u = exhaustive dflags kind flag_b = redundantBang dflags check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind)+ gen_mode = case report_mode of -- See Note [Case split inhabiting patterns]+ ReportEmptyCase -> CaseSplitTopLevel+ _ -> MinimalCover maxPatterns = maxUncoveredPatterns dflags -getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]-getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)+getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]+getNFirstUncovered mode vars n (MkNablas nablas) = go n (bagToList nablas) where go 0 _ = pure [] go _ [] = pure [] go n (nabla:nablas) = do- front <- generateInhabitingPatterns vars n nabla+ front <- generateInhabitingPatterns mode vars n nabla back <- go (n - length front) nablas pure (front ++ back)
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -29,7 +29,7 @@ addPhiCtsNablas, isInhabited,- generateInhabitingPatterns+ generateInhabitingPatterns, GenerateInhabitingPatternsMode(..) ) where @@ -560,7 +560,7 @@ -- ^ @PhiConCt x K tvs dicts ys@ encodes @K \@tvs dicts ys <- x@, matching @x@ -- against the 'PmAltCon' application @K \@tvs dicts ys@, binding @tvs@, -- @dicts@ and possibly unlifted fields @ys@ in the process.- -- See Note [Strict fields and fields of unlifted type].+ -- See Note [Strict fields and variables of unlifted type]. | PhiNotConCt !Id !PmAltCon -- ^ @PhiNotConCt x K@ encodes "x ≁ K", asserting that @x@ can't be headed -- by @K@.@@ -685,9 +685,13 @@ case bot of IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do- MaybeBot -> do -- We add x ~ ⊥- let vi' = vi{ vi_bot = IsBot }- pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } }+ MaybeBot -> -- We add x ~ ⊥+ -- Case (3) in Note [Strict fields and variables of unlifted type]+ if isUnliftedType (idType x)+ then mzero -- unlifted vars can never be ⊥+ else do+ let vi' = vi{ vi_bot = IsBot }+ pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } -- | Adds the constraint @x ~/ ⊥@ to 'Nabla'. Quite similar to 'addNotConCt', -- but only cares for the ⊥ "constructor".@@ -1102,12 +1106,12 @@ Note [Strict fields and variables of unlifted type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Binders of unlifted type (and strict fields) are unlifted by construction;-they are conceived with an implicit @≁⊥@ constraint to begin with. Hence,-desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned by strict fields,-since the forcing happens *before* pattern matching.-And the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd'-have complex binding semantics (binding type constraints and unlifted fields),-so unliftedness semantics are entirely confined to the oracle.+they are conceived with an implicit (but delayed checked) @≁⊥@ constraint to+begin with. Hence, desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned+by strict fields, since the forcing happens *before* pattern matching. And+the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd' have+complex binding semantics (binding type constraints and unlifted fields), so+unliftedness semantics are entirely confined to the oracle. These are the moving parts: @@ -1138,11 +1142,18 @@ constructor constraint. 3. The preceding points handle unlifted constructor fields, but there also- are regular binders of unlifted type.- Since the oracle as implemented has no notion of scoping and bindings,- we can't know *when* an unlifted variable comes into scope. But that's- not actually a problem, because we can just add the @x ≁ ⊥@ to the- 'emptyVarInfo' when we first encounter it.+ are regular binders of unlifted type. We simply fail in 'addBotCt' for+ any binder of unlifted type.+ It would be enough to check for unliftedness once, when the binder comes+ into scope, but we haven't really a way to track that.++ 4. Why not start an 'emptyVarInfo' of unlifted type with @vi_bot = IsNotBot@?+ Because then we'd need to trigger an inhabitation test, because the var+ might actually be void to begin with. But we can't trigger the test from+ 'emptyVarInfo'.+ Historically, that is what we did and not doing the test led to #20631,+ where 'addNotBotCt' trivially succeeded, because the 'VarInfo' already+ said 'IsNotBot', implying that a prior inhabitation test succeeded. -} -------------------------@@ -1779,36 +1790,51 @@ -- This is important for warnings. Roughly corresponds to G in Figure 6 of the -- LYG paper, with a few tweaks for better warning messages. +-- | See Note [Case split inhabiting patterns]+data GenerateInhabitingPatternsMode+ = CaseSplitTopLevel+ | MinimalCover+ deriving (Eq, Show)++instance Outputable GenerateInhabitingPatternsMode where+ ppr = text . show+ -- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but -- perhaps empty) refinements of @nabla@ that represent inhabited patterns. -- Negative information is only retained if literals are involved or for -- recursive GADTs.-generateInhabitingPatterns :: [Id] -> Int -> Nabla -> DsM [Nabla]+generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla] -- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-generateInhabitingPatterns _ 0 _ = pure []-generateInhabitingPatterns [] _ nabla = pure [nabla]-generateInhabitingPatterns (x:xs) n nabla = do- tracePm "generateInhabitingPatterns" (ppr n <+> ppr (x:xs) $$ ppr nabla)+generateInhabitingPatterns _ _ 0 _ = pure []+generateInhabitingPatterns _ [] _ nabla = pure [nabla]+generateInhabitingPatterns mode (x:xs) n nabla = do+ tracePm "generateInhabitingPatterns" (ppr mode <+> ppr n <+> ppr (x:xs) $$ ppr nabla) let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x case pos of _:_ -> do- -- All solutions must be valid at once. Try to find candidates for their- -- fields. Example:- -- f x@(Just _) True = case x of SomePatSyn _ -> ()- -- after this clause, we want to report that- -- * @f Nothing _@ is uncovered- -- * @f x False@ is uncovered- -- where @x@ will have two possibly compatible solutions, @Just y@ for- -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@- -- and @z@ that is valid at the same time. These constitute arg_vas below.+ -- Example for multiple solutions (must involve a PatSyn):+ -- f x@(Just _) True | SomePatSyn _ <- x = ...+ -- within the RHS, we know that+ -- * @x ~ Just y@ for some @y@+ -- * @x ~ SomePatSyn z@ for some @z@+ -- and both conditions have to hold /at the same time/. Hence we must+ -- find evidence for @y@ and @z@ that is valid at the same time. These+ -- constitute arg_vas below. let arg_vas = concatMap paca_ids pos- generateInhabitingPatterns (arg_vas ++ xs) n nabla+ generateInhabitingPatterns mode (arg_vas ++ xs) n nabla [] -- When there are literals involved, just print negative info -- instead of listing missed constructors | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]- -> generateInhabitingPatterns xs n nabla- [] -> try_instantiate x xs n nabla+ -> generateInhabitingPatterns mode xs n nabla+ -- When some constructors are impossible or when we don't care for a+ -- minimal cover (Note [Case split inhabiting patterns]), do a case split.+ | not (isEmptyPmAltConSet neg) || mode == CaseSplitTopLevel+ -> try_instantiate x xs n nabla+ -- Else don't do a case split on this var, just print a wildcard.+ -- But try splitting for the remaining vars, of course+ | otherwise+ -> generateInhabitingPatterns mode xs n nabla where -- | Tries to instantiate a variable by possibly following the chain of -- newtypes and then instantiating to all ConLikes of the wrapped type's@@ -1832,14 +1858,14 @@ case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of Nothing -> -- No COMPLETE sets ==> inhabited- generateInhabitingPatterns xs n newty_nabla+ generateInhabitingPatterns mode xs n newty_nabla Just clss -> do -- Try each COMPLETE set, pick the one with the smallest number of -- inhabitants nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla) let nablas' = minimumBy (comparing length) nablass' if null nablas' && vi_bot vi /= IsNotBot- then generateInhabitingPatterns xs n newty_nabla -- bot is still possible. Display a wildcard!+ then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard! else pure nablas' -- | Instantiates a chain of newtypes, beginning at @x@.@@ -1860,7 +1886,7 @@ instantiate_cons _ ty xs n nabla _ -- We don't want to expose users to GHC-specific constructors for Int etc. | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True- = generateInhabitingPatterns xs n nabla+ = generateInhabitingPatterns mode xs n nabla instantiate_cons x ty xs n nabla (cl:cls) = do -- The following line is where we call out to the inhabitationTest! mb_nabla <- runMaybeT $ instCon 4 nabla x cl@@ -1875,7 +1901,7 @@ -- NB: We don't prepend arg_vars as we don't have any evidence on -- them and we only want to split once on a data type. They are -- inhabited, otherwise the inhabitation test would have refuted.- Just nabla' -> generateInhabitingPatterns xs n nabla'+ Just nabla' -> generateInhabitingPatterns mode xs n nabla' other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls pure (con_nablas ++ other_cons_nablas) @@ -1901,7 +1927,7 @@ return applicable_cms {- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why can't we define `inhabitationTest` (IT) in terms of `generateInhabitingPatterns` (GIP) as @@ -1921,4 +1947,36 @@ But we still need GIP to produce the Nablas as proxies for uncovered patterns that we display warnings for. It's fine to pay this price once at the end, but IT is called far more often than that.++Note [Case split inhabiting patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have an -XEmptyCase,+```hs+f :: Maybe a -> ()+f x = case x of {}+```+we want to show the different missing patterns {'Just _', 'Nothing'} to the user+instead of an uninformative wildcard pattern '_'.++But when we have a match as part of a function definition, such as+```hs+g :: (Bool, [a]) -> ()+g (_, []) = ()+```+we established in #20642 that we *do not* want to report P1={'(False, (_:_))',+'(True, (_:_))'} when we could just give the singleton set P2={'(_, (_:_))'}!+The latter set M is a "minimal cover" of the space of missing patterns S, in+that++1. The union of M is *exactly* S+2. The size of M is minimal under all such candidates.++In terms of 'g', P2 satisfies both (1) and (2). While P1 satisfies (1), it does+not satisfy (2). The set {'_'} satisfies (2), but it does not satisfy (1) as+it also covers the pattern '(_,[])' which is not part of the space of missing+patterns of 'g', so it would be a bad (too conservative) suggestion.++Note that for -XEmptyCase, we don't want to emit a minimal cover. We arrange+that by passing 'CaseSplitTopLevel' to 'generateInhabitingPatterns'. We detect+the -XEmptyCase case in 'reportWarnings' by looking for 'ReportEmptyCase'. -}
compiler/GHC/HsToCore/Quote.hs view
@@ -92,6 +92,7 @@ import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy)+import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class@@ -1439,7 +1440,7 @@ k_ty <- wrapName kindTyConName repMaybeT k_ty repLTy m -repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)+repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role) repRole (L _ (Just Nominal)) = rep2_nw nominalRName [] repRole (L _ (Just Representational)) = rep2_nw representationalRName [] repRole (L _ (Just Phantom)) = rep2_nw phantomRName []@@ -1534,7 +1535,7 @@ = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs+repE (HsLet _ _ bs _ e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z }@@ -1628,7 +1629,7 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do e1 <- repLE e repGetField e1 f-repE (HsProjection _ xs) = repProjection (map (unLoc . dfoLabel . unLoc) xs)+repE (HsProjection _ xs) = repProjection (fmap (unLoc . dfoLabel . unLoc) xs) repE (XExpr (HsExpanded orig_expr ds_expr)) = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax ; if rebindable_on -- See Note [Quotation and rebindable syntax]@@ -2674,7 +2675,7 @@ arg_tys <- repPrefixConArgs ps rep2 normalCName [unC con', unC arg_tys] InfixCon st1 st2 -> do- verifyLinearConstructors [st1, st2]+ verifyLinearFields [st1, st2] arg1 <- repBangTy (hsScaledThing st1) arg2 <- repBangTy (hsScaledThing st2) rep2 infixCName [unC arg1, unC con', unC arg2]@@ -2704,8 +2705,8 @@ -- denotes a linear field. -- This check is not performed in repRecConArgs, since the GADT record -- syntax currently does not have a way to mark fields as nonlinear.-verifyLinearConstructors :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()-verifyLinearConstructors ps = do+verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()+verifyLinearFields ps = do linear <- lift $ xoptM LangExt.LinearTypes let allGood = all (\st -> case hsMult st of HsUnrestrictedArrow _ -> not linear@@ -2717,7 +2718,7 @@ repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM (Core [M TH.BangType]) repPrefixConArgs ps = do- verifyLinearConstructors ps+ verifyLinearFields ps repListM bangTypeTyConName repBangTy (map hsScaledThing ps) -- Desugar the arguments in a data constructor declared with record syntax.@@ -2936,9 +2937,9 @@ MkC s <- coreStringLit $ unpackFS fs rep2 getFieldEName [exp,s] -repProjection :: [FastString] -> MetaM (Core (M TH.Exp))+repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) repProjection fs = do- MkC xs <- coreList' stringTy <$> mapM (coreStringLit . unpackFS) fs+ MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs rep2 projectionEName [xs] ------------ Lists -------------------@@ -2969,6 +2970,9 @@ coreList' :: Type -- The element type -> [Core a] -> Core [a] coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))++coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a)+coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs) nonEmptyCoreList :: [Core a] -> Core [a] -- The list must be non-empty so we can get the element type
compiler/GHC/Iface/Errors.hs view
@@ -67,7 +67,7 @@ -- ----------------------------------------------------------------------------- -- Error messages -cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") (text "Ambiguous interface for") @@ -75,13 +75,13 @@ :: SDoc -> SDoc -> UnitState- -> HomeUnit+ -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc-cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result+cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result = cannot_find <+> quotes (ppr mod_name) $$ more_info where@@ -94,7 +94,8 @@ text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg- | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)+ | Just pkg <- mb_pkg+ , notHomeUnitId mhome_unit pkg -> not_found_in_package pkg files | null files
compiler/GHC/Iface/Ext/Ast.hs view
@@ -396,9 +396,9 @@ getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan)+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns) => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs)+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs) bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -734,7 +734,7 @@ HsPar _ _ e _ -> computeLType e ExplicitTuple{} -> Nothing HsIf _ _ t f -> computeLType t <|> computeLType f- HsLet _ _ body -> computeLType body+ HsLet _ _ _ _ body -> computeLType body RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsStatic _ e -> computeLType e@@ -818,7 +818,7 @@ , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))- ~ SrcSpan+ ~ SrcAnn NoEpAnns , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA , Data (body (GhcPass p))@@ -1059,8 +1059,8 @@ instance ( ToHie (LocatedA (body (GhcPass p))) , HiePass p , AnnoBody p body- ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where- toHie (L span g) = concatM $ makeNode g span : case g of+ ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where+ toHie (L span g) = concatM $ makeNodeA g span : case g of GRHS _ guards body -> [ toHie $ listScopes (mkLScopeA body) guards , toHie body@@ -1074,7 +1074,7 @@ ] HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble HsRecSel _ fld ->- [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld)+ [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld) ] HsOverLabel {} -> [] HsIPVar _ _ -> []@@ -1131,7 +1131,7 @@ HsMultiIf _ grhss -> [ toHie grhss ]- HsLet _ binds expr ->+ HsLet _ _ binds _ expr -> [ toHie $ RS (mkLScopeA expr) binds , toHie expr ]@@ -1169,7 +1169,7 @@ [ toHie expr ] HsProc _ pat cmdtop ->- [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+ [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat , toHie cmdtop ] HsStatic _ expr ->@@ -1334,23 +1334,23 @@ , toHie expr ] -instance HiePass p => ToHie (RFContext (Located (FieldOcc (GhcPass p)))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of FieldOcc fld _ -> case hiePass @p of- HieRn -> [toHie $ C (RecField c rhs) (L nspan fld)]- HieTc -> [toHie $ C (RecField c rhs) (L nspan fld)]+ HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]+ HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)] -instance HiePass p => ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of Unambiguous fld _ -> case hiePass @p of- HieRn -> [toHie $ C (RecField c rhs) $ L nspan fld]- HieTc -> [toHie $ C (RecField c rhs) $ L nspan fld]+ HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]+ HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld] Ambiguous fld _ -> case hiePass @p of HieRn -> []- HieTc -> [ toHie $ C (RecField c rhs) (L nspan fld) ]+ HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ] instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM@@ -1371,8 +1371,8 @@ toHie (PrefixConGADT args) = toHie args toHie (RecConGADT rec _) = toHie rec -instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where- toHie (L span top) = concatM $ makeNode top span : case top of+instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where+ toHie (L span top) = concatM $ makeNodeA top span : case top of HsCmdTop _ cmd -> [ toHie cmd ]@@ -1409,7 +1409,7 @@ , toHie b , toHie c ]- HsCmdLet _ binds cmd' ->+ HsCmdLet _ _ binds _ cmd' -> [ toHie $ RS (mkLScopeA cmd') binds , toHie cmd' ]@@ -1451,7 +1451,7 @@ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn- deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn+ deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars@@ -1487,8 +1487,8 @@ ] where rhsSpan = sigSpan `combineScopes` injSpan- sigSpan = mkScope $ getLoc sig- injSpan = maybe NoScope (mkScope . getLoc) inj+ sigSpan = mkScope $ getLocA sig+ injSpan = maybe NoScope (mkScope . getLocA) inj instance ToHie (FamilyInfo GhcRn) where toHie (ClosedTypeFamily (Just eqns)) = concatM $@@ -1499,8 +1499,8 @@ go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib toHie _ = pure [] -instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where- toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where+ toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of NoSig _ -> [] KindSig _ k ->@@ -1536,8 +1536,8 @@ patsScope = mkScope (loc pats) rhsScope = mkScope (loc rhs) -instance ToHie (Located (InjectivityAnn GhcRn)) where- toHie (L span ann) = concatM $ makeNode ann span : case ann of+instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where+ toHie (L span ann) = concatM $ makeNodeA ann span : case ann of InjectivityAnn _ lhs rhs -> [ toHie $ C Use lhs , toHie $ map (C Use) rhs@@ -1551,14 +1551,14 @@ , toHie derivs ] -instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where+instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where toHie (L span clauses) = concatM [ locOnly span , toHie clauses ] -instance ToHie (Located (HsDerivingClause GhcRn)) where- toHie (L span cl) = concatM $ makeNode cl span : case cl of+instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where+ toHie (L span cl) = concatM $ makeNodeA cl span : case cl of HsDerivingClause _ strat dct -> [ toHie strat , toHie dct@@ -1569,8 +1569,8 @@ DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] -instance ToHie (Located (DerivStrategy GhcRn)) where- toHie (L span strat) = concatM $ makeNode strat span : case strat of+instance ToHie (LocatedAn NoEpAnns (DerivStrategy GhcRn)) where+ toHie (L span strat) = concatM $ makeNodeA strat span : case strat of StockStrategy _ -> [] AnyclassStrategy _ -> [] NewtypeStrategy _ -> []@@ -1690,7 +1690,7 @@ ] SCCFunSig _ _ name mtxt -> [ toHie $ (C Use) name- , maybe (pure []) (locOnly . getLoc) mtxt+ , maybe (pure []) (locOnly . getLocA) mtxt ] CompleteMatchSig _ _ (L ispan names) typ -> [ locOnly ispan@@ -1872,8 +1872,8 @@ [ toHie f ] -instance ToHie (Located HsIPName) where- toHie (L span e) = makeNode e span+instance ToHie (LocatedAn NoEpAnns HsIPName) where+ toHie (L span e) = makeNodeA e span instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where toHie (L span sp) = concatM $ makeNodeA sp span : case sp of@@ -1890,7 +1890,7 @@ [] XSplice x -> case hiePass @p of #if __GLASGOW_HASKELL__ < 811- HieRn -> noExtCon x+ HieRn -> dataConCantHappen x #endif HieTc -> case x of HsSplicedT _ -> []@@ -1899,7 +1899,7 @@ toHie (L span annot) = concatM $ makeNodeA annot span : case annot of RoleAnnotDecl _ var roles -> [ toHie $ C Use var- , concatMapM (locOnly . getLoc) roles+ , concatMapM (locOnly . getLocA) roles ] instance ToHie (LocatedA (InstDecl GhcRn)) where@@ -2022,19 +2022,19 @@ instance ToHie (LocatedA (RuleDecl GhcRn)) where toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM [ makeNodeA r span- , locOnly $ getLoc rname+ , locOnly $ getLocA rname , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs , toHie $ map (RS $ mkScope (locA span)) bndrs , toHie exprA , toHie exprB ] where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc- bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+ bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs) exprA_sc = mkLScopeA exprA exprB_sc = mkLScopeA exprB -instance ToHie (RScoped (Located (RuleBndr GhcRn))) where- toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where+ toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of RuleBndr _ var -> [ toHie $ C (ValBind RegularBind sc Nothing) var ]
compiler/GHC/Iface/Load.hs view
@@ -109,7 +109,7 @@ import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.Finder-import GHC.Unit.Env ( ue_hpt )+import GHC.Unit.Env import GHC.Data.Maybe @@ -322,8 +322,8 @@ let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags let units = hsc_units hsc_env- let home_unit = hsc_home_unit hsc_env- res <- liftIO $ findImportedModule fc fopts units home_unit mod maybe_pkg+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ res <- liftIO $ findImportedModule fc fopts units mhome_unit mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good@@ -456,7 +456,7 @@ -- Check whether we have the interface already ; hsc_env <- getTopEnv- ; let home_unit = hsc_home_unit hsc_env+ ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded@@ -466,7 +466,7 @@ _ -> do { -- READ THE MODULE IN- ; read_result <- case (wantHiBootFile home_unit eps mod from) of+ ; read_result <- case wantHiBootFile mhome_unit eps mod from of Failed err -> return (Failed err) Succeeded hi_boot_file -> do hsc_env <- getTopEnv@@ -540,7 +540,7 @@ ; warnPprTrace bad_boot (ppr mod) $ updateEps_ $ \ eps ->- if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface+ if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file]@@ -680,12 +680,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 :: HomeUnit -> ModIface -> Bool-is_external_sig home_unit iface =+is_external_sig :: Maybe HomeUnit -> ModIface -> Bool+is_external_sig mhome_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package- not (isHomeModule home_unit (mi_module iface))+ notHomeModuleMaybe mhome_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@@ -711,21 +711,23 @@ massert (not (isHoleModule mod0)) let name_cache = hsc_NC hsc_env let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env- let find_iface m = findAndReadIface logger name_cache fc hooks units home_unit dflags doc_str+ let find_iface m = findAndReadIface logger name_cache fc hooks units mhome_unit dflags doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of- (imod, Just indef) | isHomeUnitIndefinite home_unit ->- find_iface imod >>= \case- Succeeded (iface0, path) ->- rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case- Right x -> return (Succeeded (x, path))- Left errs -> throwErrors (GhcTcRnMessage <$> errs)- Failed err -> return (Failed err)+ (imod, Just indef)+ | Just home_unit <- mhome_unit+ , isHomeUnitIndefinite home_unit ->+ find_iface imod >>= \case+ Succeeded (iface0, path) ->+ rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case+ Right x -> return (Succeeded (x, path))+ Left errs -> throwErrors (GhcTcRnMessage <$> errs)+ Failed err -> return (Failed err) (mod, _) -> find_iface mod -- | Compute the signatures which must be compiled in order to@@ -765,12 +767,12 @@ hsc_env <- getTopEnv let nc = hsc_NC hsc_env let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env- mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot case mb_iface of@@ -782,13 +784,13 @@ return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom+wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile home_unit eps mod from+wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot- | usr_boot == IsBoot && notHomeModule home_unit mod+ | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod -> Failed (badSourceImport mod) | otherwise -> Succeeded usr_boot @@ -796,7 +798,7 @@ -> Succeeded NotBoot ImportBySystem- | notHomeModule home_unit mod+ | notHomeModuleMaybe mhome_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@@ -867,7 +869,7 @@ -> FinderCache -> Hooks -> UnitState- -> HomeUnit+ -> Maybe HomeUnit -> DynFlags -> SDoc -- ^ Reason for loading the iface (used for tracing) -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for@@ -876,7 +878,7 @@ -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file -> IO (MaybeErr SDoc (ModIface, FilePath))-findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str mod wanted_mod hi_boot_file = do+findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags trace_if logger (sep [hsep [text "Reading",@@ -899,14 +901,16 @@ else do let fopts = initFinderOpts dflags -- Look for the file- mb_found <- liftIO (findExactModule fc fopts unit_state home_unit mod)+ mb_found <- liftIO (findExactModule fc fopts unit_state mhome_unit mod) case mb_found of InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do -- See Note [Home module load error]- if isHomeInstalledModule home_unit mod &&- not (isOneShot (ghcMode dflags))- then return (Failed (homeModError mod loc))- else do+ case mhome_unit of+ Just home_unit+ | isHomeInstalledModule home_unit mod+ , not (isOneShot (ghcMode dflags))+ -> return (Failed (homeModError mod loc))+ _ -> do r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of Failed _@@ -923,7 +927,7 @@ trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state- home_unit+ mhome_unit profile (Iface_Errors.mayShowLocations dflags) (moduleName mod)
compiler/GHC/Iface/Recomp.hs view
@@ -54,6 +54,7 @@ import GHC.Types.Unique.Set import GHC.Types.Fixity.Env +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State@@ -526,8 +527,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do- res_normal <- classify_import (findImportedModule fc fopts units home_unit) (ms_textual_imps summary ++ ms_srcimps summary)- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units home_unit mod) (ms_plugin_imps summary)+ res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary)+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp Right es -> do@@ -548,7 +549,7 @@ fopts = initFinderOpts dflags logger = hsc_logger hsc_env fc = hsc_FC hsc_env- home_unit = hsc_home_unit hsc_env+ mhome_unit = ue_home_unit (hsc_unit_env hsc_env) units = hsc_units hsc_env prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))@@ -560,13 +561,14 @@ -- GHC.Prim is very special and doesn't appear in ms_textual_imps but -- ghc-prim will appear in the package dependencies still. In order to not confuse -- the recompilation logic we need to not forget we imported GHC.Prim.- fake_ghc_prim_import = if homeUnitId home_unit == primUnitId- then Left (mkModuleName "GHC.Prim")- else Right ("GHC.Prim", primUnitId)+ fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId+ then Right ("GHC.Prim", primUnitId)+ else Left (mkModuleName "GHC.Prim") classify _ (Found _ mod)- | isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod))+ | Just home_unit <- mhome_unit+ , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason)
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -188,7 +188,6 @@ go (reverse fps' ++ fps) (bnd' : bs) xs' dflags = hsc_dflags hsc_env- platform = targetPlatform dflags -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. --@@ -230,8 +229,8 @@ staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName return (fp, mkConApp staticPtrDataCon [ Type t- , mkWord64LitWordRep platform w0- , mkWord64LitWordRep platform w1+ , mkWord64LitWord64 w0+ , mkWord64LitWord64 w1 , info , e ]) @@ -241,13 +240,6 @@ , moduleNameString $ moduleName this_mod , show n ]-- -- Choose either 'Word64#' or 'Word#' to represent the arguments of the- -- 'Fingerprint' data constructor.- mkWord64LitWordRep platform =- case platformWordSize platform of- PW4 -> mkWord64LitWord64- PW8 -> mkWordLit platform . toInteger lookupIdHscEnv :: Name -> IO Id lookupIdHscEnv n = lookupType hsc_env n >>=
compiler/GHC/IfaceToCore.hs view
@@ -65,6 +65,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails@@ -160,7 +161,7 @@ internal TyCons to MATCH the ones that we just constructed during typechecking: the knot is thus tied through if_rec_types. - 2) retypecheckLoop in GHC.Driver.Make: We are retypechecking a+ 2) rehydrate in GHC.Driver.Make: We are rehydrating a mutually recursive cluster of hi files, in order to ensure that all of the references refer to each other correctly. In this case, the knot is tied through the HPT passed in,@@ -552,12 +553,12 @@ { hsc_env <- getTopEnv ; let nc = hsc_NC hsc_env ; let fc = hsc_FC hsc_env- ; let home_unit = hsc_home_unit hsc_env+ ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; let units = hsc_units hsc_env ; let dflags = hsc_dflags hsc_env ; let logger = hsc_logger hsc_env ; let hooks = hsc_hooks hsc_env- ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags+ ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags need (fst (getModuleInstantiation mod)) mod IsBoot -- Hi-boot file @@ -1766,7 +1767,7 @@ core_expr' <- tcIfaceExpr expr -- Check for type consistency in the unfolding- -- See Note [Linting Unfoldings from Interfaces]+ -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do in_scope <- get_in_scope@@ -1859,6 +1860,7 @@ -- * Note [DFun knot-tying] -- * Note [hsc_type_env_var hack] -- * Note [Knot-tying fallback on boot]+-- * Note [Hydrating Modules] -- -- There is also a wiki page on the subject, see: --
compiler/GHC/Linker/Loader.hs view
@@ -723,7 +723,6 @@ let pkg = moduleUnit mod deps = mi_deps iface- home_unit = hsc_home_unit hsc_env pkg_deps = dep_direct_pkgs deps (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $@@ -735,10 +734,11 @@ acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) --- if not (isHomeUnit home_unit pkg)- then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))- else follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods)- acc_mods' acc_pkgs'+ case ue_home_unit (hsc_unit_env hsc_env) of+ Just home_unit+ | isHomeUnit home_unit pkg+ -> follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) acc_mods' acc_pkgs'+ _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) where msg = text "need to link module" <+> ppr mod <+> text "due to use of Template Haskell"@@ -765,12 +765,14 @@ | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation...- let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags- mb_stuff <- findHomeModule fc fopts home_unit mod_name- case mb_stuff of+ case ue_home_unit (hsc_unit_env hsc_env) of+ Nothing -> no_obj mod_name+ Just home_unit -> do+ let fc = hsc_FC hsc_env+ let dflags = hsc_dflags hsc_env+ let fopts = initFinderOpts dflags+ mb_stuff <- findHomeModule fc fopts home_unit mod_name+ case mb_stuff of Found loc mod -> found loc mod _ -> no_obj mod_name where
compiler/GHC/Linker/Static.hs view
@@ -202,7 +202,7 @@ [] -- See Note [No PIE when linking]- ++ picCCOpts dflags+ ++ pieCCLDOpts dflags -- Permit the linker to auto link _symbol to _imp_symbol. -- This lets us link against DLLs without needing an "import library".
compiler/GHC/Rename/Bind.hs view
@@ -43,7 +43,9 @@ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), mapFvRn- , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds+ , checkDupRdrNames, checkDupRdrNamesN+ , warnUnusedLocalBinds+ , warnForallIdentifier , checkUnusedRecordWildcard , checkDupAndShadowedNames, bindLocalNamesFV , addNoNestedForallsContextsErr, checkInferredVars )@@ -981,6 +983,7 @@ = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig)+ ; mapM_ warnForallIdentifier vs ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }@@ -1181,8 +1184,8 @@ , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA- , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan- , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+ , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns , Outputable (body GhcPs) ) @@ -1254,7 +1257,7 @@ -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> LGRHS GhcPs (LocatedA (body GhcPs)) -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)-rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)+rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody) rnGRHS' :: HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
compiler/GHC/Rename/Expr.hs view
@@ -74,6 +74,7 @@ import qualified GHC.LanguageExtensions as LangExt import Data.List (unzip4, minimumBy)+import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord@@ -207,16 +208,10 @@ ; return (HsVar noExtField (L (la2na l) name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v =- if isUnqual v- then -- Treat this as a "hole"- -- Do not fail right now; instead, return HsUnboundVar- -- and let the type checker report the error- return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)-- else -- Fail immediately (qualified name)- do { n <- reportUnboundName v- ; return (HsVar noExtField (noLocA n), emptyFVs) }+rnUnboundVar v = do+ deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables+ unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())+ return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags@@ -337,7 +332,7 @@ ; let fs' = fmap rnDotFieldOcc fs ; return ( mkExpandedExpr (HsProjection noExtField fs')- (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))+ (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs')) , unitFV circ `plusFV` fv_getField) } ------------------------------------------@@ -387,10 +382,10 @@ ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ binds expr)+rnExpr (HsLet _ tkLet binds tkIn expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr- ; return (HsLet noExtField binds' expr', fvExpr) }+ ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) } rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts1, _), fvs1) <-@@ -721,7 +716,7 @@ ************************************************************************ -} -rnDotFieldOcc :: Located (DotFieldOcc GhcPs) -> Located (DotFieldOcc GhcRn)+rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn) rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label) rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn@@ -743,7 +738,7 @@ ; return (arg':args', fvArg `plusFV` fvArgs) } rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)-rnCmdTop = wrapLocFstM rnCmdTop'+rnCmdTop = wrapLocFstMA rnCmdTop' where rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars) rnCmdTop' (HsCmdTop _ cmd)@@ -828,10 +823,10 @@ ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ binds cmd)+rnCmd (HsCmdLet _ tkLet binds tkIn cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd- ; return (HsCmdLet noExtField binds' cmd', fvExpr) }+ ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) } rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <-@@ -859,7 +854,7 @@ methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c+methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match@@ -888,7 +883,7 @@ ------------------------------------------------- -methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds+methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs ---------------------------------------------------@@ -2195,7 +2190,7 @@ SplicePat{} -> True XPat ext -> case ghcPass @p of #if __GLASGOW_HASKELL__ < 811- GhcPs -> noExtCon ext+ GhcPs -> dataConCantHappen ext #endif GhcRn | HsPatExpanded _ p <- ext@@ -2621,35 +2616,34 @@ -- mkGetField arg field calcuates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z-mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field) -- mkSetField a field b calculates a set_field @field expression. -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").-mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn+mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ field) b = genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b -mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]+mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] mkGet get_field l@(r : _) (L _ field) = wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l mkGet _ [] _ = panic "mkGet : The impossible has happened!" -mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn+mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" -- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"-mkProjection :: Name -> Name -> [Located FieldLabelString] -> HsExpr GhcRn-mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields+mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn+mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields where- f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+ f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] - proj :: Located FieldLabelString -> HsExpr GhcRn+ proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f-mkProjection _ _ [] = panic "mkProjection: The impossible happened" -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1.
compiler/GHC/Rename/HsType.hs view
@@ -51,7 +51,8 @@ import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext , mapFvRn, pprHsDocContext, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN- , checkShadowedRdrNames )+ , checkShadowedRdrNames+ , warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )@@ -1281,7 +1282,8 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))- = do { let new_names = map (fmap (lookupField fl_env)) names+ = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names+ ; let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc) , fvs) }@@ -1469,7 +1471,7 @@ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1)- [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))])+ [a11, L loc (HsCmdTop [] (L (l2l loc) new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2
compiler/GHC/Rename/Module.hs view
@@ -31,6 +31,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns+ , warnForallIdentifier , newLocalBndrsRn , withHsDocContext, noNestedForallsContextsErr , addNoNestedForallsContextsErr, checkInferredVars )@@ -351,6 +352,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv+ ; warnForallIdentifier name ; name' <- lookupLocatedTopBndrRnN name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty @@ -1220,6 +1222,7 @@ , rd_lhs = lhs , rd_rhs = rhs }) = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+ ; mapM_ warnForallIdentifier rdr_names_w_loc ; checkDupRdrNamesN rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc@@ -1924,7 +1927,9 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = context, dd_cons = condecls , dd_kindSig = m_sig, dd_derivs = derivs })- = do { checkTc (h98_style || null (fromMaybeContext context))+ = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with+ -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon.+ checkTc (h98_style || null (fromMaybeContext context)) (badGadtStupidTheta doc) ; (m_sig', sig_fvs) <- case m_sig of@@ -1996,7 +2001,7 @@ , deriv_clause_tys = dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct- ; warnNoDerivStrat dcs' loc+ ; warnNoDerivStrat dcs' (locA loc) ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = dct' })@@ -2034,7 +2039,7 @@ = case mds of Nothing -> boring_case Nothing Just (L loc ds) ->- setSrcSpan loc $ do+ setSrcSpanA loc $ do (ds', thing, fvs) <- rn_deriv_strat ds pure (Just (L loc ds'), thing, fvs) where@@ -2117,7 +2122,7 @@ ; ((tyvars', res_sig', injectivity'), fv1) <- bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> do { let rn_sig = rnFamResultSig doc- ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+ ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }@@ -2225,7 +2230,9 @@ -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo- ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }+ -- Note: srcSpan is unchanged, but typechecker gets+ -- confused, l2l call makes it happy+ ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv@@ -2246,7 +2253,7 @@ ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid- ; addErrAt srcSpan $ TcRnUnknownMessage $ mkPlainError noHints $+ ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $ ( hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:"@@ -2263,7 +2270,7 @@ -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =- setSrcSpan srcSpan $ do+ setSrcSpanA srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo@@ -2295,7 +2302,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args- , con_doc = mb_doc, con_forall = forall })+ , con_doc = mb_doc, con_forall = forall_ }) = do { _ <- addLocMA checkConName name ; new_name <- lookupLocatedTopConstructorRnN name @@ -2322,7 +2329,7 @@ , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc- , con_forall = forall }, -- Remove when #18311 is fixed+ , con_forall = forall_ }, -- Remove when #18311 is fixed all_fvs) }} rnConDecl (ConDeclGADT { con_names = names@@ -2444,7 +2451,7 @@ , psb_args = RecCon as }))) <- bind = do bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)- let field_occs = map ((\ f -> L (getLocA (foLabel f)) f) . recordPatSynField) as+ let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
compiler/GHC/Rename/Names.hs view
@@ -1028,7 +1028,7 @@ newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))- = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field+ = do { selName <- newTopSrcBinder $ L (l2l loc) $ field ; return $ FieldLabel { flLabel = fieldLabelString , flHasDuplicateRecordFields = dup_fields_ok , flHasFieldSelector = has_sel
compiler/GHC/Rename/Pat.hs view
@@ -53,7 +53,7 @@ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames- , warnUnusedMatches, newLocalBndrRn+ , warnUnusedMatches, warnForallIdentifier , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit )@@ -232,14 +232,16 @@ newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside ->- do { name <- newLocalBndrRn rdr_name+ do { warnForallIdentifier rdr_name+ ; name <- newLocalBndrRn rdr_name ; (res, fvs) <- bindLocalNames [name] (thing_inside name) ; when report_unused $ warnUnusedMatches [name] fvs ; return (res, name `delFV` fvs) }) newPatName (LetMk is_top fix_env) rdr_name = CpsRn (\ thing_inside ->- do { name <- case is_top of+ do { warnForallIdentifier rdr_name+ ; name <- case is_top of NotTopLevel -> newLocalBndrRn rdr_name TopLevel -> newTopSrcBinder rdr_name ; bindLocalNames [name] $@@ -516,7 +518,7 @@ = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) ; if ovlStr then rnPatAndThen mk- (mkNPat (noLoc (mkHsIsString src s))+ (mkNPat (noLocA (mkHsIsString src s)) Nothing noAnn) else normal_lit } | otherwise = normal_lit@@ -778,12 +780,12 @@ (L loc (FieldOcc _ (L ll lbl))) , hfbRHS = arg , hfbPun = pun }))- = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl+ = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun- then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))+ then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)- ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }+ ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) } else return arg ; return (L l (HsFieldBind { hfbAnn = noAnn@@ -833,7 +835,7 @@ ; return [ L (noAnnSrcSpan loc) (HsFieldBind { hfbAnn = noAnn , hfbLHS- = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))+ = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) , hfbRHS = L locn (mk_arg loc arg_rdr) , hfbPun = False }) | fl <- dot_dot_fields@@ -881,23 +883,23 @@ , hfbRHS = arg , hfbPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f- ; mb_sel <- setSrcSpan loc $+ ; mb_sel <- setSrcSpanA loc $ -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head lookupRecFieldOcc_update dup_fields_ok lbl ; arg' <- if pun- then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))+ then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)- ; return (L (noAnnSrcSpan loc) (HsVar noExtField- (L (noAnnSrcSpan loc) arg_rdr))) }+ ; return (L (l2l loc) (HsVar noExtField+ (L (l2l loc) arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' ; let (lbl', fvs') = case mb_sel of UnambiguousGre gname -> let sel_name = greNameMangledName gname- in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)- AmbiguousFields -> (Ambiguous noExtField (L (noAnnSrcSpan loc) lbl), fvs)+ in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)+ AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs) ; return (L l (HsFieldBind { hfbAnn = noAnn , hfbLHS = L loc lbl'
compiler/GHC/Rename/Utils.hs view
@@ -15,6 +15,7 @@ addFvRn, mapFvRn, mapMaybeFvRn, warnUnusedMatches, warnUnusedTypePatterns, warnUnusedTopBinds, warnUnusedLocalBinds,+ warnForallIdentifier, checkUnusedRecordWildcard, mkFieldEnv, unknownSubordinateErr, badQualBndrErr, typeAppErr,@@ -425,6 +426,13 @@ check_unused flag bound_names used_names = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) bound_names))++warnForallIdentifier :: LocatedN RdrName -> RnM ()+warnForallIdentifier (L l rdr_name@(Unqual occ))+ | isKw (fsLit "forall") || isKw (fsLit "∀")+ = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)+ where isKw = (occNameFS occ ==)+warnForallIdentifier _ = return () ------------------------- -- Helpers
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -1045,6 +1045,9 @@ world <- newVar liftedTypeKind addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) return [(tv', contents)]+ APClosure {payload=pLoad} -> do -- #19559 (incr)+ mapM_ (go my_ty) pLoad+ return [] ConstrClosure{ptrArgs=pArgs} -> do Right dcname <- liftIO $ constrClosToName hsc_env clos traceTR (text "Constr1" <+> ppr dcname)
compiler/GHC/Runtime/Loader.hs view
@@ -54,6 +54,7 @@ import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface+import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger@@ -133,14 +134,18 @@ Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name- ; mb_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon)- ; case mb_plugin of- Nothing ->- throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep+ ; eith_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon)+ ; case eith_plugin of+ Left actual_type ->+ throwGhcExceptionIO (CmdLineError $+ showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))+ alwaysQualify $ hsep [ text "The value", ppr name+ , text "with type", ppr actual_type , text "did not have the type"- , ppr pluginTyConName, text "as required"])- Just plugin -> return (plugin, mod_iface) } } }+ , text "GHC.Plugins.Plugin"+ , text "as required"])+ Right plugin -> return (plugin, mod_iface) } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used@@ -178,29 +183,29 @@ -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! ----- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:+-- If the value found was not of the correct type, returns @Left <actual_type>@. Any other condition results in an exception: -- -- * If we could not load the names module -- * If the thing being loaded is not a value -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe a)+getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Either Type a) getValueSafely hsc_env mnwib val_name expected_type = do- mb_hval <- case getValueSafelyHook hooks of+ eith_hval <- case getValueSafelyHook hooks of Nothing -> getHValueSafely interp hsc_env mnwib val_name expected_type Just h -> h hsc_env mnwib val_name expected_type- case mb_hval of- Nothing -> return Nothing- Just hval -> do+ case eith_hval of+ Left actual_type -> return (Left actual_type)+ Right hval -> do value <- lessUnsafeCoerce logger "getValueSafely" hval- return (Just value)+ return (Right value) where interp = hscInterp hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe HValue)+getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Either Type HValue) getHValueSafely interp hsc_env mnwib val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment@@ -221,8 +226,8 @@ hval <- do v <- loadName interp hsc_env mnwib val_name wormhole interp v- return (Just hval)- else return Nothing+ return (Right hval)+ else return (Left (idType id)) Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing where dflags = hsc_dflags hsc_env @@ -258,13 +263,14 @@ lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags- let fc = hsc_FC hsc_env- let units = hsc_units hsc_env- let home_unit = hsc_home_unit hsc_env+ let dflags = hsc_dflags hsc_env+ let fopts = initFinderOpts dflags+ let fc = hsc_FC hsc_env+ let unit_env = hsc_unit_env hsc_env+ let unit_state = ue_units unit_env+ let mhome_unit = ue_home_unit unit_env -- First find the unit the module resides in by searching exposed units and home modules- found_module <- findPluginModule fc fopts units home_unit mod_name+ found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module
compiler/GHC/Settings/IO.hs view
@@ -35,12 +35,6 @@ => String -- ^ TopDir path -> ExceptT SettingsError m Settings initSettings top_dir = do- -- see Note [topdir: How GHC finds its files]- -- NB: top_dir is assumed to be in standard Unix- -- format, '/' separated- mtool_dir <- liftIO $ findToolDir top_dir- -- see Note [tooldir: How GHC finds mingw on Windows]- let installed :: FilePath -> FilePath installed file = top_dir </> file libexec :: FilePath -> FilePath@@ -58,24 +52,31 @@ Nothing -> throwE $ SettingsError_BadData $ "Can't parse " ++ show settingsFile let mySettings = Map.fromList settingsList+ getBooleanSetting :: String -> ExceptT SettingsError m Bool+ getBooleanSetting key = either pgmError pure $+ getRawBooleanSetting settingsFile mySettings key++ -- On Windows, by mingw is often distributed with GHC,+ -- so we look in TopDir/../mingw/bin,+ -- as well as TopDir/../../mingw/bin for hadrian.+ -- But we might be disabled, in which we we don't do that.+ useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"++ -- see Note [topdir: How GHC finds its files]+ -- NB: top_dir is assumed to be in standard Unix+ -- format, '/' separated+ mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir+ -- see Note [tooldir: How GHC finds mingw on Windows]+ -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $ getRawFilePathSetting top_dir settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String- getToolSetting key = expandToolDir mtool_dir <$> getSetting key- getBooleanSetting :: String -> ExceptT SettingsError m Bool- getBooleanSetting key = either pgmError pure $- getRawBooleanSetting settingsFile mySettings key+ getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key targetPlatformString <- getSetting "target platform string" myExtraGccViaCFlags <- getSetting "GCC extra via C opts"- -- On Windows, mingw is distributed with GHC,- -- so we look in TopDir/../mingw/bin,- -- as well as TopDir/../../mingw/bin for hadrian.- -- It would perhaps be nice to be able to override this- -- with the settings file, but it would be a little fiddly- -- to make that possible, so for now you can't. cc_prog <- getToolSetting "C compiler command" cc_args_str <- getSetting "C compiler flags" cxx_args_str <- getSetting "C++ compiler flags"@@ -162,6 +163,7 @@ , toolSettings_ldSupportsFilelist = ldSupportsFilelist , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie+ , toolSettings_useInplaceMinGW = useInplaceMinGW , toolSettings_pgm_L = unlit_path , toolSettings_pgm_P = (cpp_prog, cpp_args)
− compiler/GHC/Stg/DepAnal.hs
@@ -1,146 +0,0 @@---module GHC.Stg.DepAnal (depSortStgPgm) where--import GHC.Prelude--import GHC.Stg.Syntax-import GHC.Types.Id-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)--import Data.Graph (SCC (..))-import Data.Bifunctor (first)------------------------------------------------------------------------------------- * Dependency analysis---- | Set of bound variables-type BVs = VarSet---- | Set of free variables-type FVs = VarSet---- | Dependency analysis on STG terms.------ Dependencies of a binding are just free variables in the binding. This--- includes imported ids and ids in the current module. For recursive groups we--- just return one set of free variables which is just the union of dependencies--- of all bindings in the group.------ Implementation: pass bound variables (BVs) to recursive calls, get free--- variables (FVs) back. We ignore imported FVs as they do not change the--- ordering but it improves performance.----annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)]-annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)- where- top_bind :: StgTopBinding -> FVs- top_bind StgTopStringLit{} =- emptyVarSet-- top_bind (StgTopLifted bs) =- binding emptyVarSet bs-- binding :: BVs -> StgBinding -> FVs- binding bounds (StgNonRec _ r) =- rhs bounds r- binding bounds (StgRec bndrs) =- unionVarSets $- map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs-- bind_non_rec :: BVs -> (Id, StgRhs) -> FVs- bind_non_rec bounds (_, r) =- rhs bounds r-- rhs :: BVs -> StgRhs -> FVs- rhs bounds (StgRhsClosure _ _ _ as e) =- expr (extendVarSetList bounds as) e-- rhs bounds (StgRhsCon _ _ _ _ as) =- args bounds as-- var :: BVs -> Var -> FVs- var bounds v- | not (elemVarSet v bounds)- , nameIsLocalOrFrom this_mod (idName v)- = unitVarSet v- | otherwise- = emptyVarSet-- arg :: BVs -> StgArg -> FVs- arg bounds (StgVarArg v) = var bounds v- arg _ StgLitArg{} = emptyVarSet-- args :: BVs -> [StgArg] -> FVs- args bounds as = unionVarSets (map (arg bounds) as)-- expr :: BVs -> StgExpr -> FVs- expr bounds (StgApp f as) =- var bounds f `unionVarSet` args bounds as-- expr _ StgLit{} =- emptyVarSet-- expr bounds (StgConApp _ _ as _) =- args bounds as- expr bounds (StgOpApp _ as _) =- args bounds as- expr bounds (StgCase scrut scrut_bndr _ as) =- expr bounds scrut `unionVarSet`- alts (extendVarSet bounds scrut_bndr) as- expr bounds (StgLet _ bs e) =- binding bounds bs `unionVarSet`- expr (extendVarSetList bounds (bindersOf bs)) e- expr bounds (StgLetNoEscape _ bs e) =- binding bounds bs `unionVarSet`- expr (extendVarSetList bounds (bindersOf bs)) e-- expr bounds (StgTick _ e) =- expr bounds e-- alts :: BVs -> [StgAlt] -> FVs- alts bounds = unionVarSets . map (alt bounds)-- alt :: BVs -> StgAlt -> FVs- alt bounds (_, bndrs, e) =- expr (extendVarSetList bounds bndrs) e------------------------------------------------------------------------------------- * Dependency sorting---- | Dependency sort a STG program so that dependencies come before uses.-depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding]-depSortStgPgm this_mod =- {-# SCC "STG.depSort" #-}- map fst . depSort . annTopBindingsDeps this_mod---- | Sort free-variable-annotated STG bindings so that dependencies come before--- uses.-depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)]-depSort = concatMap get_binds . depAnal defs uses- where- uses, defs :: (StgTopBinding, FVs) -> [Name]-- -- TODO (osa): I'm unhappy about two things in this code:- --- -- * Why do we need Name instead of Id for uses and dependencies?- -- * Why do we need a [Name] instead of `Set Name`? Surely depAnal- -- doesn't need any ordering.-- uses (StgTopStringLit{}, _) = []- uses (StgTopLifted{}, fvs) = map idName (nonDetEltsUniqSet fvs)-- defs (bind, _) = map idName (bindersOfTop bind)-- get_binds (AcyclicSCC bind) =- [bind]- get_binds (CyclicSCC binds) =- pprPanic "depSortStgBinds"- (text "Found cyclic SCC:"- $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))
compiler/GHC/Stg/FVs.hs view
@@ -40,129 +40,236 @@ variables are global. -} module GHC.Stg.FVs (- annTopBindingsFreeVars,+ depSortWithAnnotStgPgm, annBindingFreeVars ) where -import GHC.Prelude+import GHC.Prelude hiding (mod) import GHC.Stg.Syntax import GHC.Types.Id-import GHC.Types.Var.Set+import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Tickish ( GenTickish(Breakpoint) )+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Types.Var.Set+import GHC.Unit.Module (Module) import GHC.Utils.Misc -import Data.Maybe ( mapMaybe )+import Data.Graph (SCC (..))+import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq ) -newtype Env+{- Note [Why do we need dependency analysis?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The program needs to be in dependency order for the SRT algorithm to+work (see CmmBuildInfoTables, which also includes a detailed+description of the algorithm).++But isn't it in correct dependency order already? No:++* The simplifier does not guarantee to produce programs in dependency+ order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal).+ This could be solved by a final run of the occurrence analyser, but+ that's more work++* We also don't guarantee that StgLiftLams will preserve the order or+ only create minimal recursive groups.+-}++--------------------------------------------------------------------------------+-- | Dependency sort a STG program, and annotate it with free variables+-- The returned bindings:+-- * Are in dependency order+-- * Each StgRhsClosure is correctly annotated (in its extension field)+-- with the free variables needed in the closure+-- * Each StgCase is correctly annotated (in its extension field) with+-- the variables that must be saved across the case+depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]+depSortWithAnnotStgPgm this_mod binds+ = {-# SCC "STG.depSortWithAnnotStgPgm" #-}+ lit_binds ++ map from_scc sccs+ where+ lit_binds :: [CgStgTopBinding]+ pairs :: [(Id, StgRhs)]+ (lit_binds, pairs) = flattenTopStgBindings binds++ nodes :: [Node Name (Id, CgStgRhs)]+ nodes = map (annotateTopPair env0) pairs+ env0 = Env { locals = emptyVarSet, mod = this_mod }++ -- Do strongly connected component analysis. Why?+ -- See Note [Why do we need dependency analysis?]+ sccs :: [SCC (Id,CgStgRhs)]+ sccs = stronglyConnCompFromEdgedVerticesUniq nodes++ from_scc (CyclicSCC pairs) = StgTopLifted (StgRec pairs)+ from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs)+++flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)])+flattenTopStgBindings binds+ = go [] [] binds+ where+ go lits pairs [] = (lits, pairs)+ go lits pairs (bind:binds)+ = case bind of+ StgTopStringLit bndr rhs -> go (StgTopStringLit bndr rhs:lits) pairs binds+ StgTopLifted stg_bind -> go lits (flatten_one stg_bind ++ pairs) binds++ flatten_one (StgNonRec b r) = [(b,r)]+ flatten_one (StgRec pairs) = pairs++annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)+annotateTopPair env0 (bndr, rhs)+ = DigraphNode { node_key = idName bndr+ , node_payload = (bndr, rhs')+ , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) }+ where+ (rhs', top_fvs, _) = rhsFVs env0 rhs++--------------------------------------------------------------------------------+-- * Non-global free variable analysis++data Env = Env- { locals :: IdSet+ { -- | Set of locally-bound, not-top-level binders in scope.+ -- That is, variables bound by a let (but not let-no-escape), a lambda+ -- (in a StgRhsClsoure), a case binder, or a case alternative. These+ -- are the variables that must be captured in a function closure, if they+ -- are free in the RHS. Example+ -- f = \x. let g = \y. x+1+ -- let h = \z. g z + 1+ -- in h x+ -- In the body of h we have locals = {x, g, z}. Note that f is top level+ -- and does not appear in locals.+ locals :: IdSet+ , mod :: Module } -emptyEnv :: Env-emptyEnv = Env emptyVarSet- addLocals :: [Id] -> Env -> Env addLocals bndrs env = env { locals = extendVarSetList (locals env) bndrs } --- | Annotates a top-level STG binding group with its free variables.-annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]-annTopBindingsFreeVars = map go- where- go (StgTopStringLit id bs) = StgTopStringLit id bs- go (StgTopLifted bind)- = StgTopLifted (annBindingFreeVars bind)---- | Annotates an STG binding with its free variables.-annBindingFreeVars :: StgBinding -> CgStgBinding-annBindingFreeVars = fst . binding emptyEnv emptyDVarSet+--------------------------------------------------------------------------------+-- | TopFVs: set of variables that are:+-- (a) bound at the top level of this module, and+-- (b) appear free in the expression+-- It is a /non-deterministic/ set because we use it only to perform dependency+-- analysis on the top-level bindings.+type TopFVs = IdSet -boundIds :: StgBinding -> [Id]-boundIds (StgNonRec b _) = [b]-boundIds (StgRec pairs) = map fst pairs+-- | LocalFVs: set of variable that are:+-- (a) bound locally (by a lambda, non-top-level let, or case); that is,+-- it appears in the 'locals' field of 'Env'+-- (b) appear free in the expression+-- It is a /deterministic/ set because it is used to annotate closures with+-- their free variables, and we want closure layout to be deterministic.+--+-- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env+type LocalFVs = DIdSet --- Note [Tracking local binders]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- 'locals' contains non-toplevel, non-imported binders.--- We maintain the set in 'expr', 'alt' and 'rhs', which are the only--- places where new local binders are introduced.--- Why do it there rather than in 'binding'? Two reasons:+-- | Dependency analysis on STG terms. ----- 1. We call 'binding' from 'annTopBindingsFreeVars', which would--- add top-level bindings to the 'locals' set.--- 2. In the let(-no-escape) case, we need to extend the environment--- prior to analysing the body, but we also need the fvs from the--- body to analyse the RHSs. No way to do this without some--- knot-tying.+-- Dependencies of a binding are just free variables in the binding. This+-- includes imported ids and ids in the current module. For recursive groups we+-- just return one set of free variables which is just the union of dependencies+-- of all bindings in the group.+--+-- Implementation: pass bound variables (NestedIds) to recursive calls, get free+-- variables (TopFVs) back. We ignore imported TopFVs as they do not change the+-- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`).+-- --- | This makes sure that only local, non-global free vars make it into the set.-mkFreeVarSet :: Env -> [Id] -> DIdSet-mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)+annBindingFreeVars :: Module -> StgBinding -> CgStgBinding+annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet -args :: Env -> [StgArg] -> DIdSet-args env = mkFreeVarSet env . mapMaybe f- where- f (StgVarArg occ) = Just occ- f _ = Nothing+bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs)+bindingFVs env body_fv b =+ case b of+ StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs)+ where+ (r', fvs, rhs_lcl_fvs) = rhsFVs env r+ lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs -binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)-binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)- where- -- See Note [Tracking local binders]- (r', rhs_fvs) = rhs env r- fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs-binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)- where- -- See Note [Tracking local binders]- bndrs = map fst pairs- (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs- pairs' = zip bndrs rhss- fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs+ StgRec pairs -> (StgRec pairs', fvs, lcl_fvss)+ where+ bndrs = map fst pairs+ env' = addLocals bndrs env+ (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs+ fvs = unionVarSets rhs_fvss+ pairs' = zip bndrs rhss+ lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs -expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)-expr env = go+varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs)+varFVs env v (top_fvs, lcl_fvs)+ | v `elemVarSet` locals env -- v is locally bound+ = (top_fvs, lcl_fvs `extendDVarSet` v)+ | nameIsLocalOrFrom (mod env) (idName v) -- v is bound at top level+ = (top_fvs `extendVarSet` v, lcl_fvs)+ | otherwise -- v is imported+ = (top_fvs, lcl_fvs)++exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs)+exprFVs env = go where- go (StgApp occ as)- = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))- go (StgLit lit) = (StgLit lit, emptyDVarSet)- go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as)- go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)- go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)- where- (scrut', scrut_fvs) = go scrut- -- See Note [Tracking local binders]- (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts- alt_fvs = unionDVarSets alt_fvss- fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr- go (StgLet ext bind body) = go_bind (StgLet ext) bind body+ go (StgApp f as)+ | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as)+ = (StgApp f as, top_fvs, lcl_fvs)++ go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet)++ go (StgConApp dc n as tys)+ | (top_fvs, lcl_fvs) <- argsFVs env as+ = (StgConApp dc n as tys, top_fvs, lcl_fvs)++ go (StgOpApp op as ty)+ | (top_fvs, lcl_fvs) <- argsFVs env as+ = (StgOpApp op as ty, top_fvs, lcl_fvs)++ go (StgCase scrut bndr ty alts)+ | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut+ , (alts',alts_top_fvss,alts_lcl_fvss)+ <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts+ , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss+ alts_lcl_fvs = unionDVarSets alts_lcl_fvss+ lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr+ = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs)++ go (StgLet ext bind body) = go_bind (StgLet ext) bind body go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body- go (StgTick tick e) = (StgTick tick e', fvs')- where- (e', fvs) = go e- fvs' = unionDVarSet (tickish tick) fvs- tickish (Breakpoint _ _ ids) = mkDVarSet ids- tickish _ = emptyDVarSet - go_bind dc bind body = (dc bind' body', fvs)+ go (StgTick tick e)+ | (e', top_fvs, lcl_fvs) <- exprFVs env e+ , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs+ = (StgTick tick e', top_fvs, lcl_fvs')+ where+ tickish (Breakpoint _ _ ids) = mkDVarSet ids+ tickish _ = emptyDVarSet++ go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs) where- -- See Note [Tracking local binders]- env' = addLocals (boundIds bind) env- (body', body_fvs) = expr env' body- (bind', fvs) = binding env' body_fvs bind+ env' = addLocals (bindersOf bind) env+ (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body+ (bind', bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind+ top_fvs = bind_top_fvs `unionVarSet` body_top_fvs -rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)-rhs env (StgRhsClosure _ ccs uf bndrs body)- = (StgRhsClosure fvs ccs uf bndrs body', fvs)- where- -- See Note [Tracking local binders]- (body', body_fvs) = expr (addLocals bndrs env) body- fvs = delDVarSetList body_fvs bndrs-rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as) -alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)-alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)+rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)+rhsFVs env (StgRhsClosure _ ccs uf bs body)+ | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body+ , let lcl_fvs' = delDVarSetList lcl_fvs bs+ = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs')+rhsFVs env (StgRhsCon ccs dc mu ts bs)+ | (top_fvs, lcl_fvs) <- argsFVs env bs+ = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs)++argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)+argsFVs env = foldl' f (emptyVarSet, emptyDVarSet) where- -- See Note [Tracking local binders]- (e', rhs_fvs) = expr (addLocals bndrs env) e- fvs = delDVarSetList rhs_fvs bndrs+ f (fvs,ids) StgLitArg{} = (fvs, ids)+ f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)++altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)+altFVs env (con,bndrs,e)+ | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e+ , let lcl_fvs' = delDVarSetList lcl_fvs bndrs+ = ((con,bndrs, e'), top_fvs, lcl_fvs')
compiler/GHC/Stg/Lift.hs view
@@ -24,8 +24,9 @@ import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax-import GHC.Utils.Outputable+import GHC.Unit.Module (Module) import GHC.Types.Unique.Supply+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when )@@ -124,17 +125,17 @@ -- -- (Mostly) textbook instance of the lambda lifting transformation, selecting -- which bindings to lambda lift by consulting 'goodToLift'.-stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]-stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())+stgLiftLams :: Module -> DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams this_mod dflags us = runLiftM dflags us . foldr (liftTopLvl this_mod) (pure ()) -liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()-liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do+liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()+liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do addTopStringLit bndr' lit rest-liftTopLvl (StgTopLifted bind) rest = do+liftTopLvl this_mod (StgTopLifted bind) rest = do let is_rec = isRec $ fst $ decomposeStgBinding bind when is_rec startBindingGroup- let bind_w_fvs = annBindingFreeVars bind+ let bind_w_fvs = annBindingFreeVars this_mod bind withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do -- We signal lifting of a binding through returning Nothing. -- Should never happen for a top-level binding, though, since we are already
compiler/GHC/Stg/Lint.hs view
@@ -355,7 +355,7 @@ is_sum, is_tuple, is_void :: Maybe String is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"- is_void = guard (isVoidTy id_ty) >> return "void"+ is_void = guard (isZeroBitTy id_ty) >> return "void" in is_sum <|> is_tuple <|> is_void
compiler/GHC/Stg/Pipeline.hs view
@@ -17,7 +17,7 @@ import GHC.Stg.Lint ( lintStgTopBindings ) import GHC.Stg.Stats ( showStgStats )-import GHC.Stg.DepAnal ( depSortStgPgm )+import GHC.Stg.FVs ( depSortWithAnnotStgPgm ) import GHC.Stg.Unarise ( unarise ) import GHC.Stg.BcPrep ( bcPrep ) import GHC.Stg.CSE ( stgCse )@@ -52,13 +52,13 @@ -> Bool -- prepare for bytecode? -> Module -- module being compiled -> [StgTopBinding] -- input program- -> IO [StgTopBinding] -- output program+ -> IO [CgStgTopBinding] -- output program stg2stg logger dflags ictxt for_bytecode this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $- foldM do_stg_pass binds (getStgToDo for_bytecode dflags)+ foldM (do_stg_pass this_mod) binds (getStgToDo for_bytecode dflags) -- Dependency sort the program as last thing. The program needs to be -- in dependency order for the SRT algorithm to work (see@@ -68,8 +68,10 @@ -- dependency order. We also don't guarantee that StgLiftLams will -- preserve the order or only create minimal recursive groups, so a -- sorting pass is necessary.- ; let binds_sorted = depSortStgPgm this_mod binds'- ; return binds_sorted+ -- This pass will also augment each closure with non-global free variables+ -- annotations (which is used by code generator to compute offsets into closures)+ ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'+ ; return binds_sorted_with_fvs } where@@ -80,8 +82,8 @@ = \ _whodunnit _binds -> return () -------------------------------------------- do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]- do_stg_pass binds to_do+ do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]+ do_stg_pass this_mod binds to_do = case to_do of StgDoNothing -> return binds@@ -95,7 +97,8 @@ StgLiftLams -> do us <- getUniqueSupplyM- let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds+ --+ let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod dflags us binds end_pass "StgLiftLams" binds' StgBcPrep -> do
compiler/GHC/Stg/Unarise.hs view
@@ -557,7 +557,7 @@ -> UnariseEnv -> UnariseEnv mapTupleIdBinders ids args0 rho0- = assert (not (any (isVoidTy . stgArgType) args0)) $+ = assert (not (any (isZeroBitTy . stgArgType) args0)) $ let ids_unarised :: [(Id, [PrimRep])] ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids@@ -591,7 +591,7 @@ -> UnariseEnv mapSumIdBinders [id] args rho0- = assert (not (any (isVoidTy . stgArgType) args)) $+ = assert (not (any (isZeroBitTy . stgArgType) args)) $ let arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args id_slots = map primRepSlot $ typePrimRep (idType id)@@ -777,15 +777,15 @@ Just (UnaryVal arg) -> [arg] Just (MultiVal as) -> as -- 'as' can be empty Nothing- | isVoidTy (idType x) -> [] -- e.g. C realWorld#- -- Here realWorld# is not in the envt, but- -- is a void, and so should be eliminated+ | isZeroBitTy (idType x) -> [] -- e.g. C realWorld#+ -- Here realWorld# is not in the envt, but+ -- is a void, and so should be eliminated | otherwise -> [StgVarArg x] unariseConArg _ arg@(StgLitArg lit) | Just as <- unariseRubbish_maybe lit = as | otherwise- = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals+ = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals [arg] unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
compiler/GHC/StgToByteCode.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -88,14 +89,13 @@ import Data.Either ( partitionEithers ) import GHC.Stg.Syntax-import GHC.Stg.FVs -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module byteCodeGen :: HscEnv -> Module- -> [StgTopBinding]+ -> [CgStgTopBinding] -> [TyCon] -> Maybe ModBreaks -> IO CompiledByteCode@@ -116,8 +116,7 @@ (BcM_State{..}, proto_bcos) <- runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do- let flattened_binds =- concatMap (flattenBind . annBindingFreeVars) (reverse lifted_binds)+ let flattened_binds = concatMap flattenBind (reverse lifted_binds) mapM schemeTopBind flattened_binds when (notNull ffis)@@ -1393,6 +1392,7 @@ conv = case cconv of CCallConv -> FFICCall+ CApiConv -> FFICCall StdCallConv -> FFIStdCall _ -> panic "GHC.StgToByteCode: unexpected calling convention" @@ -1935,7 +1935,7 @@ StdCallConv -> True -- convention to ensure that a warning PrimCallConv -> False -- is triggered when a new one is added JavaScriptCallConv -> False- CApiConv -> False+ CApiConv -> True -- See bug #10462 unsupportedCConvException :: a
compiler/GHC/StgToCmm/Closure.hs view
@@ -151,23 +151,23 @@ ppr (NonVoid a) = ppr a nonVoidIds :: [Id] -> [NonVoid Id]-nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]+nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))] -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = assert (not (any (isVoidTy . idType) ids)) $+assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $ coerce ids nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))] -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = assert (not (any (isVoidTy . stgArgType) args)) $+assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $ coerce args
compiler/GHC/StgToCmm/Expr.hs view
@@ -43,7 +43,7 @@ import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type ( isUnliftedType )-import GHC.Types.RepType ( isVoidTy, countConRepArgs )+import GHC.Types.RepType ( isZeroBitTy, countConRepArgs ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish import GHC.Data.Maybe@@ -896,12 +896,12 @@ fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args- v_args = length $ filter (isVoidTy . stgArgType) args+ v_args = length $ filter (isZeroBitTy . stgArgType) args case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt- | isVoidTy (idType fun_id) -> emitReturn []- | otherwise -> emitReturn [fun]+ | isZeroBitTy (idType fun_id) -> emitReturn []+ | otherwise -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? EnterIt -> assert (null args) $ -- Discarding arguments
compiler/GHC/StgToCmm/Layout.hs view
@@ -212,7 +212,7 @@ -- Note [avoid intermediate PAPs] let n_args = length stg_args- if n_args > arity && optLevel dflags >= 2+ if n_args > arity && gopt Opt_FastPAPCalls dflags then do ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
compiler/GHC/SysTools/Tasks.hs view
@@ -365,16 +365,15 @@ args' = -- If windres.exe and gcc.exe are in a directory containing -- spaces then windres fails to run gcc. We therefore need -- to tell it what command to use...- Option ("--preprocessor=" ++- unwords (map quote (cc :- map showOpt opts ++- ["-E", "-xc", "-DRC_INVOKED"])))+ [ Option ("--preprocessor=" ++ quote cc) ]+ ++ map (Option . ("--preprocessor-arg=" ++) . quote)+ (map showOpt opts ++ ["-E", "-xc", "-DRC_INVOKED"]) -- ...but if we do that then if windres calls popen then -- it can't understand the quoting, so we have to use -- --use-temp-file so that it interprets it correctly. -- See #1828.- : Option "--use-temp-file"- : args+ ++ [ Option "--use-temp-file" ]+ ++ args mb_env <- getGccEnv cc_args runSomethingFiltered logger id "Windres" windres args' Nothing mb_env
compiler/GHC/Tc/Deriv.hs view
@@ -5,6 +5,7 @@ -} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} @@ -1241,11 +1242,13 @@ -- Find the instance of a data family -- Note [Looking up family instances for deriving] let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args- in DerivInstTys { dit_cls_tys = cls_tys- , dit_tc = tc- , dit_tc_args = tc_args- , dit_rep_tc = rep_tc- , dit_rep_tc_args = rep_tc_args }+ dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args+ in DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_tc_args = tc_args+ , dit_rep_tc = rep_tc+ , dit_rep_tc_args = rep_tc_args+ , dit_dc_inst_arg_env = dc_inst_arg_env } {- Note [Looking up family instances for deriving]@@ -1327,7 +1330,7 @@ dfun_name <- lift $ newDFunName cls inst_tys loc case deriv_ctxt of InferContext wildcard ->- do { (inferred_constraints, tvs', inst_tys')+ do { (inferred_constraints, tvs', inst_tys', mechanism') <- inferConstraints mechanism ; return $ InferTheta $ DS { ds_loc = loc@@ -1336,7 +1339,7 @@ , ds_theta = inferred_constraints , ds_overlap = overlap_mode , ds_standalone_wildcard = wildcard- , ds_mechanism = mechanism } }+ , ds_mechanism = mechanism' } } SupplyContext theta -> return $ GivenTheta $ DS@@ -1350,16 +1353,11 @@ mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class -> DerivM EarlyDerivSpec-mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys- , dit_tc = tc- , dit_rep_tc = rep_tc })- = do DerivEnv { denv_cls = cls- , denv_ctxt = deriv_ctxt } <- ask- dflags <- getDynFlags+mk_eqn_stock dit+ = do dflags <- getDynFlags let isDeriveAnyClassEnabled = deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)- case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys- tc rep_tc of+ checkOriginativeSideConditions dit >>= \case CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fn = gen_fn }@@ -1431,11 +1429,8 @@ -- Use heuristics (checkOriginativeSideConditions) to determine whether -- stock or anyclass deriving should be used. mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec- mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys- , dit_tc = tc- , dit_rep_tc = rep_tc }) = do- DerivEnv { denv_cls = cls- , denv_ctxt = deriv_ctxt } <- ask+ mk_eqn_originative dit@(DerivInstTys { dit_tc = tc+ , dit_rep_tc = rep_tc }) = do dflags <- getDynFlags let isDeriveAnyClassEnabled = deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)@@ -1447,8 +1442,7 @@ | otherwise = DerivErrNotStockDeriveable isDeriveAnyClassEnabled - case checkOriginativeSideConditions dflags deriv_ctxt cls- cls_tys tc rep_tc of+ checkOriginativeSideConditions dit >>= \case NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why CanDeriveStock gen_fn -> mk_eqn_from_mechanism $@@ -1476,12 +1470,10 @@ -- deriving strategy? -> DerivInstTys -> DerivM EarlyDerivSpec mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys- , dit_tc = tycon , dit_rep_tc = rep_tycon , dit_rep_tc_args = rep_tc_args }) -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...- = do DerivEnv { denv_cls = cls- , denv_ctxt = deriv_ctxt } <- ask+ = do DerivEnv{denv_cls = cls} <- ask dflags <- getDynFlags let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags@@ -1573,8 +1565,7 @@ && ((newtype_deriving && not deriveAnyClass) || std_class_via_coercible cls) then mk_eqn_newtype dit rep_inst_ty- else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys- tycon rep_tycon of+ else checkOriginativeSideConditions dit >>= \case StockClassError why -- There's a particular corner case where --@@ -1859,6 +1850,9 @@ -- that bring type variables into scope. -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate , LangExt.InstanceSigs+ -- Skip unboxed tuples checking for derived instances when imported+ -- in a different module, see #20524+ , LangExt.UnboxedTuples ] | otherwise = []@@ -2017,12 +2011,9 @@ -> gen_newtype_or_via rhs_ty -- Try a stock deriver- DerivSpecStock { dsm_stock_dit = DerivInstTys- { dit_rep_tc = rep_tc- , dit_rep_tc_args = rep_tc_args- }+ DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fn = gen_fn }- -> gen_fn loc rep_tc rep_tc_args inst_tys+ -> gen_fn loc inst_tys dit -- Try DeriveAnyClass DerivSpecAnyClass -> do
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -149,10 +149,10 @@ $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Functor_binds loc tycon _+gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon}) | Phantom <- last (tyConRoles tycon) = (unitBag fmap_bind, emptyBag) where@@ -163,7 +163,8 @@ coerce_Expr] fmap_match_ctxt = mkPrefixFunRhs fmap_name -gen_Functor_binds loc tycon tycon_args+gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) = (listToBag [fmap_bind, replace_bind], emptyBag) where data_cons = getPossibleDataCons tycon tycon_args@@ -176,7 +177,7 @@ fmap_eqn con = flip evalState bs_RDRs $ match_for_con fmap_match_ctxt [f_Pat] con parts where- parts = foldDataConArgs ft_fmap con+ parts = foldDataConArgs ft_fmap con dit fmap_eqns = map fmap_eqn data_cons @@ -215,7 +216,7 @@ replace_eqn con = flip evalState bs_RDRs $ match_for_con replace_match_ctxt [z_Pat] con parts where- parts = foldDataConArgs ft_replace con+ parts = foldDataConArgs ft_replace con dit replace_eqns = map replace_eqn data_cons @@ -552,10 +553,10 @@ , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) -foldDataConArgs :: FFoldType a -> DataCon -> [a]+foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a] -- Fold over the arguments of the datacon-foldDataConArgs ft con- = map foldArg (map scaledThing $ dataConOrigArgTys con)+foldDataConArgs ft con dit+ = map foldArg (derivDataConInstArgTys con dit) where foldArg = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of@@ -783,10 +784,10 @@ think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Foldable_binds loc tycon _+gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon}) | Phantom <- last (tyConRoles tycon) = (unitBag foldMap_bind, emptyBag) where@@ -797,7 +798,8 @@ mempty_Expr] foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -gen_Foldable_binds loc tycon tycon_args+gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) | null data_cons -- There's no real point producing anything but -- foldMap for a type with no constructors. = (unitBag foldMap_bind, emptyBag)@@ -814,7 +816,7 @@ foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs where- parts = sequence $ foldDataConArgs ft_foldr con+ parts = sequence $ foldDataConArgs ft_foldr con dit foldr_match_ctxt = mkPrefixFunRhs foldr_name foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR@@ -828,7 +830,7 @@ foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs where- parts = sequence $ foldDataConArgs ft_foldMap con+ parts = sequence $ foldDataConArgs ft_foldMap con dit foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -- Given a list of NullM results, produce Nothing if any of@@ -847,7 +849,7 @@ null_eqns = map null_eqn data_cons null_eqn con = flip evalState bs_RDRs $ do- parts <- sequence $ foldDataConArgs ft_null con+ parts <- sequence $ foldDataConArgs ft_null con dit case convert parts of Nothing -> return $ mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]@@ -1016,10 +1018,10 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Traversable_binds loc tycon _+gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon}) | Phantom <- last (tyConRoles tycon) = (unitBag traverse_bind, emptyBag) where@@ -1031,7 +1033,8 @@ (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] traverse_match_ctxt = mkPrefixFunRhs traverse_name -gen_Traversable_binds loc tycon tycon_args+gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) = (unitBag traverse_bind, emptyBag) where data_cons = getPossibleDataCons tycon tycon_args@@ -1045,7 +1048,7 @@ traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where- parts = sequence $ foldDataConArgs ft_trav con+ parts = sequence $ foldDataConArgs ft_trav con dit traverse_match_ctxt = mkPrefixFunRhs traverse_name -- Yields 'Just' an expression if we're folding over a type that mentions
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -36,7 +36,9 @@ ordOpTbl, boxConTbl, litConTbl, mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr, - getPossibleDataCons, tyConInstArgTys+ getPossibleDataCons,+ DerivInstTys(..), buildDataConInstArgEnv,+ derivDataConInstArgTys, substDerivInstTys ) where import GHC.Prelude@@ -67,11 +69,12 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type-import GHC.Core.Multiplicity import GHC.Core.Class+import GHC.Types.Unique.FM ( lookupUFM ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc+import GHC.Types.Unique.FM ( listToUFM ) import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic@@ -212,8 +215,9 @@ produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Eq_binds loc tycon tycon_args = do+gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) = do return (method_binds, emptyBag) where all_cons = getPossibleDataCons tycon tycon_args@@ -258,9 +262,9 @@ con_arity = length tys_needed as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs- tys_needed = dataConOrigArgTys data_con+ tys_needed = derivDataConInstArgTys data_con dit in- ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed)+ ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs@@ -388,8 +392,9 @@ gtResult OrdGT = true_Expr -------------gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Ord_binds loc tycon tycon_args = do+gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) = do return $ if null tycon_data_cons -- No data-cons => invoke bale-out case then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] , emptyBag)@@ -507,7 +512,7 @@ -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $- mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con)+ mkCompareFields op (derivDataConInstArgTys data_con dit) where data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs@@ -636,8 +641,8 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Enum_binds loc tycon _ = do+gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon maxtag_RDR <- new_maxtag_rdr_name loc tycon@@ -726,8 +731,8 @@ ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Bounded_binds loc tycon _+gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)+gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon}) | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) | otherwise@@ -813,9 +818,9 @@ (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ix_binds loc tycon _ = do+gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon @@ -1015,10 +1020,10 @@ we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) -gen_Read_binds get_fixity loc tycon _+gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) where -----------------------------------------------------------------------@@ -1107,7 +1112,7 @@ is_infix = dataConIsInfix data_con is_record = labels `lengthExceeds` 0 as_needed = take con_arity as_RDRs- read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con)+ read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit) (read_a1:read_a2:_) = read_args prefix_prec = appPrecedence@@ -1199,10 +1204,11 @@ -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) -gen_Show_binds get_fixity loc tycon tycon_args+gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) = (unitBag shows_prec, emptyBag) where data_cons = getPossibleDataCons tycon tycon_args@@ -1222,7 +1228,7 @@ data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con bs_needed = take con_arity bs_RDRs- arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed+ arg_tys = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed con_pat = nlConVarPat data_con_RDR bs_needed nullary_con = con_arity == 0 labels = map flLabel $ dataConFieldLabels data_con@@ -1250,7 +1256,7 @@ where nm = wrapOpParens (unpackFS l) - show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys)+ show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys (show_arg1:show_arg2:_) = show_args show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args @@ -1370,12 +1376,10 @@ -} gen_Data_binds :: SrcSpan- -> TyCon -- For data families, this is the- -- *representation* TyCon- -> [Type]+ -> DerivInstTys -> TcM (LHsBinds GhcPs, -- The method bindings BagDerivStuff) -- Auxiliary bindings-gen_Data_binds loc rep_tc _+gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc}) = do { -- See Note [Auxiliary binders] dataT_RDR <- new_dataT_rdr_name loc rep_tc ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons@@ -1628,27 +1632,35 @@ ==> instance (Lift a) => Lift (Foo a) where- lift (Foo a) = [| Foo a |]- lift ((:^:) u v) = [| (:^:) u v |]+ lift (Foo a) = [| Foo $(lift a) |]+ lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |] - liftTyped (Foo a) = [|| Foo a ||]- liftTyped ((:^:) u v) = [|| (:^:) u v ||]+ liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]+ liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]++Note that we use explicit splices here in order to not trigger the implicit+lifting warning in derived code. (See #20688) -} -gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)+gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)+gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon+ , dit_rep_tc_args = tycon_args }) =+ (listToBag [lift_bind, liftTyped_bind], emptyBag) where lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)- (map (pats_etc mk_exp) data_cons)+ (map (pats_etc mk_exp mk_usplice liftName) data_cons) liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)- (map (pats_etc mk_texp) data_cons)+ (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons) mk_exp = ExpBr noExtField mk_texp = TExpBr noExtField++ mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice+ mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice data_cons = getPossibleDataCons tycon tycon_args - pats_etc mk_bracket data_con+ pats_etc mk_bracket mk_splice lift_name data_con = ([con_pat], lift_Expr) where con_pat = nlConVarPat data_con_RDR as_needed@@ -1657,8 +1669,14 @@ as_needed = take con_arity as_RDRs lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body)) br_body = nlHsApps (Exact (dataConName data_con))- (map nlHsVar as_needed)+ (map lift_var as_needed) + lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)+ lift_var x = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x))))++ mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)+ mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]+ {- ************************************************************************ * *@@ -2642,32 +2660,107 @@ getPossibleDataCons :: TyCon -> [Type] -> [DataCon] getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon where- isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)+ isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc --- | Given a type constructor @tycon@ of arity /n/ and a list of argument types--- @tycon_args@ of length /m/,+-- | Information about the arguments to the class in a stock- or+-- newtype-derived instance. For a @deriving@-generated instance declaration+-- such as this one: -- -- @--- tyConInstArgTys tycon tycon_args+-- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ... -- @ ----- returns------ @--- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]--- @+-- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@. ----- where @extra_args@ are distinct type variables.+-- * 'dit_tc' corresponds to @TC@. ----- Examples:+-- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a+-- more in-depth explanation, including the relationship between+-- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.-tyConInstArgTys :: TyCon -> [Type] -> [Type]-tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix+-- A 'DerivInstTys' value can be seen as a more structured representation of+-- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to+-- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the+-- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@+-- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'.+data DerivInstTys = DerivInstTys+ { dit_cls_tys :: [Type]+ -- ^ Other arguments to the class except the last+ , dit_tc :: TyCon+ -- ^ Type constructor for which the instance is requested+ -- (last arguments to the type class)+ , dit_tc_args :: [Type]+ -- ^ Arguments to the type constructor+ , dit_rep_tc :: TyCon+ -- ^ The representation tycon for 'dit_tc'+ -- (for data family instances). Otherwise the same as 'dit_tc'.+ , dit_rep_tc_args :: [Type]+ -- ^ The representation types for 'dit_tc_args'+ -- (for data family instances). Otherwise the same as 'dit_tc_args'.+ , dit_dc_inst_arg_env :: DataConEnv [Type]+ -- ^ The cached results of instantiating each data constructor's field+ -- types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@.+ -- See @Note [Instantiating field types in stock deriving]@.+ --+ -- This field is only used for stock-derived instances and goes unused+ -- for newtype-derived instances. It is put here mainly for the sake of+ -- convenience.+ }++instance Outputable DerivInstTys where+ ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args+ , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args+ , dit_dc_inst_arg_env = dc_inst_arg_env })+ = hang (text "DerivInstTys")+ 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys+ , text "dit_tc" <+> ppr tc+ , text "dit_tc_args" <+> ppr tc_args+ , text "dit_rep_tc" <+> ppr rep_tc+ , text "dit_rep_tc_args" <+> ppr rep_tc_args+ , text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ])++-- | Look up a data constructor's instantiated field types in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@.+derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]+derivDataConInstArgTys dc dit =+ case lookupUFM (dit_dc_inst_arg_env dit) dc of+ Just inst_arg_tys -> inst_arg_tys+ Nothing -> pprPanic "derivDataConInstArgTys" (ppr dc)++-- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps+-- each of @tycon@'s data constructors to their field types, with are to be+-- instantiated with @arg_tys@.+-- See @Note [Instantiating field types in stock deriving]@.+buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]+buildDataConInstArgEnv rep_tc rep_tc_args =+ listToUFM [ (dc, inst_arg_tys)+ | dc <- tyConDataCons rep_tc+ , let (_, _, inst_arg_tys) =+ dataConInstSig dc $ dataConInstUnivs dc rep_tc_args+ ]++-- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@ for why we need to+-- substitute into a 'DerivInstTys' in the first place.+substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys+substDerivInstTys subst+ dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args+ , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })++ | isEmptyTCvSubst subst+ = dit+ | otherwise+ = dit{ dit_cls_tys = cls_tys'+ , dit_tc_args = tc_args'+ , dit_rep_tc_args = rep_tc_args'+ , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'+ } where- tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon+ cls_tys' = substTys subst cls_tys+ tc_args' = substTys subst tc_args+ rep_tc_args' = substTys subst rep_tc_args {- Note [Auxiliary binders]@@ -2938,4 +3031,82 @@ there is a valid use-case and we have requirements for how they should work. See #16341 and the T16341.hs test case.++Note [Instantiating field types in stock deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Figuring out what the types of data constructor fields are in `deriving` can+be surprisingly tricky. Here are some examples (adapted from #20375) to set+the scene:++ data Ta = MkTa Int#+ data Tb (x :: TYPE IntRep) = MkTb x++ deriving instance Eq Ta -- 1.+ deriving instance Eq (Tb a) -- 2.+ deriving instance Eq (Tb Int#) -- 3.++Example (1) is accepted, as `deriving Eq` has a special case for fields of type+Int#. Example (2) is rejected, however, as the special case for Int# does not+extend to all types of kind (TYPE IntRep).++Example (3) ought to typecheck. If you instantiate the field of type `x` in+MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be+careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the+field types, then we would get `b`, which `deriving Eq` would reject. In+order to handle `deriving Eq` (and, more generally, any stock deriving+strategy) correctly, we /must/ instantiate the field types as needed.+Not doing so led to #20375 and #20387.++In fact, we end up needing to instantiate the field types in quite a few+places:++* When performing validity checks for stock deriving strategies (e.g., in+ GHC.Tc.Deriv.Utils.cond_stdOK)++* When inferring the instance context in+ GHC.Tc.Deriv.Infer.inferConstraintStock++* When generating code for stock-derived instances in+ GHC.Tc.Deriv.{Functor,Generate,Generics}++Repeatedly performing these instantiations in multiple places would be+wasteful, so we build a cache of data constructor field instantiations in+the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically:++1. When beginning to generate code for a stock-derived instance+ `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking+ each data constructor `dc`, instantiating its field types with+ `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the+ instantiated field types in the cache. The `buildDataConInstArgEnv` function+ is responsible for orchestrating this.++2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field+ types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use+ `derivDataConInstArgTys`, which looks up a DataCon's instantiated field+ types in the cache.++StandaloneDeriving is one way for the field types to become instantiated.+Another way is by deriving Functor and related classes, as chronicled in+Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such+example:++ newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a))+ deriving Generic1++This ultimately generates the following instance:++ instance forall (f :: Type -> Type) (g :: j -> Type).+ Functor f => Generic1 (Compose f g) where ...++Note that because of the inferred `Functor f` constraint, `k` was instantiated+to be `Type`. GHC's deriving machinery doesn't realize this until it performs+constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however,+which is *after* the initial DerivInstTys has been created. As a result, the+`dit_dc_inst_arg_env` field might need to be updated after constraint inference,+as the inferred constraints might instantiate the field types further.++This is accomplished by way of `substDerivInstTys`, which substitutes all of+the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`.+It is important to do this in inferConstraintsStock, as the+deriving/should_compile/T20387 test case will not compile otherwise. -}
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -31,7 +31,6 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )-import GHC.Core.Multiplicity import GHC.Tc.Instance.Family import GHC.Unit.Module ( moduleName, moduleNameFS , moduleUnit, unitFS, getModule )@@ -78,12 +77,12 @@ \end{itemize} -} -gen_Generic_binds :: GenericKind -> TyCon -> [Type]- -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)-gen_Generic_binds gk tc inst_tys = do+gen_Generic_binds :: GenericKind -> [Type] -> DerivInstTys+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)+gen_Generic_binds gk inst_tys dit = do dflags <- getDynFlags- repTyInsts <- tc_mkRepFamInsts gk tc inst_tys- let (binds, sigs) = mkBindsRep dflags gk tc+ repTyInsts <- tc_mkRepFamInsts gk inst_tys dit+ let (binds, sigs) = mkBindsRep dflags gk dit return (binds, sigs, repTyInsts) {-@@ -119,6 +118,7 @@ alpha-renaming). (b) D cannot have a "stupid context".+ See Note [The stupid context] in GHC.Core.DataCon. (c) The right-hand side of D cannot include existential types, universally quantified types, or "exotic" unlifted types. An exotic unlifted type@@ -147,7 +147,7 @@ -} -canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason]+canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken@@ -155,7 +155,7 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics tc+canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc}) = mergeErrors ( -- Check (b) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc)))@@ -177,7 +177,7 @@ -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors bad_con :: DataCon -> Validity' DeriveGenericsErrReason- bad_con dc = if any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)+ bad_con dc = if any bad_arg_type (derivDataConInstArgTys dc dit) then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc else if not (isVanillaDataCon dc) then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc@@ -243,9 +243,9 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics1 :: TyCon -> Validity' [DeriveGenericsErrReason]-canDoGenerics1 rep_tc =- canDoGenerics rep_tc `andValid` additionalChecks+canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]+canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =+ canDoGenerics dit `andValid` additionalChecks where additionalChecks -- check (d) from Note [Requirements for deriving Generic and Rep]@@ -257,7 +257,7 @@ data_cons = tyConDataCons rep_tc check_con con = case check_vanilla con of j@(NotValid {}) -> [j]- IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con+ IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con dit check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason check_vanilla con | isVanillaDataCon con = IsValid@@ -329,8 +329,8 @@ -- Bindings for the Generic instance-mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])-mkBindsRep dflags gk tycon = (binds, sigs)+mkBindsRep :: DynFlags -> GenericKind -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])+mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) where binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn]) `unionBags`@@ -377,7 +377,7 @@ -- Recurse over the sum first from_alts, to_alts :: [Alt]- (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons+ (from_alts, to_alts) = mkSum gk_ (1 :: US) dit datacons where gk_ = case gk of Gen0 -> Gen0_ Gen1 -> assert (tyvars `lengthAtLeast` 1) $@@ -391,11 +391,12 @@ -------------------------------------------------------------------------------- tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1- -> TyCon -- The type to generate representation for -> [Type] -- The type(s) to which Generic(1) is applied -- in the generated instance+ -> DerivInstTys -- Information about the last type argument,+ -- including the data type's TyCon -> TcM FamInst -- Generated representation0 coercion-tc_mkRepFamInsts gk tycon inst_tys =+tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a }@@ -404,8 +405,6 @@ Gen0 -> tcLookupTyCon repTyConName Gen1 -> tcLookupTyCon rep1TyConName - ; fam_envs <- tcGetFamInstEnvs- ; let -- If the derived instance is -- instance Generic (Foo x) -- then:@@ -420,23 +419,14 @@ (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) - ; let mbFamInst = tyConFamInst_maybe tycon- -- If we're examining a data family instance, we grab the parent- -- TyCon (ptc) and use it to determine the type arguments- -- (inst_args) for the data family *instance*'s type variables.- ptc = maybe tycon fst mbFamInst- (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd- $ tcSplitTyConApp inst_ty-- ; let -- `tyvars` = [a,b]- (tyvars, gk_) = case gk of- Gen0 -> (all_tyvars, Gen0_)+ gk_ = case gk of+ Gen0 -> Gen0_ Gen1 -> assert (not $ null all_tyvars)- (init all_tyvars, Gen1_ $ last all_tyvars)+ Gen1_ $ last all_tyvars where all_tyvars = tyConTyVars tycon -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *- ; repTy <- tc_mkRepTy gk_ tycon arg_ki+ ; repTy <- tc_mkRepTy gk_ dit arg_ki -- `rep_name` is a name we generate for the synonym ; mod <- getModule@@ -445,19 +435,14 @@ rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ ; rep_name <- newGlobalBinder mod rep_occ loc - -- We make sure to substitute the tyvars with their user-supplied- -- type arguments before generating the Rep/Rep1 instance, since some- -- of the tyvars might have been instantiated when deriving.- -- See Note [Generating a correctly typed Rep instance].- ; let (env_tyvars, env_inst_args)- = case gk_ of- Gen0_ -> (tyvars, inst_args)- Gen1_ last_tv- -- See the "wrinkle" in- -- Note [Generating a correctly typed Rep instance]- -> ( last_tv : tyvars- , anyTypeOfKind (tyVarKind last_tv) : inst_args )- env = zipTyEnv env_tyvars env_inst_args+ -- If deriving Generic1, make sure to substitute the last type variable+ -- with Any in the generated Rep1 instance. This avoids issues like what+ -- is documented in the "wrinkle" section of+ -- Note [Generating a correctly typed Rep instance].+ ; let env = case gk_ of+ Gen0_ -> emptyTvSubstEnv+ Gen1_ last_tv+ -> zipTyEnv [last_tv] [anyTypeOfKind (tyVarKind last_tv)] in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) subst = mkTvSubst in_scope env repTy' = substTyUnchecked subst repTy@@ -541,14 +526,14 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_- -- The type to generate representation for- -> TyCon- -- The kind of the representation type's argument- -- See Note [Handling kinds in a Rep instance]+ -- Information about the last type argument to Generic(1)+ -> DerivInstTys+ -- The kind of the representation type's argument+ -- See Note [Handling kinds in a Rep instance] -> Kind -- Generated representation0 type -> TcM Type-tc_mkRepTy gk_ tycon k =+tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName@@ -598,8 +583,7 @@ mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] mkC a = mkTyConApp c1 [ k , metaConsTy a- , prod (map scaledThing . dataConInstOrigArgTys a- . mkTyVarTys . tyConTyVars $ tycon)+ , prod (derivDataConInstArgTys a dit) (dataConSrcBangs a) (dataConImplBangs a) (dataConFieldLabels a)]@@ -730,41 +714,43 @@ -------------------------------------------------------------------------------- mkSum :: GenericKind_ -- Generic or Generic1?- -> US -- Base for generating unique names- -> [DataCon] -- The data constructors- -> ([Alt], -- Alternatives for the T->Trep "from" function- [Alt]) -- Alternatives for the Trep->T "to" function+ -> US -- Base for generating unique names+ -> DerivInstTys -- Information about the last type argument to Generic(1)+ -> [DataCon] -- The data constructors+ -> ([Alt], -- Alternatives for the T->Trep "from" function+ [Alt]) -- Alternatives for the Trep->T "to" function -- Datatype without any constructors-mkSum _ _ [] = ([from_alt], [to_alt])+mkSum _ _ _ [] = ([from_alt], [to_alt]) where from_alt = (x_Pat, nlHsCase x_Expr []) to_alt = (x_Pat, nlHsCase x_Expr []) -- These M1s are meta-information for the datatype -- Datatype with at least one constructor-mkSum gk_ us datacons =+mkSum gk_ us dit datacons = -- switch the payload of gk_ to be datacon-centric instead of tycon-centric- unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) dit d | (d,i) <- zip datacons [1..] ] -- Build the sum for a particular constructor mk1Sum :: GenericKind_DC -- Generic or Generic1?- -> US -- Base for generating unique names- -> Int -- The index of this constructor- -> Int -- Total number of constructors- -> DataCon -- The data constructor- -> (Alt, -- Alternative for the T->Trep "from" function- Alt) -- Alternative for the Trep->T "to" function-mk1Sum gk_ us i n datacon = (from_alt, to_alt)+ -> US -- Base for generating unique names+ -> Int -- The index of this constructor+ -> Int -- Total number of constructors+ -> DerivInstTys -- Information about the last type argument to Generic(1)+ -> DataCon -- The data constructor+ -> (Alt, -- Alternative for the T->Trep "from" function+ Alt) -- Alternative for the Trep->T "to" function+mk1Sum gk_ us i n dit datacon = (from_alt, to_alt) where gk = forgetArgVar gk_ -- Existentials already excluded- argTys = dataConOrigArgTys datacon+ argTys = derivDataConInstArgTys datacon dit n_args = dataConSourceArity datacon - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys)+ datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys datacon_vars = map fst datacon_varTys datacon_rdr = getRdrName datacon@@ -922,59 +908,55 @@ Note [Generating a correctly typed Rep instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving-Generic(1). That is, it derives the ellipsis in the following:-- instance Generic Foo where- type Rep Foo = ...+Generic(1). For example, given the following data declaration: -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which-a Generic(1) instance is being derived, not the fully instantiated type. As a-result, tc_mkRepTy builds the most generalized Rep(1) instance possible using-the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This-can cause problems when the instance has instantiated type variables-(see #11732). As an example:+ data Foo a = MkFoo a+ deriving stock Generic - data T a = MkT a- deriving instance Generic (T Int)- ==>- instance Generic (T Int) where- type Rep (T Int) = (... (Rec0 a)) -- wrong!+tc_mkRepTy would generate the `Rec0 a` portion of this instance: --XStandaloneDeriving is one way for the type variables to become instantiated.-Another way is when Generic1 is being derived for a datatype with a visible-kind binder, e.g.,+ instance Generic (Foo a) where+ type Rep (Foo a) = Rec0 a+ ... - data P k (a :: k) = MkP k deriving Generic1- ==>- instance Generic1 (P *) where- type Rep1 (P *) = (... (Rec0 k)) -- wrong!+(The full `Rep` instance is more complicated than this, but we have simplified+it for presentation purposes.) -See Note [Unify kinds in deriving] in GHC.Tc.Deriv.+`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a+DerivInstTys, which contains the instantiated field types for each data+constructor. (See Note [Instantiating field types in stock deriving] for a+description of how this works.) As a result, `tc_mkRepTy` "just works" even+when dealing with StandaloneDeriving, such as in this example: -In any such scenario, we must prevent a discrepancy between the LHS and RHS of-a Rep(1) instance. To do so, we create a type variable substitution that maps-the tyConTyVars of the TyCon to their counterparts in the fully instantiated-type. (For example, using T above as example, you'd map a :-> Int.) We then-apply the substitution to the RHS before generating the instance.+ deriving stock instance Generic (Foo Int)+ ===>+ instance Generic (Foo Int) where+ type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here -A wrinkle in all of this: when forming the type variable substitution for-Generic1 instances, we map the last type variable of the tycon to Any. Why?-It's because of wily data types like this one (#15012):+A wrinkle in all of this: what happens when deriving a Generic1 instance where+the last type variable appears in a type synonym that discards it? That is,+what should happen in this example (taken from #15012)? - data T a = MkT (FakeOut a)- type FakeOut a = Int+ type FakeOut a = Int+ data T a = MkT (FakeOut a)+ deriving Generic1 -If we ignore a, then we'll produce the following Rep1 instance:+MkT is a particularly wily data constructor. Although the last type variable+`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a`+simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type+variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's+field. But we must be careful not to produce code like this: instance Generic1 T where- type Rep1 T = ... (Rec0 (FakeOut a))+ type Rep1 T = Rec0 (FakeOut a) ... -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we-ensure that `a` is mapped to Any:+Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause+issues like what was observed in #15012. To avoid this, we ensure that `a` is+instantiated to Any: instance Generic1 T where- type Rep1 T = ... (Rec0 (FakeOut Any))+ type Rep1 T = Rec0 (FakeOut Any) ... And now all is good.
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -59,7 +59,7 @@ ---------------------- inferConstraints :: DerivSpecMechanism- -> DerivM ([ThetaOrigin], [TyVar], [TcType])+ -> DerivM ([ThetaOrigin], [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a -- data type declaration. It also returns the new in-scope type@@ -80,11 +80,13 @@ , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask ; wildcard <- isStandaloneWildcardDeriv- ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])+ ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType], DerivSpecMechanism) infer_constraints = case mechanism of DerivSpecStock{dsm_stock_dit = dit}- -> inferConstraintsStock dit+ -> do (thetas, tvs, inst_tys, dit') <- inferConstraintsStock dit+ pure ( thetas, tvs, inst_tys+ , mechanism{dsm_stock_dit = dit'} ) DerivSpecAnyClass -> infer_constraints_simple inferConstraintsAnyclass DerivSpecNewtype { dsm_newtype_dit =@@ -104,10 +106,10 @@ -- Note [Inferring the instance context]. infer_constraints_simple :: DerivM [ThetaOrigin]- -> DerivM ([ThetaOrigin], [TyVar], [TcType])+ -> DerivM ([ThetaOrigin], [TyVar], [TcType], DerivSpecMechanism) infer_constraints_simple infer_thetas = do thetas <- infer_thetas- pure (thetas, tvs, inst_tys)+ pure (thetas, tvs, inst_tys, mechanism) -- Constraints arising from superclasses -- See Note [Superclasses of derived instance]@@ -120,13 +122,14 @@ cls_subst = assert (equalLength cls_tvs inst_tys) $ zipTvSubst cls_tvs inst_tys - ; (inferred_constraints, tvs', inst_tys') <- infer_constraints+ ; (inferred_constraints, tvs', inst_tys', mechanism')+ <- infer_constraints ; lift $ traceTc "inferConstraints" $ vcat [ ppr main_cls <+> ppr inst_tys' , ppr inferred_constraints ] ; return ( sc_constraints ++ inferred_constraints- , tvs', inst_tys' ) }+ , tvs', inst_tys', mechanism' ) } -- | Like 'inferConstraints', but used only in the case of the @stock@ deriving -- strategy. The constraints are inferred by inspecting the fields of each data@@ -152,12 +155,12 @@ -- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. -- See Note [Inferring the instance context]. inferConstraintsStock :: DerivInstTys- -> DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys- , dit_tc = tc- , dit_tc_args = tc_args- , dit_rep_tc = rep_tc- , dit_rep_tc_args = rep_tc_args })+ -> DerivM ([ThetaOrigin], [TyVar], [TcType], DerivInstTys)+inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_tc_args = tc_args+ , dit_rep_tc = rep_tc+ , dit_rep_tc_args = rep_tc_args }) = do DerivEnv { denv_tvs = tvs , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask@@ -176,21 +179,35 @@ :: (CtOrigin -> TypeOrKind -> Type -> [([PredOrigin], Maybe TCvSubst)])- -> ([ThetaOrigin], [TyVar], [TcType])+ -> ([ThetaOrigin], [TyVar], [TcType], DerivInstTys) con_arg_constraints get_arg_constraints- = let (predss, mbSubsts) = unzip+ = let -- Constraints from the fields of each data constructor.+ (predss, mbSubsts) = unzip [ preds_and_mbSubst | data_con <- tyConDataCons rep_tc , (arg_n, arg_t_or_k, arg_ty) <- zip3 [1..] t_or_ks $- dataConInstOrigArgTys data_con all_rep_tc_args+ derivDataConInstArgTys data_con dit -- No constraints for unlifted types -- See Note [Deriving and unboxed types]- , not (isUnliftedType (irrelevantMult arg_ty))+ , not (isUnliftedType arg_ty) , let orig = DerivOriginDC data_con arg_n wildcard , preds_and_mbSubst- <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty)+ <- get_arg_constraints orig arg_t_or_k arg_ty ]+ -- Stupid constraints from DatatypeContexts. Note that we+ -- must gather these constraints from the data constructors,+ -- not from the parent type constructor, as the latter could+ -- lead to redundant constraints due to thinning.+ -- See Note [The stupid context] in GHC.Core.DataCon.+ stupid_theta =+ [ substTyWith (dataConUnivTyVars data_con)+ (dataConInstUnivs data_con rep_tc_args)+ stupid_pred+ | data_con <- tyConDataCons rep_tc+ , stupid_pred <- dataConStupidTheta data_con+ ]+ preds = concat predss -- If the constraints require a subtype to be of kind -- (* -> *) (which is the case for functor-like@@ -202,10 +219,14 @@ unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst && not (v `isInScope` subst)) tvs (subst', _) = substTyVarBndrs subst unmapped_tvs+ stupid_theta_origin = mkThetaOrigin deriv_origin TypeLevel [] [] [] $+ substTheta subst' stupid_theta preds' = map (substPredOrigin subst') preds inst_tys' = substTys subst' inst_tys+ dit' = substDerivInstTys subst' dit tvs' = tyCoVarsOfTypesWellScoped inst_tys'- in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')+ in ( [stupid_theta_origin, mkThetaOriginFromPreds preds']+ , tvs', inst_tys', dit' ) is_generic = main_cls `hasKey` genClassKey is_generic1 = main_cls `hasKey` gen1ClassKey@@ -253,24 +274,7 @@ rep_tc_tvs = tyConTyVars rep_tc last_tv = last rep_tc_tvs- -- When we first gather up the constraints to solve, most of them- -- contain rep_tc_tvs, i.e., the type variables from the derived- -- datatype's type constructor. We don't want these type variables- -- to appear in the final instance declaration, so we must- -- substitute each type variable with its counterpart in the derived- -- instance. rep_tc_args lists each of these counterpart types in- -- the same order as the type variables.- all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args - -- Stupid constraints- stupid_constraints- = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $- substTheta tc_subst (tyConStupidTheta rep_tc) ]- tc_subst = -- See the comment with all_rep_tc_args for an- -- explanation of this assertion- assert (equalLength rep_tc_tvs all_rep_tc_args) $- zipTvSubst rep_tc_tvs all_rep_tc_args- -- Extra Data constraints -- The Data class (only) requires that for -- instance (...) => Data (T t1 t2)@@ -302,7 +306,7 @@ if -- Generic constraints are easy | is_generic- -> return ([], tvs, inst_tys)+ -> return ([], tvs, inst_tys, dit) -- Generic1 needs Functor -- See Note [Getting base classes]@@ -316,20 +320,14 @@ -- The others are a bit more complicated | otherwise- -> -- See the comment with all_rep_tc_args for an explanation of- -- this assertion- assertPpr (equalLength rep_tc_tvs all_rep_tc_args)- ( ppr main_cls <+> ppr rep_tc- $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args) $- do { let (arg_constraints, tvs', inst_tys')- = con_arg_constraints get_std_constrained_tys- ; lift $ traceTc "inferConstraintsStock" $ vcat- [ ppr main_cls <+> ppr inst_tys'- , ppr arg_constraints- ]- ; return ( stupid_constraints ++ extra_constraints- ++ arg_constraints- , tvs', inst_tys') }+ -> do { let (arg_constraints, tvs', inst_tys', dit')+ = con_arg_constraints get_std_constrained_tys+ ; lift $ traceTc "inferConstraintsStock" $ vcat+ [ ppr main_cls <+> ppr inst_tys'+ , ppr arg_constraints+ ]+ ; return ( extra_constraints ++ arg_constraints+ , tvs', inst_tys', dit' ) } -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, -- which gathers its constraints based on the type signatures of the class's
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -4,12 +4,13 @@ -} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} -- | Error-checking and other utilities for @deriving@ clauses or declarations. module GHC.Tc.Deriv.Utils ( DerivM, DerivEnv(..),- DerivSpec(..), pprDerivSpec, DerivInstTys(..),+ DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, DerivContext(..), OriginativeDerivStatus(..),@@ -50,7 +51,6 @@ import GHC.Tc.Utils.TcType import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon-import GHC.Core.Multiplicity import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var.Set@@ -179,35 +179,6 @@ instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec --- | Information about the arguments to the class in a stock- or--- newtype-derived instance.--- See @Note [DerivEnv and DerivSpecMechanism]@.-data DerivInstTys = DerivInstTys- { dit_cls_tys :: [Type]- -- ^ Other arguments to the class except the last- , dit_tc :: TyCon- -- ^ Type constructor for which the instance is requested- -- (last arguments to the type class)- , dit_tc_args :: [Type]- -- ^ Arguments to the type constructor- , dit_rep_tc :: TyCon- -- ^ The representation tycon for 'dit_tc'- -- (for data family instances). Otherwise the same as 'dit_tc'.- , dit_rep_tc_args :: [Type]- -- ^ The representation types for 'dit_tc_args'- -- (for data family instances). Otherwise the same as 'dit_tc_args'.- }--instance Outputable DerivInstTys where- ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args- , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })- = hang (text "DITTyConHead")- 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys- , text "dit_tc" <+> ppr tc- , text "dit_tc_args" <+> ppr tc_args- , text "dit_rep_tc" <+> ppr rep_tc- , text "dit_rep_tc_args" <+> ppr rep_tc_args ])- -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as -- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".@@ -219,9 +190,8 @@ -- instance, including what type constructor the last argument is -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. , dsm_stock_gen_fn ::- SrcSpan -> TyCon -- dit_rep_tc- -> [Type] -- dit_rep_tc_args- -> [Type] -- inst_tys+ SrcSpan -> [Type] -- inst_tys+ -> DerivInstTys -- dsm_stock_dit -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) -- ^ This function returns four things: --@@ -333,13 +303,16 @@ This extra structure is witnessed by the DerivInstTys data type, which stores arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor- (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type- constructor, then dit_rep_tc/dit_rep_tc_args are the same as- dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then- dit_rep_tc is the representation type constructor for the data family- instance, and dit_rep_tc_args are the arguments to the representation type- constructor in the corresponding instance.+ (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen+ as a more structured representation of the denv_inst_tys field of DerivEnv. + If dit_tc is an ordinary data type constructor, then+ dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a+ data family type constructor, then dit_rep_tc is the representation type+ constructor for the data family instance, and dit_rep_tc_args are the+ arguments to the representation type constructor in the corresponding+ instance.+ * newtype (DerivSpecNewtype): Newtype deriving imposes the same DerivInstTys requirements as stock@@ -429,7 +402,7 @@ -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus = CanDeriveStock -- Stock class, can derive- (SrcSpan -> TyCon -> [Type] -> [Type]+ (SrcSpan -> [Type] -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class]@@ -565,18 +538,16 @@ hasStockDeriving :: Class -> Maybe (SrcSpan- -> TyCon -> [Type]- -> [Type]+ -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) hasStockDeriving clas = assocMaybe gen_list (getUnique clas) where gen_list :: [(Unique, SrcSpan- -> TyCon -> [Type]- -> [Type]+ -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))] gen_list = [ (eqClassKey, simpleM gen_Eq_binds) , (ordClassKey, simpleM gen_Ord_binds)@@ -593,27 +564,28 @@ , (genClassKey, generic (gen_Generic_binds Gen0)) , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - simple gen_fn loc tc tc_args _- = let (binds, deriv_stuff) = gen_fn loc tc tc_args+ simple gen_fn loc _ dit+ = let (binds, deriv_stuff) = gen_fn loc dit in return (binds, [], deriv_stuff, []) -- Like `simple`, but monadic. The only monadic thing that these functions -- do is allocate new Uniques, which are used for generating the names of -- auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.- simpleM gen_fn loc tc tc_args _- = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args+ simpleM gen_fn loc _ dit+ = do { (binds, deriv_stuff) <- gen_fn loc dit ; return (binds, [], deriv_stuff, []) } - read_or_show gen_fn loc tc tc_args _- = do { fix_env <- getDataConFixityFun tc- ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args+ read_or_show gen_fn loc _ dit+ = do { let tc = dit_rep_tc dit+ ; fix_env <- getDataConFixityFun tc+ ; let (binds, deriv_stuff) = gen_fn fix_env loc dit field_names = all_field_names tc ; return (binds, [], deriv_stuff, field_names) } - generic gen_fn _ tc _ inst_tys- = do { (binds, sigs, faminst) <- gen_fn tc inst_tys- ; let field_names = all_field_names tc+ generic gen_fn _ inst_tys dit+ = do { (binds, sigs, faminst) <- gen_fn inst_tys dit+ ; let field_names = all_field_names (dit_rep_tc dit) ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) } -- See Note [Deriving and unused record selectors]@@ -679,34 +651,36 @@ -- the data constructors - but we need to be careful to fall back to the -- family tycon (with indexes) in error messages. -checkOriginativeSideConditions- :: DynFlags -> DerivContext -> Class -> [TcType]- -> TyCon -> TyCon- -> OriginativeDerivStatus-checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc- -- First, check if stock deriving is possible...- | Just cond <- stockSideConditions deriv_ctxt cls- = case (cond dflags tc rep_tc) of- NotValid err -> StockClassError err -- Class-specific error- IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)- -- All stock derivable classes are unary in the sense that- -- there should be not types in cls_tys (i.e., no type args- -- other than last). Note that cls_types can contain- -- invisible types as well (e.g., for Generic1, which is- -- poly-kinded), so make sure those are not counted.- , Just gen_fn <- hasStockDeriving cls- -> CanDeriveStock gen_fn- | otherwise -> StockClassError (classArgsErr cls cls_tys)- -- e.g. deriving( Eq s )+checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus+checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) =+ do DerivEnv { denv_cls = cls+ , denv_ctxt = deriv_ctxt } <- ask+ dflags <- getDynFlags - -- ...if not, try falling back on DeriveAnyClass.- | xopt LangExt.DeriveAnyClass dflags- = CanDeriveAnyClass -- DeriveAnyClass should work+ if -- First, check if stock deriving is possible...+ | Just cond <- stockSideConditions deriv_ctxt cls+ -> case cond dflags dit of+ NotValid err -> pure $ StockClassError err -- Class-specific error+ IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)+ -- All stock derivable classes are unary in the sense that+ -- there should be not types in cls_tys (i.e., no type args+ -- other than last). Note that cls_types can contain+ -- invisible types as well (e.g., for Generic1, which is+ -- poly-kinded), so make sure those are not counted.+ , Just gen_fn <- hasStockDeriving cls+ -> pure $ CanDeriveStock gen_fn+ | otherwise+ -> pure $ StockClassError $ classArgsErr cls cls_tys+ -- e.g. deriving( Eq s ) - | otherwise- = NonDerivableClass -- Neither anyclass nor stock work+ -- ...if not, try falling back on DeriveAnyClass.+ | xopt LangExt.DeriveAnyClass dflags+ -> pure CanDeriveAnyClass -- DeriveAnyClass should work + | otherwise+ -> pure NonDerivableClass -- Neither anyclass nor stock work + classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys) @@ -758,20 +732,16 @@ type Condition = DynFlags - -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the- -- family 'TyCon'.-- -> TyCon -- ^ For data families, this is the representation 'TyCon'.- -- Otherwise, this is the same as the other 'TyCon' argument.+ -> DerivInstTys -- ^ Information about the type arguments to the class. -> Validity' DeriveInstanceErrReason- -- ^ 'IsValid' if deriving an instance for this 'TyCon' is+ -- ^ 'IsValid' if deriving an instance for this type is -- possible. Otherwise, it's @'NotValid' err@, where @err@ -- explains what went wrong. andCond :: Condition -> Condition -> Condition-andCond c1 c2 dflags tc rep_tc- = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc+andCond c1 c2 dflags dit+ = c1 dflags dit `andValid` c2 dflags dit -- | Some common validity checks shared among stock derivable classes. One -- check that absolutely must hold is that if an instance @C (T a)@ is being@@ -801,7 +771,8 @@ -- the -XEmptyDataDeriving extension. -> Condition-cond_stdOK deriv_ctxt permissive dflags tc rep_tc+cond_stdOK deriv_ctxt permissive dflags+ dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc}) = valid_ADT `andValid` valid_misc where valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason@@ -822,7 +793,7 @@ InferContext wildcard | null data_cons -- 1. , not permissive- -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`+ -> checkFlag LangExt.EmptyDataDeriving dflags dit `orValid` NotValid (no_cons_why rep_tc) | not (null con_whys) -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys@@ -844,7 +815,7 @@ = bad DerivErrBadConHasExistentials | not (null theta) -- 4. = bad DerivErrBadConHasConstraints- | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5.+ | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5. = bad DerivErrBadConHasHigherRankType | otherwise = IsValid@@ -856,14 +827,14 @@ no_cons_why = DerivErrNoConstructors cond_RepresentableOk :: Condition-cond_RepresentableOk _ _ rep_tc =- case canDoGenerics rep_tc of+cond_RepresentableOk _ dit =+ case canDoGenerics dit of IsValid -> IsValid NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs cond_Representable1Ok :: Condition-cond_Representable1Ok _ _ rep_tc =- case canDoGenerics1 rep_tc of+cond_Representable1Ok _ dit =+ case canDoGenerics1 dit of IsValid -> IsValid NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs @@ -872,8 +843,8 @@ (cond_isProduct `andCond` cond_args cls) where orCond :: Condition -> Condition -> Condition- orCond c1 c2 dflags tc rep_tc- = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of+ orCond c1 c2 dflags dit+ = case (c1 dflags dit, c2 dflags dit) of (IsValid, _) -> IsValid -- c1 succeeds (_, IsValid) -> IsValid -- c21 succeeds (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y@@ -885,13 +856,13 @@ -- by generating specialised code. For others (eg 'Data') we don't. -- For even others (eg 'Lift'), unlifted types aren't even a special -- consideration!-cond_args cls _ _ rep_tc+cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc}) = case bad_args of [] -> IsValid (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty where bad_args = [ arg_ty | con <- tyConDataCons rep_tc- , Scaled _ arg_ty <- dataConOrigArgTys con+ , arg_ty <- derivDataConInstArgTys con dit , isLiftedType_maybe arg_ty /= Just True , not (ok_ty arg_ty) ] @@ -908,12 +879,12 @@ cond_isEnumeration :: Condition-cond_isEnumeration _ _ rep_tc+cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc}) | isEnumerationTyCon rep_tc = IsValid | otherwise = NotValid $ DerivErrMustBeEnumType rep_tc cond_isProduct :: Condition-cond_isProduct _ _ rep_tc+cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc}) | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid | otherwise@@ -926,10 +897,14 @@ -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) -- (d) optionally: don't use function types -- (e) no "stupid context" on data type-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _+ dit@(DerivInstTys{dit_rep_tc = rep_tc}) | null tc_tvs = NotValid $ DerivErrMustHaveSomeParameters rep_tc + -- We can't handle stupid contexts that mention the last type argument,+ -- so error out if we encounter one.+ -- See Note [The stupid context] in GHC.Core.DataCon. | not (null bad_stupid_theta) = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta @@ -943,7 +918,7 @@ -- See Note [Check that the type variable is truly universal] data_cons = tyConDataCons rep_tc- check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)+ check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit) check_universal :: DataCon -> Validity' DeriveInstanceErrReason check_universal con@@ -969,7 +944,7 @@ checkFlag :: LangExt.Extension -> Condition-checkFlag flag dflags _ _+checkFlag flag dflags _ | xopt flag dflags = IsValid | otherwise = NotValid why where
compiler/GHC/Tc/Errors.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -85,7 +86,9 @@ import Data.Foldable ( toList ) import Data.Functor ( (<&>) ) import Data.Function ( on )-import Data.List ( partition, mapAccumL, sortBy, unfoldr )+import Data.List ( groupBy, partition, mapAccumL+ , sortBy, tails, unfoldr )+import Data.Ord ( comparing ) -- import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -1028,11 +1031,11 @@ pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message--- We've done special processing for TypeEq, KindEq, Given-pprArising (TypeEqOrigin {}) = empty-pprArising (KindEqOrigin {}) = empty-pprArising (GivenOrigin {}) = empty-pprArising orig = pprCtOrigin orig+-- We've done special processing for TypeEq, KindEq, givens+pprArising (TypeEqOrigin {}) = empty+pprArising (KindEqOrigin {}) = empty+pprArising orig | isGivenOrigin orig = empty+ | otherwise = pprCtOrigin orig -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc@@ -2615,16 +2618,13 @@ potential_msg = ppWhen (not (null unifiers) && want_potential orig) $- sdocOption sdocPrintPotentialInstances $ \print_insts ->- getPprStyle $ \sty ->- pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers+ potential_hdr $$+ potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) potential_hdr- = vcat [ ppWhen lead_with_ambig $- text "Probable fix: use a type annotation to specify what"- <+> pprQuotedList ambig_tvs <+> text "should be."- , thisOrThese unifiers <+> text "potential instance" <> plural unifiers- <+> text "exist" <> singular unifiers <> text ":"]+ = ppWhen lead_with_ambig $+ text "Probable fix: use a type annotation to specify what"+ <+> pprQuotedList ambig_tvs <+> text "should be." mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov@@ -2676,10 +2676,8 @@ sep [text "Matching givens (or their superclasses):" , nest 2 (vcat matching_givens)] - , sdocOption sdocPrintPotentialInstances $ \print_insts ->- getPprStyle $ \sty ->- pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $- ispecs ++ unifiers+ , potentialInstancesErrMsg+ (PotentialInstances { matches = map fst matches, unifiers }) , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ -- Intuitively, some given matched the wanted in their@@ -2907,36 +2905,88 @@ , nest 2 (vcat (f : map (text "or" <+>) fs))] --- Avoid boolean blindness-newtype PrintPotentialInstances = PrintPotentialInstances Bool+-- | This datatype collates instances that match or unifier,+-- in order to report an error message for an unsolved typeclass constraint.+data PotentialInstances+ = PotentialInstances+ { matches :: [ClsInst]+ , unifiers :: [ClsInst]+ } -pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc+-- | Directly display the given matching and unifying instances,+-- with a header for each: `Matching instances`/`Potentially matching instances`.+pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc+pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) =+ vcat+ [ ppWhen (not $ null matches) $+ text "Matching instance" <> plural matches <> colon $$+ nest 2 (vcat (map ppr_inst matches))+ , ppWhen (not $ null unifiers) $+ (text "Potentially matching instance" <> plural unifiers <> colon) $$+ nest 2 (vcat (map ppr_inst unifiers))+ ]++-- | Display a summary of available instances, omitting those involving+-- out-of-scope types, in order to explain why we couldn't solve a particular+-- constraint, e.g. due to instance overlap or out-of-scope types.+--+-- To directly display a collection of matching/unifying instances,+-- use 'pprPotentialInstances'.+potentialInstancesErrMsg :: PotentialInstances -> SDoc -- See Note [Displaying potential instances]-pprPotentials (PrintPotentialInstances show_potentials) sty herald insts- | null insts+potentialInstancesErrMsg potentials =+ sdocOption sdocPrintPotentialInstances $ \print_insts ->+ getPprStyle $ \sty ->+ potentials_msg_with_options potentials print_insts sty++-- | Display a summary of available instances, omitting out-of-scope ones.+--+-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing+-- options.+potentials_msg_with_options :: PotentialInstances+ -> Bool -- ^ Whether to print /all/ potential instances+ -> PprStyle+ -> SDoc+potentials_msg_with_options+ (PotentialInstances { matches, unifiers })+ show_all_potentials sty+ | null matches && null unifiers = empty - | null show_these- = hang herald- 2 (vcat [ not_in_scope_msg empty- , flag_hint ])+ | null show_these_matches && null show_these_unifiers+ = vcat [ not_in_scope_msg empty+ , flag_hint ] | otherwise- = hang herald- 2 (vcat [ pprInstances show_these- , ppWhen (n_in_scope_hidden > 0) $- text "...plus"- <+> speakNOf n_in_scope_hidden (text "other")- , not_in_scope_msg (text "...plus")- , flag_hint ])+ = vcat [ pprPotentialInstances+ pprInstance -- print instance + location info+ (PotentialInstances+ { matches = show_these_matches+ , unifiers = show_these_unifiers })+ , overlapping_but_not_more_specific_msg sorted_matches+ , nest 2 $ vcat+ [ ppWhen (n_in_scope_hidden > 0) $+ text "...plus"+ <+> speakNOf n_in_scope_hidden (text "other")+ , ppWhen (not_in_scopes > 0) $+ not_in_scope_msg (text "...plus")+ , flag_hint ] ] where- n_show = 3 :: Int+ n_show_matches, n_show_unifiers :: Int+ n_show_matches = 3+ n_show_unifiers = 2 - (in_scope, not_in_scope) = partition inst_in_scope insts- sorted = sortBy fuzzyClsInstCmp in_scope- show_these | show_potentials = sorted- | otherwise = take n_show sorted- n_in_scope_hidden = length sorted - length show_these+ (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches+ (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers+ sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches+ sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers+ (show_these_matches, show_these_unifiers)+ | show_all_potentials = (sorted_matches, sorted_unifiers)+ | otherwise = (take n_show_matches sorted_matches+ ,take n_show_unifiers sorted_unifiers)+ n_in_scope_hidden+ = length sorted_matches + length sorted_unifiers+ - length show_these_matches - length show_these_unifiers -- "in scope" means that all the type constructors -- are lexically in scope; these instances are likely@@ -2958,16 +3008,72 @@ qual_in_scope (NameQual {}) = True qual_in_scope _ = False - not_in_scope_msg herald- | null not_in_scope- = empty- | otherwise- = hang (herald <+> speakNOf (length not_in_scope) (text "instance")+ not_in_scopes :: Int+ not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers++ not_in_scope_msg herald =+ hang (herald <+> speakNOf not_in_scopes (text "instance") <+> text "involving out-of-scope types")- 2 (ppWhen show_potentials (pprInstances not_in_scope))+ 2 (ppWhen show_all_potentials $+ pprPotentialInstances+ pprInstanceHdr -- only print the header, not the instance location info+ (PotentialInstances+ { matches = not_in_scope_matches+ , unifiers = not_in_scope_unifiers+ })) - flag_hint = ppUnless (show_potentials || equalLength show_these insts) $+ flag_hint = ppUnless (show_all_potentials+ || (equalLength show_these_matches matches+ && equalLength show_these_unifiers unifiers)) $ text "(use -fprint-potential-instances to see them all)"++-- | Compute a message informing the user of any instances that are overlapped+-- but were not discarded because the instance overlapping them wasn't+-- strictly more specific.+overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc+overlapping_but_not_more_specific_msg insts+ -- Only print one example of "overlapping but not strictly more specific",+ -- to avoid information overload.+ | overlap : _ <- overlapping_but_not_more_specific+ = overlap_header $$ ppr_overlapping overlap+ | otherwise+ = empty+ where+ overlap_header :: SDoc+ overlap_header+ | [_] <- overlapping_but_not_more_specific+ = text "An overlapping instance can only be chosen when it is strictly more specific."+ | otherwise+ = text "Overlapping instances can only be chosen when they are strictly more specific."+ overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]+ overlapping_but_not_more_specific+ = nubOrdBy (comparing (is_dfun . fst))+ [ (overlapper, overlappee)+ | these <- groupBy ((==) `on` is_cls_nm) insts+ -- Take all pairs of distinct instances...+ , one:others <- tails these -- if `these = [inst_1, inst_2, ...]`+ , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j`+ -- ... such that one instance in the pair overlaps the other...+ , let mb_overlapping+ | hasOverlappingFlag (overlapMode $ is_flag one)+ || hasOverlappableFlag (overlapMode $ is_flag other)+ = [(one, other)]+ | hasOverlappingFlag (overlapMode $ is_flag other)+ || hasOverlappableFlag (overlapMode $ is_flag one)+ = [(other, one)]+ | otherwise+ = []+ , (overlapper, overlappee) <- mb_overlapping+ -- ... but the overlapper is not more specific than the overlappee.+ , not (overlapper `more_specific_than` overlappee)+ ]+ more_specific_than :: ClsInst -> ClsInst -> Bool+ is1 `more_specific_than` is2+ = isJust (tcMatchTys (is_tys is1) (is_tys is2))+ ppr_overlapping :: (ClsInst, ClsInst) -> SDoc+ ppr_overlapping (overlapper, overlappee)+ = text "The first instance that follows overlaps the second, but is not more specific than it:"+ $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) {- Note [Displaying potential instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Errors/Hole.hs view
@@ -484,12 +484,10 @@ hang display 2 provenance where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap where pprArg b arg = case binderArgFlag b of- -- See Note [Explicit Case Statement for Specificity]- (Invisible spec) -> case spec of- SpecifiedSpec -> text "@" <> pprParendType arg+ Specified -> text "@" <> pprParendType arg -- Do not print type application for inferred -- variables (#16456)- InferredSpec -> empty+ Inferred -> empty Required -> pprPanic "pprHoleFit: bad Required" (ppr b <+> ppr arg) tyAppVars = sep $ punctuate comma $
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -98,7 +98,7 @@ ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 -- start with the names as they are used to desugar the proc itself -- See #17423- ; names' <- setSrcSpan loc $+ ; names' <- setSrcSpanA loc $ mapM (tcSyntaxName ProcOrigin arr_ty) names ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- newArrowScope@@ -136,7 +136,7 @@ -> TcM (LHsCmdTop GhcTc) tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)- = setSrcSpan loc $+ = setSrcSpanA loc $ do { cmd' <- tcCmd env cmd cmd_ty ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') } @@ -154,11 +154,11 @@ = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x lpar cmd' rpar) } -tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty+tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan (locA body_loc) $ tc_cmd env body res_ty- ; return (HsCmdLet x binds' (L body_loc body')) }+ ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do@@ -301,7 +301,7 @@ tc_grhss (GRHSs x grhss binds) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $- mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss+ mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs x grhss' binds') } tc_grhs stk_ty res_ty (GRHS x guards body)@@ -349,7 +349,7 @@ = do { arr_ty <- newFlexiTyVarTy arrowTyConKind ; stk_ty <- newFlexiTyVarTy liftedTypeKind ; res_ty <- newFlexiTyVarTy liftedTypeKind- ; names' <- setSrcSpan loc $+ ; names' <- setSrcSpanA loc $ mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names ; let env' = env { cmd_arr = arr_ty } ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
compiler/GHC/Tc/Gen/Expr.hs view
@@ -366,10 +366,10 @@ ************************************************************************ -} -tcExpr (HsLet x binds expr) res_ty+tcExpr (HsLet x tkLet binds tkIn expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty- ; return (HsLet x binds' expr') }+ ; return (HsLet x tkLet binds' tkIn expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first.@@ -406,7 +406,7 @@ ; return (HsIf x pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty- = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+ = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }@@ -790,7 +790,8 @@ -- Typecheck the bindings ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - -- STEP 6: Deal with the stupid theta+ -- STEP 6: Deal with the stupid theta.+ -- See Note [The stupid context] in GHC.Core.DataCon. ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) ; instStupidTheta RecordUpdOrigin theta' @@ -880,7 +881,7 @@ tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)-tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty)+tcExpr (HsTcBracketOut x _ _ _) _ = dataConCantHappen x {-@@ -1269,7 +1270,7 @@ -- (giving duplicate deprecation warnings). Just gre -> do { unless (null (tail xs)) $ do let L loc _ = hfbLHS (unLoc upd)- setSrcSpan loc $ addUsedGRE True gre+ setSrcSpanA loc $ addUsedGRE True gre ; lookupSelector (upd, greMangledName gre) } -- The field doesn't belong to this parent, so report -- an error but keep going through all the fields@@ -1285,12 +1286,10 @@ = do { i <- tcLookupId n ; let L loc af = hfbLHS upd lbl = rdrNameAmbiguousFieldOcc af- -- ; return $ L l upd { hfbLHS- -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) } ; return $ L l HsFieldBind { hfbAnn = hfbAnn upd , hfbLHS- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))+ = L (l2l loc) (Unambiguous i (L (l2l loc) lbl)) , hfbRHS = hfbRHS upd , hfbPun = hfbPun upd }@@ -1368,7 +1367,7 @@ , hfbRHS = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af- f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl))+ f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing@@ -1377,7 +1376,7 @@ (L l (fld { hfbLHS = L loc (Unambiguous (foExt (unLoc f'))- (L (noAnnSrcSpan loc) lbl))+ (L (l2l loc) lbl)) , hfbRHS = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type@@ -1392,7 +1391,7 @@ field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name)- Many field_ty loc+ Many field_ty (locA loc) -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS
compiler/GHC/Tc/Gen/Head.hs view
@@ -483,7 +483,7 @@ = do { thing <- tcLookup sel_name ; case thing of ATcId { tct_id = id }- -> do { check_naughty occ id+ -> do { check_naughty occ id -- See Note [Local record selectors] ; check_local_id id ; return id } @@ -905,7 +905,9 @@ Note [Instantiating stupid theta] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a data type with a "stupid theta":+Consider a data type with a "stupid theta" (see+Note [The stupid context] in GHC.Core.DataCon):+ data Ord a => T a = MkT (Maybe a) We want to generate an Ord constraint for every use of MkT; but@@ -1032,11 +1034,11 @@ If this check fails (which isn't impossible) we get another chance; see Note [Converting strings] in Convert.hs -Local record selectors-~~~~~~~~~~~~~~~~~~~~~~+Note [Local record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record selectors for TyCons in this module are ordinary local bindings, which show up as ATcIds rather than AGlobals. So we need to check for-naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.+naughtiness in both branches. c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. -}
compiler/GHC/Tc/Gen/HsType.hs view
@@ -641,7 +641,7 @@ = case mb_lds of Nothing -> boring_case Nothing Just (L loc ds) ->- setSrcSpan loc $ do+ setSrcSpanA loc $ do (ds', tvs) <- tc_deriv_strategy ds pure (Just (L loc ds'), tvs) where@@ -2396,7 +2396,7 @@ candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } inf_candidates = candidates `delCandidates` spec_req_tkvs - ; inferred <- quantifyTyVars allVarsOfKindDefault inf_candidates+ ; inferred <- quantifyTyVars DefaultNonStandardTyVars inf_candidates -- NB: 'inferred' comes back sorted in dependency order ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs@@ -3505,7 +3505,7 @@ -- thus, every free variable is really a kv, never a tv. ; dvs <- candidateQTyVarsOfKind kind_or_type ; dvs <- filterConstrainedCandidates wanted dvs- ; quantifyTyVars allVarsOfKindDefault dvs }+ ; quantifyTyVars DefaultNonStandardTyVars dvs } filterConstrainedCandidates :: WantedConstraints -- Don't quantify over variables free in these@@ -3533,7 +3533,7 @@ kindGeneralizeAll kind_or_type = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) ; dvs <- candidateQTyVarsOfKind kind_or_type- ; quantifyTyVars allVarsOfKindDefault dvs }+ ; quantifyTyVars DefaultNonStandardTyVars dvs } -- | Specialized version of 'kindGeneralizeSome', but where no variables -- can be generalized, but perhaps some may need to be promoted.
compiler/GHC/Tc/Gen/Match.hs view
@@ -205,8 +205,8 @@ , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL- , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan- , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+ , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA )@@ -289,7 +289,7 @@ tcGRHSs ctxt (GRHSs _ grhss binds) res_ty = do { (binds', ugrhss) <- tcLocalBinds binds $- mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss+ mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss ; let (usages, grhss') = unzip ugrhss ; tcEmitBindingUsage $ supUEs usages ; return (GRHSs emptyComments grhss' binds') }
compiler/GHC/Tc/Gen/Pat.hs view
@@ -868,6 +868,19 @@ pat_ty arg_pats thing_inside } +-- Warn when pattern matching on a GADT or a pattern synonym+-- when MonoLocalBinds is off.+warnMonoLocalBinds :: TcM ()+warnMonoLocalBinds+ = do { mono_local_binds <- xoptM LangExt.MonoLocalBinds+ ; unless mono_local_binds $+ addDiagnostic TcRnGADTMonoLocalBinds+ -- We used to require the GADTs or TypeFamilies extension+ -- to pattern match on a GADT (#2905, #7156)+ --+ -- In #20485 this was made into a warning.+ }+ tcDataConPat :: PatEnv -> LocatedN Name -> DataCon -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a@@ -940,21 +953,12 @@ { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta'- no_equalities = null eq_spec && not (any isEqPred theta) skol_info = PatSkol (RealDataCon data_con) mc mc = case pe_ctxt penv of LamPat mc -> mc LetPat {} -> PatBindRhs - ; gadts_on <- xoptM LangExt.GADTs- ; families_on <- xoptM LangExt.TypeFamilies- ; checkTc (no_equalities || gadts_on || families_on)- (TcRnUnknownMessage $ mkPlainError noHints $- text "A pattern match on a GADT requires the" <+>- text "GADTs or TypeFamilies language extension")- -- #2905 decided that a *pattern-match* of a GADT- -- should require the GADT language flag.- -- Re TypeFamilies see also #7156+ ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res))@@ -999,6 +1003,8 @@ prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta + ; when (any isEqPred prov_theta) warnMonoLocalBinds+ ; mult_wrap <- checkManyPattern pat_ty -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. @@ -1258,7 +1264,7 @@ (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel- ; pat_ty <- setSrcSpan loc $ find_field_ty sel+ ; pat_ty <- setSrcSpanA loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'@@ -1311,7 +1317,8 @@ addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw--- the constraints into the constraint set+-- the constraints into the constraint set.+-- See Note [The stupid context] in GHC.Core.DataCon. addDataConStupidTheta data_con inst_tys | null stupid_theta = return () | otherwise = instStupidTheta origin inst_theta
compiler/GHC/Tc/Gen/Rule.hs view
@@ -30,7 +30,7 @@ import GHC.Types.Id import GHC.Types.Var( EvVar ) import GHC.Types.Var.Set-import GHC.Types.Basic ( RuleName, allVarsOfKindDefault )+import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -151,7 +151,7 @@ -- See Note [Re-quantify type variables in rules] ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)- ; qtkvs <- quantifyTyVars allVarsOfKindDefault forall_tkvs+ ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars forall_tkvs ; traceTc "tcRule" (vcat [ pprFullRuleName rname , ppr forall_tkvs , ppr qtkvs@@ -175,7 +175,7 @@ , rd_name = rname , rd_act = act , rd_tyvs = ty_bndrs -- preserved for ppr-ing- , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA)+ , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA) (qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } }
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -48,7 +48,6 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class (lift) import Data.Maybe ( isJust )-import Data.Word( Word64 ) {- Note [Grand plan for Typeable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -641,11 +640,11 @@ -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep = nlHsDataCon trTyConDataCon- `nlHsApp` nlHsLit (word64 platform high)- `nlHsApp` nlHsLit (word64 platform low)+ `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger high))+ `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger low)) `nlHsApp` mod_rep_expr todo `nlHsApp` trNameLit (mkFastString tycon_str)- `nlHsApp` nlHsLit (int n_kind_vars)+ `nlHsApp` nlHsLit (HsIntPrim NoSourceText (toInteger n_kind_vars)) `nlHsApp` kind_rep where n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)@@ -659,14 +658,6 @@ , mod_fingerprint todo , fingerprintString tycon_str ]-- int :: Int -> HsLit GhcTc- int n = HsIntPrim (SourceText $ show n) (toInteger n)--word64 :: Platform -> Word64 -> HsLit GhcTc-word64 platform n = case platformWordSize platform of- PW4 -> HsWord64Prim NoSourceText (toInteger n)- PW8 -> HsWordPrim NoSourceText (toInteger n) {- Note [Representing TyCon kinds: KindRep]
compiler/GHC/Tc/Module.hs view
@@ -27,6 +27,8 @@ tcRnDeclsi, isGHCiMonad, runTcInteractive, -- Used by GHC API clients (#8878)+ withTcPlugins, -- Used by GHC API clients (#20499)+ withHoleFitPlugins, -- Used by GHC API clients (#20499) tcRnLookupName, tcRnGetInfo, tcRnModule, tcRnModuleTcRnM,@@ -2706,7 +2708,7 @@ reverse :: forall a. [a] -> [a] -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String- > :type +v foo @Int+ > :type foo @Int forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String Note that Show Int is still reported, because the solver never got a chance
compiler/GHC/Tc/Plugin.hs view
@@ -73,6 +73,7 @@ , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var ( EvVar ) +import GHC.Unit.Env import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( OccName, Name ) import GHC.Types.TyThing ( TyThing )@@ -81,7 +82,7 @@ import GHC.Core.DataCon ( DataCon ) import GHC.Core.Class ( Class ) import GHC.Driver.Config.Finder ( initFinderOpts )-import GHC.Driver.Env ( HscEnv(..), hsc_home_unit, hsc_units )+import GHC.Driver.Env ( HscEnv(..), hsc_units ) import GHC.Utils.Outputable ( SDoc ) import GHC.Core.Type ( Kind, Type, PredType ) import GHC.Types.Id ( Id )@@ -102,12 +103,12 @@ findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv- let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags- tcPluginIO $ Finder.findImportedModule fc fopts units home_unit mod_name mb_pkg+ let fc = hsc_FC hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ let units = hsc_units hsc_env+ let dflags = hsc_dflags hsc_env+ let fopts = initFinderOpts dflags+ tcPluginIO $ Finder.findImportedModule fc fopts units mhome_unit mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
compiler/GHC/Tc/Solver.hs view
@@ -65,7 +65,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Basic ( IntWithInf, intGtLimit- , DefaultKindVars(..), allVarsOfKindDefault )+ , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) ) import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt @@ -1052,7 +1052,7 @@ , pred <- sig_inst_theta sig ] ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)- ; qtkvs <- quantifyTyVars allVarsOfKindDefault dep_vars+ ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1505,8 +1505,10 @@ = return False | otherwise = defaultTyVar- (if not poly_kinds && is_kind_var then DefaultKinds else Don'tDefaultKinds)- allVarsOfKindDefault+ (if not poly_kinds && is_kind_var+ then DefaultKindVars+ else NonStandardDefaulting DefaultNonStandardTyVars)+ -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. tv simplify_cand candidates@@ -1567,7 +1569,7 @@ , text "grown_tcvs =" <+> ppr grown_tcvs , text "dvs =" <+> ppr dvs_plus]) - ; quantifyTyVars allVarsOfKindDefault dvs_plus }+ ; quantifyTyVars DefaultNonStandardTyVars dvs_plus } ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet@@ -2053,19 +2055,28 @@ ; bad_telescope <- checkBadTelescope implic - ; let dead_givens | warnRedundantGivens info- = filterOut (`elemVarSet` need_inner) givens- | otherwise = [] -- None to report+ ; let (used_givens, unused_givens)+ | warnRedundantGivens info+ = partition (`elemVarSet` need_inner) givens+ | otherwise = (givens, []) -- None to report + minimal_used_givens = mkMinimalBySCs evVarPred used_givens+ is_minimal = (`elemVarSet` mkVarSet minimal_used_givens)++ warn_givens+ | not (null unused_givens) = unused_givens+ | warnRedundantGivens info = filterOut is_minimal used_givens+ | otherwise = []+ discard_entire_implication -- Can we discard the entire implication?- = null dead_givens -- No warning from this implication+ = null warn_givens -- No warning from this implication && not bad_telescope && isEmptyWC pruned_wc -- No live children && isEmptyVarSet need_outer -- No needed vars to pass up to parent final_status | bad_telescope = IC_BadTelescope- | otherwise = IC_Solved { ics_dead = dead_givens }+ | otherwise = IC_Solved { ics_dead = warn_givens } final_implic = implic { ic_status = final_status , ic_wanted = pruned_wc } @@ -2296,37 +2307,37 @@ With Opt_WarnRedundantConstraints, GHC can report which constraints of a type signature (or instance declaration) are redundant, and can be omitted. Here is an overview of how it-works:+works. +This is all tested in typecheck/should_compile/T20602 (among+others).+ ----- What is a redundant constraint? * The things that can be redundant are precisely the Given constraints of an implication. * A constraint can be redundant in two different ways:- a) It is implied by other givens. E.g.- f :: (Eq a, Ord a) => blah -- Eq a unnecessary- g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary- b) It is not needed by the Wanted constraints covered by the+ a) It is not needed by the Wanted constraints covered by the implication E.g. f :: Eq a => a -> Bool f x = True -- Equality not used+ b) It is implied by other givens. E.g.+ f :: (Eq a, Ord a) => blah -- Eq a unnecessary+ g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary -* To find (a), when we have two Given constraints,- we must be careful to drop the one that is a naked variable (if poss).- So if we have- f :: (Eq a, Ord a) => blah- then we may find [G] sc_sel (d1::Ord a) :: Eq a- [G] d2 :: Eq a- We want to discard d2 in favour of the superclass selection from- the Ord dictionary. This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther- See Note [Replacement vs keeping].+* To find (a) we need to know which evidence bindings are 'wanted';+ hence the eb_is_given field on an EvBind. -* To find (b) we need to know which evidence bindings are 'wanted';- hence the eb_is_given field on an EvBind.+* To find (b), we use mkMinimalBySCs on the Givens to see if any+ are unnecessary. ----- How tracking works +* When two Givens are the same, we drop the evidence for the one+ that requires more superclass selectors. This is done+ according to Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.+ * The ic_need fields of an Implic records in-scope (given) evidence variables bound by the context, that were needed to solve this implication (so far). See the declaration of Implication.@@ -2340,9 +2351,15 @@ * We compute which evidence variables are needed by an implication in setImplicationStatus. A variable is needed if a) it is free in the RHS of a Wanted EvBind,- b) it is free in the RHS of an EvBind whose LHS is needed,+ b) it is free in the RHS of an EvBind whose LHS is needed, or c) it is in the ics_need of a nested implication. +* After computing which variables are needed, we then look at the+ remaining variables for internal redundancies. This is case (b)+ from above. This is also done in setImplicationStatus.+ Note that we only look for case (b) if case (a) shows up empty,+ as exemplified below.+ * We need to be careful not to discard an implication prematurely, even one that is fully solved, because we might thereby forget which variables it needs, and hence wrongly@@ -2351,6 +2368,32 @@ simply has no free vars. This careful discarding is also handled in setImplicationStatus. +* Examples:++ f, g, h :: (Eq a, Ord a) => a -> Bool+ f x = x == x+ g x = x > x+ h x = x == x && x > x++ All three will discover that they have two [G] Eq a constraints:+ one as given and one extracted from the Ord a constraint. They will+ both discard the latter, as noted above and in+ Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.++ The body of f uses the [G] Eq a, but not the [G] Ord a. It will+ report a redundant Ord a using the logic for case (a).++ The body of g uses the [G] Ord a, but not the [G] Eq a. It will+ report a redundant Eq a using the logic for case (a).++ The body of h uses both [G] Ord a and [G] Eq a. Case (a) will+ thus come up with nothing redundant. But then, the case (b)+ check will discover that Eq a is redundant and report this.++ If we did case (b) even when case (a) reports something, then+ we would report both constraints as redundant for f, which is+ terrible.+ ----- Reporting redundant constraints * GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.@@ -2381,13 +2424,18 @@ ----- Shortcomings -Consider (see #9939)- f2 :: (Eq a, Ord a) => a -> a -> Bool- -- Ord a redundant, but Eq a is reported- f2 x y = (x == y)+Consider -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's-really not easy to detect that!+ j :: (Eq a, a ~ b) => a -> Bool+ j x = x == x++ k :: (Eq a, b ~ a) => a -> Bool+ k x = x == x++Currently (Nov 2021), j issues no warning, while k says that b ~ a+is redundant. This is because j uses the a ~ b constraint to rewrite+everything to be in terms of b, while k does none of that. This is+ridiculous, but I (Richard E) don't see a good fix. -}
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -586,17 +586,24 @@ -- get down to a base predicate, we'll include its size. -- #10335 - | GivenOrigin skol_info <- ctLocOrigin loc -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance- -- for explantation of this transformation for givens- = case skol_info of- InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }- InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }- _ -> loc+ -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in+ -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths+ | otherwise+ = loc { ctl_origin = new_orig }+ where+ new_orig = case ctLocOrigin loc of+ -- these cases are when we have something that's already a superclass constraint+ InstSCOrigin sc_depth n -> InstSCOrigin (sc_depth + 1) (n `max` size)+ OtherSCOrigin sc_depth si -> OtherSCOrigin (sc_depth + 1) si - | otherwise -- Probably doesn't happen, since this function- = loc -- is only used for Givens, but does no harm+ -- these cases do not already have a superclass constraint: depth starts at 1+ GivenOrigin InstSkol -> InstSCOrigin 1 size+ GivenOrigin other_skol -> OtherSCOrigin 1 other_skol + other_orig -> pprPanic "Given constraint without given origin" $+ ppr evar $$ ppr other_orig+ mk_strict_superclasses rec_clss ev tvs theta cls tys | all noFreeVarsOfType tys = return [] -- Wanteds with no variables yield no deriveds.@@ -1019,7 +1026,7 @@ canNonDecomposableConcretePrim ev ty = do { -- Update the evidence to account for the zonk to `ty`. let ki = typeKind ty- new_ev = ev { ctev_pred = mkTyConApp concretePrimTyCon [ki, ty] }+ new_ev = setCtEvPredType ev (mkTyConApp concretePrimTyCon [ki, ty]) new_ct = CSpecialCan { cc_ev = new_ev , cc_special_pred = ConcretePrimPred@@ -3129,11 +3136,11 @@ -- was produced by rewriting, may contain suspended calls to -- (ctEvExpr c), which fails for Derived constraints. -- (Getting this wrong caused #7384.)- continueWith (old_ev { ctev_pred = new_pred })+ continueWith (setCtEvPredType old_ev new_pred) rewriteEvidence old_ev (Reduction co new_pred) | isTcReflCo co -- See Note [Rewriting with Refl]- = continueWith (old_ev { ctev_pred = new_pred })+ = continueWith (setCtEvPredType old_ev new_pred) rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) (Reduction co new_pred) = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)@@ -3181,12 +3188,12 @@ -- It's all a form of rewriteEvidence, specialised for equalities rewriteEqEvidence old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) | CtDerived {} <- old_ev -- Don't force the evidence for a Derived- = return (old_ev { ctev_pred = new_pred })+ = return (setCtEvPredType old_ev new_pred) | NotSwapped <- swapped , isTcReflCo lhs_co -- See Note [Rewriting with Refl] , isTcReflCo rhs_co- = return (old_ev { ctev_pred = new_pred })+ = return (setCtEvPredType old_ev new_pred) | CtGiven { ctev_evar = old_evar } <- old_ev = do { let new_tm = evCoercion ( mkTcSymCo lhs_co
compiler/GHC/Tc/Solver/Interact.hs view
@@ -50,7 +50,6 @@ import GHC.Types.Var.Env import Control.Monad-import GHC.Data.Maybe( isJust ) import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session@@ -492,7 +491,7 @@ -- After this, neither ev_i or ev_w are Derived | CtWanted { ctev_loc = loc_w } <- ev_w- , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w+ , prohibitedSuperClassSolve loc_i loc_w = -- inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork }@@ -526,9 +525,7 @@ -- See Note [Replacement vs keeping] | lvl_i == lvl_w- = do { ev_binds_var <- getTcEvBindsVar- ; binds <- getTcEvBindsMap ev_binds_var- ; return (same_level_strategy binds) }+ = return same_level_strategy | otherwise -- Both are Given, levels differ = return different_level_strategy@@ -538,42 +535,44 @@ loc_w = ctEvLoc ev_w lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w- ev_id_i = ctEvEvId ev_i- ev_id_w = ctEvEvId ev_w different_level_strategy -- Both Given | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork- -- See Note [Replacement vs keeping] (the different-level bullet)+ -- See Note [Replacement vs keeping] part (1) -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] - same_level_strategy binds -- Both Given- | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i- = case ctLocOrigin loc_w of- GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork- | otherwise -> KeepInert- _ -> KeepWork+ same_level_strategy -- Both Given+ = case (ctLocOrigin loc_i, ctLocOrigin loc_w) of+ -- case 2(a) from Note [Replacement vs keeping]+ (InstSCOrigin _depth_i size_i, InstSCOrigin _depth_w size_w)+ | size_w < size_i -> KeepWork+ | otherwise -> KeepInert - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w- = KeepInert+ -- case 2(c) from Note [Replacement vs keeping]+ (InstSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w+ (OtherSCOrigin depth_i _, InstSCOrigin depth_w _) -> choose_shallower depth_i depth_w+ (OtherSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w - | has_binding binds ev_id_w- , not (has_binding binds ev_id_i)- , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))- = KeepWork+ -- case 2(b) from Note [Replacement vs keeping]+ (InstSCOrigin {}, _) -> KeepWork+ (OtherSCOrigin {}, _) -> KeepWork - | otherwise- = KeepInert+ -- case 2(d) from Note [Replacement vs keeping]+ _ -> KeepInert - has_binding binds ev_id = isJust (lookupEvBind binds ev_id)+ choose_shallower depth_i depth_w | depth_w < depth_i = KeepWork+ | otherwise = KeepInert+ -- favor KeepInert in the equals case, according to 2(d) from the Note {- Note [Replacement vs keeping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have two Given constraints both of type (C tys), say, which should-we keep? More subtle than you might think!+we keep? More subtle than you might think! This is all implemented in+solveOneFromTheOther. - * Constraints come from different levels (different_level_strategy)+ 1) Constraints come from different levels (different_level_strategy) - For implicit parameters we want to keep the innermost (deepest) one, so that it overrides the outer one.@@ -588,38 +587,36 @@ 8% performance improvement in nofib cryptarithm2, compared to just rolling the dice. I didn't investigate why. - * Constraints coming from the same level (i.e. same implication)+ 2) Constraints coming from the same level (i.e. same implication) - (a) Always get rid of InstSC ones if possible, since they are less- useful for solving. If both are InstSC, choose the one with- the smallest TypeSize- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+ (a) If both are InstSCOrigin, choose the one with the smallest TypeSize,+ according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - (b) Keep the one that has a non-trivial evidence binding.- Example: f :: (Eq a, Ord a) => blah- then we may find [G] d3 :: Eq a- [G] d2 :: Eq a- with bindings d3 = sc_sel (d1::Ord a)- We want to discard d2 in favour of the superclass selection from- the Ord dictionary.- Why? See Note [Tracking redundant constraints] in GHC.Tc.Solver again.+ (b) Prefer constraints that are not superclass selections. Example: - (c) But don't do (b) if the evidence binding depends transitively on the- one without a binding. Example (with RecursiveSuperClasses)- class C a => D a- class D a => C a- Inert: d1 :: C a, d2 :: D a- Binds: d3 = sc_sel d2, d2 = sc_sel d1- Work item: d3 :: C a- Then it'd be ridiculous to replace d1 with d3 in the inert set!- Hence the findNeedEvVars test. See #14774.+ f :: (Eq a, Ord a) => a -> Bool+ f x = x == x - * Finally, when there is still a choice, use KeepInert rather than- KeepWork, for two reasons:- - to avoid unnecessary munging of the inert set.- - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical+ Eager superclass expansion gives us two [G] Eq a constraints. We+ want to keep the one from the user-written Eq a, not the superclass+ selection. This means we report the Ord a as redundant with+ -Wredundant-constraints, not the Eq a. -Doing the depth-check for implicit parameters, rather than making the work item+ Getting this wrong was #20602. See also+ Note [Tracking redundant constraints] in GHC.Tc.Solver.++ (c) If both are superclass selections (but not both InstSCOrigin), choose the one+ with the shallower superclass-selection depth, in the hope of identifying+ more correct redundant constraints. This is really a generalization of+ point (b), because the superclass depth of a non-superclass+ constraint is 0.++ (d) Finally, when there is still a choice, use KeepInert rather than+ KeepWork, for two reasons:+ - to avoid unnecessary munging of the inert set.+ - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical++Doing the level-check for implicit parameters, rather than making the work item always override, is important. Consider data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }@@ -635,7 +632,7 @@ - process a~Int, kicking out (?x::a) - process (?x::Int), the inner given, adding to inert set - process (?x::a), the outer given, overriding the inner given-Wrong! The depth-check ensures that the inner implicit parameter wins.+Wrong! The level-check ensures that the inner implicit parameter wins. (Actually I think that the order in which the work-list is processed means that this chain of events won't happen, but that's very fragile.) @@ -2456,35 +2453,57 @@ matchLocalInst pred loc = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts ; case match_local_inst inerts (inert_insts ics) of- ([], False) -> do { traceTcS "No local instance for" (ppr pred)- ; return NoInstance }- ([(dfun_ev, inst_tys)], unifs)- | not unifs+ ([], Nothing) -> do { traceTcS "No local instance for" (ppr pred)+ ; return NoInstance }++ -- See Note [Use only the best local instance] about+ -- superclass depths+ (matches, unifs)+ | [(dfun_ev, inst_tys)] <- best_matches+ , maybe True (> min_sc_depth) unifs -> do { let dfun_id = ctEvEvId dfun_ev ; (tys, theta) <- instDFunType dfun_id inst_tys ; let result = OneInst { cir_new_theta = theta , cir_mk_ev = evDFunApp dfun_id tys , cir_what = LocalInstance }- ; traceTcS "Local inst found:" (ppr result)+ ; traceTcS "Best local inst found:" (ppr result)+ ; traceTcS "All local insts:" (ppr matches) ; return result }- _ -> do { traceTcS "Multiple local instances for" (ppr pred)- ; return NotSure }}++ | otherwise+ -> do { traceTcS "Multiple local instances for" (ppr pred)+ ; return NotSure }++ where+ extract_depth = sc_depth . ctEvLoc . fst+ min_sc_depth = minimum (map extract_depth matches)+ best_matches = filter ((== min_sc_depth) . extract_depth) matches } where pred_tv_set = tyCoVarsOfType pred + sc_depth :: CtLoc -> Int+ sc_depth ctloc = case ctLocOrigin ctloc of+ InstSCOrigin depth _ -> depth+ OtherSCOrigin depth _ -> depth+ _ -> 0++ -- See Note [Use only the best local instance] about superclass depths match_local_inst :: InertSet -> [QCInst] -> ( [(CtEvidence, [DFunInstType])]- , Bool ) -- True <=> Some unify but do not match+ , Maybe Int ) -- Nothing ==> no unifying local insts+ -- Just n ==> unifying local insts, with+ -- minimum superclass depth+ -- of n match_local_inst _inerts []- = ([], False)+ = ([], Nothing) match_local_inst inerts (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred- , qci_ev = ev })+ , qci_ev = qev }) : qcis) | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) emptyTvSubstEnv qpred pred- , let match = (ev, map (lookupVarEnv tv_subst) qtvs)+ , let match = (qev, map (lookupVarEnv tv_subst) qtvs) = (match:matches, unif) | otherwise@@ -2492,8 +2511,52 @@ (ppr qci $$ ppr pred) -- ASSERT: unification relies on the -- quantified variables being fresh- (matches, unif || this_unif)+ (matches, unif `combine` this_unif) where+ qloc = ctEvLoc qev qtv_set = mkVarSet qtvs- this_unif = mightEqualLater inerts qpred (ctEvLoc ev) pred loc+ this_unif+ | mightEqualLater inerts qpred qloc pred loc = Just (sc_depth qloc)+ | otherwise = Nothing (matches, unif) = match_local_inst inerts qcis++ combine Nothing Nothing = Nothing+ combine (Just n) Nothing = Just n+ combine Nothing (Just n) = Just n+ combine (Just n1) (Just n2) = Just (n1 `min` n2)++{- Note [Use only the best local instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#20582) the ambiguity check for+ (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int++Because of eager expansion of given superclasses, we get+ [G] forall a. Ord (m a)+ [G] forall a. Eq (m a)+ [G] forall a. Semigroup a => Eq (m a)++ [W] forall a. Ord (m a)+ [W] forall a. Semigroup a => Eq (m a)++The first wanted is solved straightforwardly. But the second wanted+matches *two* local instances. Our general rule around multiple local+instances is that we refuse to commit to any of them. However, that+means that our type fails the ambiguity check. That's bad: the type+is perfectly fine. (This actually came up in the wild, in the streamly+library.)++The solution is to prefer local instances with fewer superclass selections.+So, matchLocalInst is careful to whittle down the matches only to the+ones with the shallowest superclass depth, and also to worry about unifying+local instances that are at that depth (or less).++By preferring these shallower local instances, we can use the last given+listed above and pass the ambiguity check.++The instance-depth mechanism uses the same superclass depth+information as described in Note [Replacement vs keeping], 2a.++Test case: typecheck/should_compile/T20582.++-}+
compiler/GHC/Tc/TyCl.hs view
@@ -907,7 +907,7 @@ -- Step 2b: quantify, mainly meaning skolemise the free variables -- Returned 'inferred' are scope-sorted and skolemised- ; inferred <- quantifyTyVars allVarsOfKindDefault dvs2+ ; inferred <- quantifyTyVars DefaultNonStandardTyVars dvs2 ; traceTc "generaliseTcTyCon: pre zonk" (vcat [ text "tycon =" <+> ppr tc@@ -2466,7 +2466,15 @@ ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; is_boot <- tcIsHsBootOrSig- ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+ ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff+ -- We use @isNothing hs_ctxt@ rather than @null ctxt@,+ -- so that a declaration in an hs-boot file such as:+ --+ -- class () => C a b | a -> b+ --+ -- is not considered abstract; it's sometimes useful+ -- to be able to declare such empty classes in hs-boot files.+ -- See #20661. = Nothing | otherwise = Just (ctxt, at_stuff, sig_stuff, mindef)@@ -2822,7 +2830,7 @@ -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))- = setSrcSpan loc $+ = setSrcSpanA loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)@@ -3140,7 +3148,7 @@ -- See Note [Generalising in tcTyFamInstEqnGuts] ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs)- ; qtvs <- quantifyTyVars noVarsOfKindDefault dvs+ ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs @@ -3312,7 +3320,8 @@ ; let gadt_syntax = consUseGadtSyntax cons ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - -- Check that the stupid theta is empty for a GADT-style declaration+ -- Check that the stupid theta is empty for a GADT-style declaration.+ -- See Note [The stupid context] in GHC.Core.DataCon. ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) -- Check that a newtype has exactly one constructor@@ -4964,7 +4973,7 @@ check_no_roles = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () checkRoleAnnot _ (L _ Nothing) _ = return () checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $
compiler/GHC/Tc/TyCl/Build.hs view
@@ -192,6 +192,8 @@ -- the type variables mentioned in the arg_tys -- ToDo: Or functionally dependent on? -- This whole stupid theta thing is, well, stupid.+--+-- See Note [The stupid context] in GHC.Core.DataCon. mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] mkDataConStupidTheta tycon arg_tys univ_tvs | null stupid_theta = [] -- The common case
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -915,7 +915,7 @@ -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)- ; qtvs <- quantifyTyVars noVarsOfKindDefault dvs+ ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted -- Zonk the patterns etc into the Type world@@ -1601,10 +1601,11 @@ GivenOrigin InstSkol. * When we make a superclass selection from InstSkol we use- a SkolemInfo of (InstSC size), where 'size' is the size of- the constraint whose superclass we are taking. A similarly- when taking the superclass of an InstSC. This is implemented- in GHC.Tc.Solver.Canonical.newSCWorkFromFlavored+ a CtOrigin of (InstSCOrigin size), where 'size' is the size of+ the constraint whose superclass we are taking. And similarly+ when taking the superclass of an InstSCOrigin. This is implemented+ in GHC.Tc.Solver.Canonical.mk_strict_superclasses (in the+ mk_given_loc helper function). Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -761,7 +761,7 @@ ; tv_name <- newNameAt (mkTyVarOcc "r") loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv- res_tv = mkTyVar tv_name (tYPE rr)+ res_tv = mkTyVar tv_name (mkTYPEapp rr) res_ty = mkTyVarTy res_tv is_unlifted = null args && null prov_dicts (cont_args, cont_arg_tys)
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -886,6 +886,7 @@ loc = getSrcSpan sel_name loc' = noAnnSrcSpan loc locn = noAnnSrcSpan loc+ locc = noAnnSrcSpan loc lbl = flLabel fl sel_name = flSelector fl @@ -905,7 +906,8 @@ || has_sel == NoFieldSelectors sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $- mkPhiTy (conLikeStupidTheta con1) $ -- Urgh!+ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon+ mkPhiTy (conLikeStupidTheta con1) $ -- req_theta is empty for normal DataCon mkPhiTy req_theta $ mkVisFunTyMany data_ty $@@ -930,8 +932,8 @@ rec_field = noLocA (HsFieldBind { hfbAnn = noAnn , hfbLHS- = L loc (FieldOcc sel_name- (L locn $ mkVarUnqual lbl))+ = L locc (FieldOcc sel_name+ (L locn $ mkVarUnqual lbl)) , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) , hfbPun = False })
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -41,6 +41,7 @@ import GHC.Types.PkgQual import GHC.Unit+import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface@@ -306,17 +307,17 @@ implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do- found <- findImportedModule fc fopts units home_unit imp mb_pkg+ found <- findImportedModule fc fopts units mhome_unit imp mb_pkg case found of- Found _ mod | not (isHomeModule home_unit mod) ->+ Found _ mod | notHomeModuleMaybe mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where- fc = hsc_FC hsc_env- home_unit = hsc_home_unit hsc_env- units = hsc_units hsc_env- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags+ fc = hsc_FC hsc_env+ mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ units = hsc_units hsc_env+ dflags = hsc_dflags hsc_env+ fopts = initFinderOpts dflags -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that@@ -328,17 +329,17 @@ -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where- fc = hsc_FC hsc_env- home_unit = hsc_home_unit hsc_env- units = hsc_units hsc_env- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags+ fc = hsc_FC hsc_env+ mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ units = hsc_units hsc_env+ dflags = hsc_dflags hsc_env+ fopts = initFinderOpts dflags go acc [] = pure acc go (accL, accR) ((mb_pkg, L _ imp):imports) = do- found <- findImportedModule fc fopts units home_unit imp mb_pkg+ found <- findImportedModule fc fopts units mhome_unit imp mb_pkg let acc' = case found of- Found _ mod | not (isHomeModule home_unit mod) ->+ Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of HoleUnit -> (moduleName mod : accL, accR) RealUnit _ -> (accL, accR)@@ -570,7 +571,7 @@ let unit_state = hsc_units hsc_env let fc = hsc_FC hsc_env let nc = hsc_NC hsc_env- let home_unit = hsc_home_unit hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env@@ -588,7 +589,7 @@ ctx = initSDocContext dflags defaultUserStyle fmap fst . withException ctx- $ findAndReadIface logger nc fc hooks unit_state home_unit dflags+ $ findAndReadIface logger nc fc hooks unit_state mhome_unit dflags (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces,@@ -768,6 +769,8 @@ setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do tcg_env <- getGblEnv + let home_unit = hsc_home_unit hsc_env+ -- STEP 4: Rename the interfaces ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface@@ -1001,12 +1004,12 @@ hsc_env <- getTopEnv let nc = hsc_NC hsc_env let fc = hsc_FC hsc_env- let home_unit = hsc_home_unit hsc_env+ let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env- mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags+ mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags (text "checkImplements 2") isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of
compiler/GHC/Tc/Utils/Env.hs view
@@ -106,6 +106,7 @@ import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External+import GHC.Unit.Env import GHC.Utils.Outputable import GHC.Utils.Panic@@ -161,8 +162,8 @@ lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env)- home_unit = hsc_home_unit hsc_env- tcg_semantic_mod = homeModuleInstantiation home_unit mod+ mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name then (return
compiler/GHC/Tc/Utils/Monad.hs view
@@ -268,7 +268,7 @@ let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ;- !home_unit = hsc_home_unit hsc_env ;+ !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ;@@ -296,7 +296,7 @@ tcg_th_docs = th_docs_var, tcg_mod = mod,- tcg_semantic_mod = homeModuleInstantiation home_unit mod,+ tcg_semantic_mod = homeModuleInstantiation mhome_unit mod, tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv,@@ -950,8 +950,7 @@ ; return (L loc b) } wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)-wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a- ; return (L (locA loc) b) }+wrapLocAM fn a = wrapLocM fn (reLoc a) wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a@@ -963,7 +962,12 @@ (b,c) <- fn a return (L loc b, c) -wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)+-- Possible instantiations:+-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)+-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN a -> TcM (LocatedN b, c)+-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)+-- and so on.+wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c) wrapLocFstMA fn (L loc a) = setSrcSpanA loc $ do (b,c) <- fn a@@ -975,7 +979,12 @@ (b,c) <- fn a return (b, L loc c) -wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)+-- Possible instantiations:+-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)+-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN a -> TcM (b, LocatedN c)+-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)+-- and so on.+wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c) wrapLocSndMA fn (L loc a) = setSrcSpanA loc $ do (b,c) <- fn a@@ -2064,11 +2073,11 @@ = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356)- ; let !home_unit = hsc_home_unit hsc_env+ ; let !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) !knot_vars = tcg_type_env_var tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie.- is_instantiate = isHomeUnitInstantiating home_unit+ is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types =
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -129,7 +129,8 @@ import GHC.Types.Name.Env import GHC.Types.Unique.Set import GHC.Types.Basic ( TypeOrKind(..)- , DefaultKindVars(..), DefaultVarsOfKind(..), allVarsOfKindDefault )+ , NonStandardDefaultingStrategy(..)+ , DefaultingStrategy(..), defaultNonStandardTyVars ) import GHC.Data.FastString import GHC.Data.Bag@@ -505,7 +506,7 @@ -- See Note [inferResultToType] ; return ty } Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy- ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) -- See Note [TcLevel of ExpType] ; writeMutVar ref (Just tau) ; return tau }@@ -682,7 +683,7 @@ promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty -- where alpha and rr are fresh and from level dest_lvl = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy- ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+ ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) ; let eq_orig = TypeEqOrigin { uo_actual = ty , uo_expected = prom_ty , uo_thing = Nothing@@ -1067,7 +1068,7 @@ newOpenTypeKind :: TcM TcKind newOpenTypeKind = do { rr <- newFlexiTyVarTy runtimeRepTy- ; return (tYPE rr) }+ ; return (mkTYPEapp rr) } -- | Create a tyvar that can be a lifted or unlifted type. -- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh@@ -1085,7 +1086,7 @@ newOpenBoxedTypeKind = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) ; let rr = mkTyConApp boxedRepDataConTyCon [lev]- ; return (tYPE rr) }+ ; return (mkTYPEapp rr) } newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables@@ -1691,7 +1692,7 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: DefaultVarsOfKind+quantifyTyVars :: NonStandardDefaultingStrategy -> CandidatesQTvs -- See Note [Dependent type variables] -- Already zonked -> TcM [TcTyVar]@@ -1702,7 +1703,7 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars].-quantifyTyVars def_varsOfKind dvs+quantifyTyVars ns_strat dvs -- short-circuit common case | isEmptyCandidates dvs = do { traceTc "quantifyTyVars has nothing to quantify" empty@@ -1710,10 +1711,10 @@ | otherwise = do { traceTc "quantifyTyVars {"- ( vcat [ text "def_varsOfKind =" <+> ppr def_varsOfKind+ ( vcat [ text "ns_strat =" <+> ppr ns_strat , text "dvs =" <+> ppr dvs ]) - ; undefaulted <- defaultTyVars def_varsOfKind dvs+ ; undefaulted <- defaultTyVars ns_strat dvs ; final_qtvs <- mapMaybeM zonk_quant undefaulted ; traceTc "quantifyTyVars }"@@ -1791,12 +1792,13 @@ _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk -defaultTyVar :: DefaultKindVars- -> DefaultVarsOfKind- -> TcTyVar -- If it's a MetaTyVar then it is unbound- -> TcM Bool -- True <=> defaulted away altogether--defaultTyVar def_kindVars def_varsOfKind tv+-- | Default a type variable using the given defaulting strategy.+--+-- See Note [Type variable defaulting options] in GHC.Types.Basic.+defaultTyVar :: DefaultingStrategy+ -> TcTyVar -- If it's a MetaTyVar then it is unbound+ -> TcM Bool -- True <=> defaulted away altogether+defaultTyVar def_strat tv | not (isMetaTyVar tv) = return False @@ -1807,32 +1809,33 @@ -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl = return False - | isRuntimeRepVar tv- , def_runtimeRep def_varsOfKind+ , default_ns_vars -- Do not quantify over a RuntimeRep var -- unless it is a TyVarTv, handled earlier = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) ; writeMetaTyVar tv liftedRepTy ; return True } | isLevityVar tv- , def_levity def_varsOfKind+ , default_ns_vars = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) ; writeMetaTyVar tv liftedDataConTy ; return True } | isMultiplicityVar tv- , def_multiplicity def_varsOfKind- = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv)+ , default_ns_vars+ = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) ; writeMetaTyVar tv manyDataConTy ; return True } - | DefaultKinds <- def_kindVars -- -XNoPolyKinds and this is a kind var- = default_kind_var tv -- so default it to * if possible+ | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it+ = default_kind_var tv | otherwise = return False where+ default_ns_vars :: Bool+ default_ns_vars = defaultNonStandardTyVars def_strat default_kind_var :: TyVar -> TcM Bool -- defaultKindVar is used exclusively with -XNoPolyKinds -- See Note [Defaulting with -XNoPolyKinds]@@ -1859,20 +1862,37 @@ where (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv --- | Default some unconstrained type variables:--- RuntimeRep tyvars default to LiftedRep--- Multiplicity tyvars default to Many--- Type tyvars from dv_kvs default to Type, when -XNoPolyKinds--- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)-defaultTyVars :: DefaultVarsOfKind- -> CandidatesQTvs -- ^ all candidates for quantification- -> TcM [TcTyVar] -- ^ those variables not defaulted-defaultTyVars def_varsOfKind dvs+-- | Default some unconstrained type variables, as specified+-- by the defaulting options:+--+-- - 'RuntimeRep' tyvars default to 'LiftedRep'+-- - 'Levity' tyvars default to 'Lifted'+-- - 'Multiplicity' tyvars default to 'Many'+-- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds+-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)+defaultTyVars :: NonStandardDefaultingStrategy+ -> CandidatesQTvs -- ^ all candidates for quantification+ -> TcM [TcTyVar] -- ^ those variables not defaulted+defaultTyVars ns_strat dvs = do { poly_kinds <- xoptM LangExt.PolyKinds ; let- def_kinds = if poly_kinds then Don'tDefaultKinds else DefaultKinds- ; defaulted_kvs <- mapM (defaultTyVar def_kinds def_varsOfKind ) dep_kvs- ; defaulted_tvs <- mapM (defaultTyVar Don'tDefaultKinds def_varsOfKind ) nondep_tvs+ def_tvs, def_kvs :: DefaultingStrategy+ def_tvs = NonStandardDefaulting ns_strat+ def_kvs+ | poly_kinds = def_tvs+ | otherwise = DefaultKindVars+ -- As -XNoPolyKinds precludes polymorphic kind variables, we default them.+ -- For example:+ --+ -- type F :: Type -> Type+ -- type family F a where+ -- F (a -> b) = b+ --+ -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled+ -- we must default the kind variable `r :: RuntimeRep`.+ -- Test case: T20584.+ ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs+ ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] ; return (undefaulted_kvs ++ undefaulted_tvs) }@@ -2029,7 +2049,7 @@ | otherwise = do { traceTc "doNotQuantifyTyVars" (ppr dvs)- ; undefaulted <- defaultTyVars allVarsOfKindDefault dvs+ ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs -- could have regular TyVars here, in an associated type RHS, or -- bound by a type declaration head. So filter looking only for -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`@@ -2387,19 +2407,10 @@ ; return (mkNonCanonical fl') } zonkCtEvidence :: CtEvidence -> TcM CtEvidence-zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })- = do { pred' <- zonkTcType pred- ; return (ctev { ctev_pred = pred'}) }-zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })- = do { pred' <- zonkTcType pred- ; let dest' = case dest of- EvVarDest ev -> EvVarDest $ setVarType ev pred'- -- necessary in simplifyInfer- HoleDest h -> HoleDest h- ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }-zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })- = do { pred' <- zonkTcType pred- ; return (ctev { ctev_pred = pred' }) }+zonkCtEvidence ctev+ = do { pred' <- zonkTcType (ctev_pred ctev)+ ; return (setCtEvPredType ctev pred')+ } zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty@@ -2546,6 +2557,10 @@ = do { skol_info1 <- zonkSkolemInfo skol_info ; let skol_info2 = tidySkolemInfo env skol_info1 ; return (env, GivenOrigin skol_info2) }+zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info)+ = do { skol_info1 <- zonkSkolemInfo skol_info+ ; let skol_info2 = tidySkolemInfo env skol_info1+ ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) = do { (env1, act') <- zonkTidyTcType env act
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -672,7 +672,7 @@ ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> MatchGroup GhcTc (LocatedA (body GhcTc))@@ -687,7 +687,7 @@ , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> LMatch GhcTc (LocatedA (body GhcTc))@@ -699,7 +699,7 @@ ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } --------------------------------------------------------------------------zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> GRHSs GhcTc (LocatedA (body GhcTc))@@ -712,7 +712,7 @@ = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs)- new_grhss <- mapM (wrapLocM zonk_grhs) grhss+ new_grhss <- mapM (wrapLocMA zonk_grhs) grhss return (GRHSs x new_grhss new_binds) {-@@ -842,7 +842,7 @@ return (HsIf x new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts)- = do { alts' <- mapM (wrapLocM zonk_alt) alts+ = do { alts' <- mapM (wrapLocMA zonk_alt) alts ; ty' <- zonkTcTypeToTypeX env ty ; return $ HsMultiIf ty' alts' } where zonk_alt (GRHS x guard expr)@@ -850,10 +850,10 @@ ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x binds expr)+zonkExpr env (HsLet x tkLet binds tkIn expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr- return (HsLet x new_binds new_expr)+ return (HsLet x tkLet new_binds tkIn new_expr) zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts@@ -1027,10 +1027,10 @@ ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x binds cmd)+zonkCmd env (HsCmdLet x tkLet binds tkIn cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd- return (HsCmdLet x new_binds new_cmd)+ return (HsCmdLet x tkLet new_binds tkIn new_cmd) zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts@@ -1040,7 +1040,7 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)-zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd+zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)@@ -1302,7 +1302,7 @@ ; return (HsRecFields flds' dd) } where zonk_rbind (L l fld)- = do { new_id <- wrapLocM (zonkFieldOcc env) (hfbLHS fld)+ = do { new_id <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld) ; new_expr <- zonkLExpr env (hfbRHS fld) ; return (L l (fld { hfbLHS = new_id , hfbRHS = new_expr })) }@@ -1312,14 +1312,14 @@ zonkRecUpdFields env = mapM zonk_rbind where zonk_rbind (L l fld)- = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)+ = do { new_id <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hfbRHS fld) ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id , hfbRHS = new_expr })) } --------------------------------------------------------------------------mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a- -> TcM (Either (Located HsIPName) b)+mapIPNameTc :: (a -> TcM b) -> Either (LocatedAn NoEpAnns HsIPName) a+ -> TcM (Either (LocatedAn NoEpAnns HsIPName) b) mapIPNameTc _ (Left x) = return (Left x) mapIPNameTc f (Right x) = do r <- f x return (Right r)
compiler/GHC/Tc/Validity.hs view
@@ -433,7 +433,7 @@ ; expand <- initialExpandMode ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) else addErrTcM ( emptyTidyEnv- , TcRnIllegalConstraintSynonymOfKind (tidyKind emptyTidyEnv actual_kind)+ , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind) ) } | otherwise@@ -923,7 +923,7 @@ -- NB: Don't tidy the sigma type since the tvbs were already tidied -- previously, and re-tidying them will make the names of type -- variables different from tau_kind.- = (env, TcRnForAllEscapeError (mkSigmaTy tvbs theta tau) (tidyKind env tau_kind))+ = (env, TcRnForAllEscapeError (mkSigmaTy tvbs theta tau) (tidyType env tau_kind)) {- Note [Type variables escaping through kinds]
compiler/GHC/ThToHs.hs view
@@ -127,19 +127,12 @@ setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: a -> CvtM (Located a)-returnL x = CvtM (\_ loc -> Right (loc, L loc x))---- returnLA :: a -> CvtM (LocatedA a) returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA --- wrapParL :: (Located a -> a) -> a -> CvtM a--- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))- wrapParLA :: (LocatedA a -> a) -> a -> CvtM a wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) @@ -259,7 +252,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing- , dd_ctxt = mkHsContextMaybe ctxt ctxt'+ , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $@@ -275,7 +268,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing- , dd_ctxt = mkHsContextMaybe ctxt ctxt'+ , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' , dd_cons = [con'] , dd_derivs = derivs' }@@ -295,7 +288,7 @@ $$ (Outputable.ppr adts')) ; returnJustLA $ TyClD noExtField $ ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)- , tcdCtxt = mkHsContextMaybe ctxt cxt', tcdLName = tc', tcdTyVars = tvs'+ , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdMeths = binds'@@ -346,7 +339,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType, dd_cType = Nothing- , dd_ctxt = mkHsContextMaybe ctxt ctxt'+ , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } @@ -367,7 +360,7 @@ ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_ND = NewType, dd_cType = Nothing- , dd_ctxt = mkHsContextMaybe ctxt ctxt'+ , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD@@ -401,7 +394,7 @@ cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameN tc- ; let roles' = map (noLoc . cvtRole) roles+ ; let roles' = map (noLocA . cvtRole) roles ; returnJustLA $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } @@ -622,7 +615,7 @@ ; L _ con' <- cvtConstr con ; returnLA $ add_forall tvs' ctxt' con' } where- add_cxt lcxt Nothing = Just lcxt+ add_cxt lcxt Nothing = mkHsContextMaybe lcxt add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) @@ -701,7 +694,7 @@ ; return $ noLocA (ConDeclField { cd_fld_ext = noAnn , cd_fld_names- = [L (locA li) $ FieldOcc noExtField (L li i')]+ = [L (l2l li) $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -824,7 +817,7 @@ , rds_src = SourceText "{-# RULES" , rds_rules = [noLocA $ HsRule { rd_ext = noAnn- , rd_name = (noLoc (quotedSourceText nm,nm'))+ , rd_name = (noLocA (quotedSourceText nm,nm')) , rd_act = act , rd_tyvs = ty_bndrs' , rd_tmvs = tm_bndrs'@@ -878,11 +871,11 @@ cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameN n- ; return $ noLoc $ Hs.RuleBndr noAnn n' }+ ; return $ noLocA $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameN n ; ty' <- cvtType ty- ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }+ ; return $ noLocA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } --------------------------------------------------- -- Declarations@@ -917,7 +910,7 @@ cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e- returnLA (IPBind noAnn (Left n') e')+ returnLA (IPBind noAnn (Left (reLocA n')) e') ------------------------------------------------------------------- -- Expressions@@ -981,7 +974,7 @@ | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf noAnn alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds- ; e' <- cvtl e; return $ HsLet noAnn ds' e'}+ ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin ; return $ HsCase noAnn e'@@ -1056,8 +1049,8 @@ cvt (LabelE s) = return $ HsOverLabel noComments (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp- ; return $ HsGetField noComments e' (L noSrcSpan (DotFieldOcc noAnn (L noSrcSpan (fsLit f)))) }- cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpan . DotFieldOcc noAnn . L noSrcSpan . fsLit) xs+ ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }+ cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example:@@ -1093,11 +1086,11 @@ -} cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)- -> CvtM (LHsFieldBind GhcPs (Located t) (LHsExpr GhcPs))+ -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v; e' <- cvtl e ; return (noLocA $ HsFieldBind { hfbAnn = noAnn- , hfbLHS = reLoc $ fmap f v'+ , hfbLHS = la2la $ fmap f v' , hfbRHS = e' , hfbPun = False}) } @@ -1228,14 +1221,14 @@ cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e- ; g' <- returnL $ GRHS noAnn [] e'; return [g'] }+ ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnLA $ mkBodyStmt ge'- ; returnL $ GRHS noAnn [g'] rhs' }+ ; returnLA $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs- ; returnL $ GRHS noAnn gs' rhs' }+ ; returnLA $ GRHS noAnn gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i)@@ -1308,7 +1301,7 @@ cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l- ; return (mkNPat (noLoc l') Nothing noAnn) }+ ; return (mkNPat (noLocA l') Nothing noAnn) } -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }@@ -1374,7 +1367,7 @@ ; p' <- cvtPat p ; return (noLocA $ HsFieldBind { hfbAnn = noAnn , hfbLHS- = L (locA ls) $ mkFieldOcc (L ls s')+ = L (l2l ls) $ mkFieldOcc (L (l2l ls) s') , hfbRHS = p' , hfbPun = False}) } @@ -1456,15 +1449,15 @@ cvtDerivClause (TH.DerivClause ds tys) = do { tys' <- cvtDerivClauseTys tys ; ds' <- traverse cvtDerivStrategy ds- ; returnL $ HsDerivingClause noAnn ds' tys' }+ ; returnLA $ HsDerivingClause noAnn ds' tys' } cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy = returnL (Hs.StockStrategy noAnn)-cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn)-cvtDerivStrategy TH.NewtypeStrategy = returnL (Hs.NewtypeStrategy noAnn)+cvtDerivStrategy TH.StockStrategy = returnLA (Hs.StockStrategy noAnn)+cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)+cvtDerivStrategy TH.NewtypeStrategy = returnLA (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do ty' <- cvtSigType ty- returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')+ returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type"@@ -1677,7 +1670,7 @@ ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t- ; returnLA (HsIParamTy noAnn n' t')+ ; returnLA (HsIParamTy noAnn (reLocA n') t') } _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty))@@ -1796,18 +1789,18 @@ -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField)+cvtMaybeKindToFamilyResultSig Nothing = returnLA (Hs.NoSig noExtField) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki- ; returnL (Hs.KindSig noExtField ki') }+ ; returnLA (Hs.KindSig noExtField ki') } -- | Convert type family result signature. Used with both open and closed type -- families. cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExtField)+cvtFamilyResultSig TH.NoSig = returnLA (Hs.NoSig noExtField) cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki- ; returnL (Hs.KindSig noExtField ki') }+ ; returnLA (Hs.KindSig noExtField ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr- ; returnL (Hs.TyVarSig noExtField tv) }+ ; returnLA (Hs.TyVarSig noExtField tv) } -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn@@ -1815,7 +1808,7 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) = do { annLHS' <- tNameN annLHS ; annRHS' <- mapM tNameN annRHS- ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') }+ ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') } cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat@@ -1924,21 +1917,19 @@ , hst_ctxt = ctxt' , hst_body = ty } --- | If passed an empty 'TH.Cxt', this returns 'Nothing'. Otherwise, this--- returns @'Just' lc@, where @lc@ is the provided @'LHsContext' 'GhcPs'@--- argument.+-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@+-- otherwise. -- -- This is much like 'mkHsQualTy', except that it returns a -- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing--- superclasses and datatype contexts. We wish to avoid using 'Just' in the--- case of an empty 'TH.Cxt', as the pretty-printer for superclasses/datatype--- contexts always prints 'Just' contexts, even if they're empty. See #20011.-mkHsContextMaybe :: TH.Cxt- -> LHsContext GhcPs- -> Maybe (LHsContext GhcPs)-mkHsContextMaybe ctxt ctxt'+-- superclasses, datatype contexts (#20011), and contexts in GADT constructor+-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty+-- contexts, as the pretty-printer always prints 'Just' contexts, even if+-- they're empty.+mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)+mkHsContextMaybe lctxt@(L _ ctxt) | null ctxt = Nothing- | otherwise = Just ctxt'+ | otherwise = Just lctxt mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)
compiler/GHC/Unit/Finder.hs view
@@ -134,18 +134,24 @@ :: FinderCache -> FinderOpts -> UnitState- -> HomeUnit+ -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult-findImportedModule fc fopts units home_unit mod_name mb_pkg =+findImportedModule fc fopts units mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg _ -> home_import OtherPkg _ -> pkg_import where- home_import = findHomeModule fc fopts home_unit mod_name+ home_import+ | Just home_unit <- mhome_unit+ = findHomeModule fc fopts home_unit mod_name+ | otherwise+ = pure $ NoPackage (panic "findImportedModule: no home-unit")+ pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg+ unqual_import = home_import `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual@@ -154,11 +160,13 @@ -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified.-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult-findPluginModule fc fopts units home_unit mod_name =+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult+findPluginModule fc fopts units (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name+findPluginModule fc fopts units Nothing mod_name =+ findExposedPluginPackageModule fc fopts units mod_name -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out@@ -166,11 +174,13 @@ -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult-findExactModule fc fopts unit_state home_unit mod = do- if isHomeInstalledModule home_unit mod- then findInstalledHomeModule fc fopts home_unit (moduleName mod)- else findPackageModule fc unit_state fopts mod+findExactModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult+findExactModule fc fopts unit_state mhome_unit mod = do+ case mhome_unit of+ Just home_unit+ | isHomeInstalledModule home_unit mod+ -> findInstalledHomeModule fc fopts home_unit (moduleName mod)+ _ -> findPackageModule fc unit_state fopts mod -- ----------------------------------------------------------------------------- -- Helpers
− compiler/MachDeps.h
@@ -1,119 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow 2002- *- * Definitions that characterise machine specific properties of basic- * types (C & Haskell) of a target platform.- *- * NB: Keep in sync with HsFFI.h and StgTypes.h.- * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!- *- * To understand the structure of the RTS headers, see the wiki:- * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes- *- * ---------------------------------------------------------------------------*/--#pragma once--/* Don't allow stage1 (cross-)compiler embed assumptions about target- * platform. When ghc-stage1 is being built by ghc-stage0 is should not- * refer to target defines. A few past examples:- * - https://gitlab.haskell.org/ghc/ghc/issues/13491- * - https://phabricator.haskell.org/D3122- * - https://phabricator.haskell.org/D3405- *- * In those cases code change assumed target defines like SIZEOF_HSINT- * are applied to host platform, not target platform.- *- * So what should be used instead in GHC_STAGE=1?- *- * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:- * Data.Bits.finiteBitSize (0 :: Int)- *- * To get target's values it is preferred to use runtime target- * configuration from 'targetPlatform :: DynFlags -> Platform'- * record.- *- * Hence we hide these macros from GHC_STAGE=1- */--/* Sizes of C types come from here... */-#include "ghcautoconf.h"--/* Sizes of Haskell types follow. These sizes correspond to:- * - the number of bytes in the primitive type (eg. Int#)- * - the number of bytes in the external representation (eg. HsInt)- * - the scale offset used by writeFooOffAddr#- *- * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,- * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.- */--#define SIZEOF_HSCHAR SIZEOF_WORD32-#define ALIGNMENT_HSCHAR ALIGNMENT_WORD32--#define SIZEOF_HSINT SIZEOF_VOID_P-#define ALIGNMENT_HSINT ALIGNMENT_VOID_P--#define SIZEOF_HSWORD SIZEOF_VOID_P-#define ALIGNMENT_HSWORD ALIGNMENT_VOID_P--#define SIZEOF_HSDOUBLE SIZEOF_DOUBLE-#define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE--#define SIZEOF_HSFLOAT SIZEOF_FLOAT-#define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT--#define SIZEOF_HSPTR SIZEOF_VOID_P-#define ALIGNMENT_HSPTR ALIGNMENT_VOID_P--#define SIZEOF_HSFUNPTR SIZEOF_VOID_P-#define ALIGNMENT_HSFUNPTR ALIGNMENT_VOID_P--#define SIZEOF_HSSTABLEPTR SIZEOF_VOID_P-#define ALIGNMENT_HSSTABLEPTR ALIGNMENT_VOID_P--#define SIZEOF_INT8 SIZEOF_INT8_T-#define ALIGNMENT_INT8 ALIGNMENT_INT8_T--#define SIZEOF_WORD8 SIZEOF_UINT8_T-#define ALIGNMENT_WORD8 ALIGNMENT_UINT8_T--#define SIZEOF_INT16 SIZEOF_INT16_T-#define ALIGNMENT_INT16 ALIGNMENT_INT16_T--#define SIZEOF_WORD16 SIZEOF_UINT16_T-#define ALIGNMENT_WORD16 ALIGNMENT_UINT16_T--#define SIZEOF_INT32 SIZEOF_INT32_T-#define ALIGNMENT_INT32 ALIGNMENT_INT32_T--#define SIZEOF_WORD32 SIZEOF_UINT32_T-#define ALIGNMENT_WORD32 ALIGNMENT_UINT32_T--#define SIZEOF_INT64 SIZEOF_INT64_T-#define ALIGNMENT_INT64 ALIGNMENT_INT64_T--#define SIZEOF_WORD64 SIZEOF_UINT64_T-#define ALIGNMENT_WORD64 ALIGNMENT_UINT64_T--#if !defined(WORD_SIZE_IN_BITS)-#if SIZEOF_HSWORD == 4-#define WORD_SIZE_IN_BITS 32-#define WORD_SIZE_IN_BITS_FLOAT 32.0-#else-#define WORD_SIZE_IN_BITS 64-#define WORD_SIZE_IN_BITS_FLOAT 64.0-#endif-#endif--#if !defined(TAG_BITS)-#if SIZEOF_HSWORD == 4-#define TAG_BITS 2-#else-#define TAG_BITS 3-#endif-#endif--#define TAG_MASK ((1 << TAG_BITS) - 1)-
+ compiler/ghc-llvm-version.h view
@@ -0,0 +1,11 @@+/* compiler/ghc-llvm-version.h. Generated from ghc-llvm-version.h.in by configure. */+#if !defined(__GHC_LLVM_VERSION_H__)+#define __GHC_LLVM_VERSION_H__++/* The maximum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MAX (13)++/* The minimum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MIN (9)++#endif /* __GHC_LLVM_VERSION_H__ */
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20211101+version: 0.20211201 license: BSD3 license-file: LICENSE category: Development@@ -17,9 +17,9 @@ llvm-targets llvm-passes extra-source-files:- ghc-lib/stage0/lib/ghcautoconf.h- ghc-lib/stage0/lib/ghcplatform.h- ghc-lib/stage0/lib/GhclibDerivedConstants.h+ ghc-lib/stage0/rts/build/include/ghcautoconf.h+ ghc-lib/stage0/rts/build/include/ghcplatform.h+ ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl ghc-lib/stage0/compiler/build/primop-code-size.hs-incl ghc-lib/stage0/compiler/build/primop-commutable.hs-incl@@ -36,14 +36,15 @@ ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/primop-docs.hs-incl+ ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs rts/include/ghcconfig.h- compiler/MachDeps.h compiler/MachRegs.h compiler/CodeGen.Platform.h compiler/Bytecodes.h compiler/ClosureTypes.h compiler/FunTypes.h compiler/Unique.h+ compiler/ghc-llvm-version.h source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git@@ -81,7 +82,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 0.20211101,+ ghc-lib-parser == 0.20211201, stm build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions:@@ -702,7 +703,6 @@ GHC.Stg.BcPrep GHC.Stg.CSE GHC.Stg.Debug- GHC.Stg.DepAnal GHC.Stg.FVs GHC.Stg.Lift GHC.Stg.Lift.Analysis
+ ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -0,0 +1,302 @@+module GHC.Platform.Constants where++import Prelude+import Data.Char++data PlatformConstants = PlatformConstants {+ pc_CONTROL_GROUP_CONST_291 :: {-# UNPACK #-} !Int,+ pc_STD_HDR_SIZE :: {-# UNPACK #-} !Int,+ pc_PROF_HDR_SIZE :: {-# UNPACK #-} !Int,+ pc_BLOCK_SIZE :: {-# UNPACK #-} !Int,+ pc_BLOCKS_PER_MBLOCK :: {-# UNPACK #-} !Int,+ pc_TICKY_BIN_COUNT :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR7 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR8 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR9 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rR10 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rF6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rD6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rXMM6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rYMM6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM2 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM3 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM4 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM5 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rZMM6 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rL1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rSp :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rSpLim :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rHp :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rHpLim :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rCCCS :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rCurrentTSO :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rCurrentNursery :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgRegTable_rHpAlloc :: {-# UNPACK #-} !Int,+ pc_OFFSET_stgEagerBlackholeInfo :: {-# UNPACK #-} !Int,+ pc_OFFSET_stgGCEnter1 :: {-# UNPACK #-} !Int,+ pc_OFFSET_stgGCFun :: {-# UNPACK #-} !Int,+ pc_OFFSET_Capability_r :: {-# UNPACK #-} !Int,+ pc_OFFSET_bdescr_start :: {-# UNPACK #-} !Int,+ pc_OFFSET_bdescr_free :: {-# UNPACK #-} !Int,+ pc_OFFSET_bdescr_blocks :: {-# UNPACK #-} !Int,+ pc_OFFSET_bdescr_flags :: {-# UNPACK #-} !Int,+ pc_SIZEOF_CostCentreStack :: {-# UNPACK #-} !Int,+ pc_OFFSET_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,+ pc_REP_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,+ pc_OFFSET_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,+ pc_REP_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgHeader_ccs :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgHeader_ldvw :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgSMPThunkHeader :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgEntCounter_allocs :: {-# UNPACK #-} !Int,+ pc_REP_StgEntCounter_allocs :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgEntCounter_allocd :: {-# UNPACK #-} !Int,+ pc_REP_StgEntCounter_allocd :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgEntCounter_registeredp :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgSmallMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgArrBytes_NoHdr :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgArrBytes_bytes :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgTSO_alloc_limit :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgTSO_cccs :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgTSO_stackobj :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,+ pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,+ pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,+ pc_OFFSET_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,+ pc_REP_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,+ pc_MAX_SPEC_SELECTEE_SIZE :: {-# UNPACK #-} !Int,+ pc_MAX_SPEC_AP_SIZE :: {-# UNPACK #-} !Int,+ pc_MIN_PAYLOAD_SIZE :: {-# UNPACK #-} !Int,+ pc_MIN_INTLIKE :: {-# UNPACK #-} !Int,+ pc_MAX_INTLIKE :: {-# UNPACK #-} !Int,+ pc_MIN_CHARLIKE :: {-# UNPACK #-} !Int,+ pc_MAX_CHARLIKE :: {-# UNPACK #-} !Int,+ pc_MUT_ARR_PTRS_CARD_BITS :: {-# UNPACK #-} !Int,+ pc_MAX_Vanilla_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Float_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Double_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Long_REG :: {-# UNPACK #-} !Int,+ pc_MAX_XMM_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Real_Vanilla_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Real_Float_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Real_Double_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Real_XMM_REG :: {-# UNPACK #-} !Int,+ pc_MAX_Real_Long_REG :: {-# UNPACK #-} !Int,+ pc_RESERVED_C_STACK_BYTES :: {-# UNPACK #-} !Int,+ pc_RESERVED_STACK_WORDS :: {-# UNPACK #-} !Int,+ pc_AP_STACK_SPLIM :: {-# UNPACK #-} !Int,+ pc_WORD_SIZE :: {-# UNPACK #-} !Int,+ pc_CINT_SIZE :: {-# UNPACK #-} !Int,+ pc_CLONG_SIZE :: {-# UNPACK #-} !Int,+ pc_CLONG_LONG_SIZE :: {-# UNPACK #-} !Int,+ pc_BITMAP_BITS_SHIFT :: {-# UNPACK #-} !Int,+ pc_TAG_BITS :: {-# UNPACK #-} !Int,+ pc_LDV_SHIFT :: {-# UNPACK #-} !Int,+ pc_ILDV_CREATE_MASK :: !Integer,+ pc_ILDV_STATE_CREATE :: !Integer,+ pc_ILDV_STATE_USE :: !Integer,+ pc_USE_INLINE_SRT_FIELD :: !Bool+ } deriving (Show,Read,Eq)+++parseConstantsHeader :: FilePath -> IO PlatformConstants+parseConstantsHeader fp = do+ s <- readFile fp+ let def = "#define HS_CONSTANTS \""+ find [] xs = xs+ find _ [] = error $ "GHC couldn't find the RTS constants ("++def++") in " ++ fp ++ ": the RTS package you are trying to use is perhaps for another GHC version" +++ "(e.g. you are using the wrong package database) or the package database is broken.\n"+ find (d:ds) (x:xs)+ | d == x = find ds xs+ | otherwise = find def xs++ readVal' :: Bool -> Integer -> String -> [Integer]+ readVal' n c (x:xs) = case x of+ '"' -> [if n then negate c else c]+ '-' -> readVal' True c xs+ ',' -> (if n then negate c else c) : readVal' False 0 xs+ _ -> readVal' n (c*10 + fromIntegral (ord x - ord '0')) xs+ readVal' n c [] = [if n then negate c else c]++ readVal = readVal' False 0++ return $! case readVal (find def s) of+ [v0,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15+ ,v16,v17,v18,v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,v31+ ,v32,v33,v34,v35,v36,v37,v38,v39,v40,v41,v42,v43,v44,v45,v46,v47+ ,v48,v49,v50,v51,v52,v53,v54,v55,v56,v57,v58,v59,v60,v61,v62,v63+ ,v64,v65,v66,v67,v68,v69,v70,v71,v72,v73,v74,v75,v76,v77,v78,v79+ ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95+ ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111+ ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127+ ,v128+ ] -> PlatformConstants+ { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0+ , pc_STD_HDR_SIZE = fromIntegral v1+ , pc_PROF_HDR_SIZE = fromIntegral v2+ , pc_BLOCK_SIZE = fromIntegral v3+ , pc_BLOCKS_PER_MBLOCK = fromIntegral v4+ , pc_TICKY_BIN_COUNT = fromIntegral v5+ , pc_OFFSET_StgRegTable_rR1 = fromIntegral v6+ , pc_OFFSET_StgRegTable_rR2 = fromIntegral v7+ , pc_OFFSET_StgRegTable_rR3 = fromIntegral v8+ , pc_OFFSET_StgRegTable_rR4 = fromIntegral v9+ , pc_OFFSET_StgRegTable_rR5 = fromIntegral v10+ , pc_OFFSET_StgRegTable_rR6 = fromIntegral v11+ , pc_OFFSET_StgRegTable_rR7 = fromIntegral v12+ , pc_OFFSET_StgRegTable_rR8 = fromIntegral v13+ , pc_OFFSET_StgRegTable_rR9 = fromIntegral v14+ , pc_OFFSET_StgRegTable_rR10 = fromIntegral v15+ , pc_OFFSET_StgRegTable_rF1 = fromIntegral v16+ , pc_OFFSET_StgRegTable_rF2 = fromIntegral v17+ , pc_OFFSET_StgRegTable_rF3 = fromIntegral v18+ , pc_OFFSET_StgRegTable_rF4 = fromIntegral v19+ , pc_OFFSET_StgRegTable_rF5 = fromIntegral v20+ , pc_OFFSET_StgRegTable_rF6 = fromIntegral v21+ , pc_OFFSET_StgRegTable_rD1 = fromIntegral v22+ , pc_OFFSET_StgRegTable_rD2 = fromIntegral v23+ , pc_OFFSET_StgRegTable_rD3 = fromIntegral v24+ , pc_OFFSET_StgRegTable_rD4 = fromIntegral v25+ , pc_OFFSET_StgRegTable_rD5 = fromIntegral v26+ , pc_OFFSET_StgRegTable_rD6 = fromIntegral v27+ , pc_OFFSET_StgRegTable_rXMM1 = fromIntegral v28+ , pc_OFFSET_StgRegTable_rXMM2 = fromIntegral v29+ , pc_OFFSET_StgRegTable_rXMM3 = fromIntegral v30+ , pc_OFFSET_StgRegTable_rXMM4 = fromIntegral v31+ , pc_OFFSET_StgRegTable_rXMM5 = fromIntegral v32+ , pc_OFFSET_StgRegTable_rXMM6 = fromIntegral v33+ , pc_OFFSET_StgRegTable_rYMM1 = fromIntegral v34+ , pc_OFFSET_StgRegTable_rYMM2 = fromIntegral v35+ , pc_OFFSET_StgRegTable_rYMM3 = fromIntegral v36+ , pc_OFFSET_StgRegTable_rYMM4 = fromIntegral v37+ , pc_OFFSET_StgRegTable_rYMM5 = fromIntegral v38+ , pc_OFFSET_StgRegTable_rYMM6 = fromIntegral v39+ , pc_OFFSET_StgRegTable_rZMM1 = fromIntegral v40+ , pc_OFFSET_StgRegTable_rZMM2 = fromIntegral v41+ , pc_OFFSET_StgRegTable_rZMM3 = fromIntegral v42+ , pc_OFFSET_StgRegTable_rZMM4 = fromIntegral v43+ , pc_OFFSET_StgRegTable_rZMM5 = fromIntegral v44+ , pc_OFFSET_StgRegTable_rZMM6 = fromIntegral v45+ , pc_OFFSET_StgRegTable_rL1 = fromIntegral v46+ , pc_OFFSET_StgRegTable_rSp = fromIntegral v47+ , pc_OFFSET_StgRegTable_rSpLim = fromIntegral v48+ , pc_OFFSET_StgRegTable_rHp = fromIntegral v49+ , pc_OFFSET_StgRegTable_rHpLim = fromIntegral v50+ , pc_OFFSET_StgRegTable_rCCCS = fromIntegral v51+ , pc_OFFSET_StgRegTable_rCurrentTSO = fromIntegral v52+ , pc_OFFSET_StgRegTable_rCurrentNursery = fromIntegral v53+ , pc_OFFSET_StgRegTable_rHpAlloc = fromIntegral v54+ , pc_OFFSET_stgEagerBlackholeInfo = fromIntegral v55+ , pc_OFFSET_stgGCEnter1 = fromIntegral v56+ , pc_OFFSET_stgGCFun = fromIntegral v57+ , pc_OFFSET_Capability_r = fromIntegral v58+ , pc_OFFSET_bdescr_start = fromIntegral v59+ , pc_OFFSET_bdescr_free = fromIntegral v60+ , pc_OFFSET_bdescr_blocks = fromIntegral v61+ , pc_OFFSET_bdescr_flags = fromIntegral v62+ , pc_SIZEOF_CostCentreStack = fromIntegral v63+ , pc_OFFSET_CostCentreStack_mem_alloc = fromIntegral v64+ , pc_REP_CostCentreStack_mem_alloc = fromIntegral v65+ , pc_OFFSET_CostCentreStack_scc_count = fromIntegral v66+ , pc_REP_CostCentreStack_scc_count = fromIntegral v67+ , pc_OFFSET_StgHeader_ccs = fromIntegral v68+ , pc_OFFSET_StgHeader_ldvw = fromIntegral v69+ , pc_SIZEOF_StgSMPThunkHeader = fromIntegral v70+ , pc_OFFSET_StgEntCounter_allocs = fromIntegral v71+ , pc_REP_StgEntCounter_allocs = fromIntegral v72+ , pc_OFFSET_StgEntCounter_allocd = fromIntegral v73+ , pc_REP_StgEntCounter_allocd = fromIntegral v74+ , pc_OFFSET_StgEntCounter_registeredp = fromIntegral v75+ , pc_OFFSET_StgEntCounter_link = fromIntegral v76+ , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77+ , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78+ , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79+ , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80+ , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81+ , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82+ , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83+ , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84+ , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85+ , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86+ , pc_OFFSET_StgTSO_cccs = fromIntegral v87+ , pc_OFFSET_StgTSO_stackobj = fromIntegral v88+ , pc_OFFSET_StgStack_sp = fromIntegral v89+ , pc_OFFSET_StgStack_stack = fromIntegral v90+ , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91+ , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92+ , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93+ , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94+ , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95+ , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96+ , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97+ , pc_MAX_SPEC_AP_SIZE = fromIntegral v98+ , pc_MIN_PAYLOAD_SIZE = fromIntegral v99+ , pc_MIN_INTLIKE = fromIntegral v100+ , pc_MAX_INTLIKE = fromIntegral v101+ , pc_MIN_CHARLIKE = fromIntegral v102+ , pc_MAX_CHARLIKE = fromIntegral v103+ , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104+ , pc_MAX_Vanilla_REG = fromIntegral v105+ , pc_MAX_Float_REG = fromIntegral v106+ , pc_MAX_Double_REG = fromIntegral v107+ , pc_MAX_Long_REG = fromIntegral v108+ , pc_MAX_XMM_REG = fromIntegral v109+ , pc_MAX_Real_Vanilla_REG = fromIntegral v110+ , pc_MAX_Real_Float_REG = fromIntegral v111+ , pc_MAX_Real_Double_REG = fromIntegral v112+ , pc_MAX_Real_XMM_REG = fromIntegral v113+ , pc_MAX_Real_Long_REG = fromIntegral v114+ , pc_RESERVED_C_STACK_BYTES = fromIntegral v115+ , pc_RESERVED_STACK_WORDS = fromIntegral v116+ , pc_AP_STACK_SPLIM = fromIntegral v117+ , pc_WORD_SIZE = fromIntegral v118+ , pc_CINT_SIZE = fromIntegral v119+ , pc_CLONG_SIZE = fromIntegral v120+ , pc_CLONG_LONG_SIZE = fromIntegral v121+ , pc_BITMAP_BITS_SHIFT = fromIntegral v122+ , pc_TAG_BITS = fromIntegral v123+ , pc_LDV_SHIFT = fromIntegral v124+ , pc_ILDV_CREATE_MASK = v125+ , pc_ILDV_STATE_CREATE = v126+ , pc_ILDV_STATE_USE = v127+ , pc_USE_INLINE_SRT_FIELD = 0 < v128+ }+ _ -> error "Invalid platform constants"+
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -220,36 +220,36 @@ 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 PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#") [] [word64PrimTy] (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 Pdep64Op = mkGenPrimOp (fsLit "pdep64#") [] [word64PrimTy, word64PrimTy] (word64PrimTy) 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 Pext64Op = mkGenPrimOp (fsLit "pext64#") [] [word64PrimTy, word64PrimTy] (word64PrimTy) 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 Clz64Op = mkGenPrimOp (fsLit "clz64#") [] [word64PrimTy] (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 Ctz64Op = mkGenPrimOp (fsLit "ctz64#") [] [word64PrimTy] (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 BSwap64Op = mkGenPrimOp (fsLit "byteSwap64#") [] [word64PrimTy] (word64PrimTy) 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 BRev64Op = mkGenPrimOp (fsLit "bitReverse64#") [] [word64PrimTy] (word64PrimTy) primOpInfo BRevOp = mkGenPrimOp (fsLit "bitReverse#") [] [wordPrimTy] (wordPrimTy) primOpInfo Narrow8IntOp = mkGenPrimOp (fsLit "narrow8Int#") [] [intPrimTy] (intPrimTy) primOpInfo Narrow16IntOp = mkGenPrimOp (fsLit "narrow16Int#") [] [intPrimTy] (intPrimTy)@@ -290,7 +290,7 @@ 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 DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#") [] [doublePrimTy] ((mkTupleTy Unboxed [int64PrimTy, intPrimTy])) primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy@@ -380,11 +380,11 @@ primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (int8PrimTy) primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (word8PrimTy) primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)@@ -395,10 +395,10 @@ primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#") [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (word16PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -410,11 +410,11 @@ primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -425,10 +425,10 @@ primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -440,11 +440,11 @@ primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -455,10 +455,10 @@ primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -472,7 +472,7 @@ primOpInfo CasByteArrayOp_Int8 = mkGenPrimOp (fsLit "casInt8Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, int8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) primOpInfo CasByteArrayOp_Int16 = mkGenPrimOp (fsLit "casInt16Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, int16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo CasByteArrayOp_Int32 = mkGenPrimOp (fsLit "casInt32Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, int32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo CasByteArrayOp_Int64 = mkGenPrimOp (fsLit "casInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo CasByteArrayOp_Int64 = mkGenPrimOp (fsLit "casInt64Array#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, int64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -517,11 +517,11 @@ primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (int8PrimTy) primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (word8PrimTy) primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (word16PrimTy) primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (word32PrimTy)-primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -533,11 +533,11 @@ primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy])) primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -549,11 +549,11 @@ primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#") [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#") [deltaTyVarSpec] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))@@ -561,7 +561,7 @@ primOpInfo CasAddrOp_Word8 = mkGenPrimOp (fsLit "atomicCasWord8Addr#") [deltaTyVarSpec] [addrPrimTy, word8PrimTy, word8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy])) primOpInfo CasAddrOp_Word16 = mkGenPrimOp (fsLit "atomicCasWord16Addr#") [deltaTyVarSpec] [addrPrimTy, word16PrimTy, word16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy])) primOpInfo CasAddrOp_Word32 = mkGenPrimOp (fsLit "atomicCasWord32Addr#") [deltaTyVarSpec] [addrPrimTy, word32PrimTy, word32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))-primOpInfo CasAddrOp_Word64 = mkGenPrimOp (fsLit "atomicCasWord64Addr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo CasAddrOp_Word64 = mkGenPrimOp (fsLit "atomicCasWord64Addr#") [deltaTyVarSpec] [addrPrimTy, word64PrimTy, word64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))@@ -659,31 +659,31 @@ primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [int64PrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [int8PrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [int16PrimTy] (int16X8PrimTy) primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [int32PrimTy] (int32X4PrimTy)-primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [intPrimTy] (int64X2PrimTy)+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [int64PrimTy] (int64X2PrimTy) primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [int8PrimTy] (int8X32PrimTy) primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [int16PrimTy] (int16X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [int32PrimTy] (int32X8PrimTy)-primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [intPrimTy] (int64X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [int64PrimTy] (int64X4PrimTy) primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [int8PrimTy] (int8X64PrimTy) primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [int16PrimTy] (int16X32PrimTy) primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [int32PrimTy] (int32X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [intPrimTy] (int64X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [int64PrimTy] (int64X8PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [word32PrimTy] (word32X4PrimTy)-primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [wordPrimTy] (word64X2PrimTy)+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [word64PrimTy] (word64X2PrimTy) primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [word32PrimTy] (word32X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [wordPrimTy] (word64X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [word64PrimTy] (word64X4PrimTy) primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [word32PrimTy] (word32X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [wordPrimTy] (word64X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [word64PrimTy] (word64X8PrimTy) primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy)@@ -693,27 +693,27 @@ primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy) primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy) primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy)-primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy])] (int64X2PrimTy) primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy) primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy) primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy)-primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X4PrimTy) primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy) primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy) primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X8PrimTy) primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy)-primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy])] (word64X2PrimTy) primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy)-primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X4PrimTy) primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X8PrimTy) primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)@@ -723,27 +723,27 @@ primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy])) primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])) primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])) primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])) primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy])) primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy])) primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))@@ -753,27 +753,27 @@ primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, int64PrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, int64PrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, int64PrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, word64PrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, word64PrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, word64PrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)
− ghc-lib/stage0/lib/GhclibDerivedConstants.h
@@ -1,559 +0,0 @@-/* This file is created automatically. Do not edit by hand.*/--#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,48,8,16,8,0,56,40,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976"-#define CONTROL_GROUP_CONST_291 291-#define STD_HDR_SIZE 1-#define PROF_HDR_SIZE 2-#define STACK_DIRTY 1-#define BLOCK_SIZE 4096-#define MBLOCK_SIZE 1048576-#define BLOCKS_PER_MBLOCK 252-#define TICKY_BIN_COUNT 9-#define OFFSET_StgRegTable_rR1 0-#define OFFSET_StgRegTable_rR2 8-#define OFFSET_StgRegTable_rR3 16-#define OFFSET_StgRegTable_rR4 24-#define OFFSET_StgRegTable_rR5 32-#define OFFSET_StgRegTable_rR6 40-#define OFFSET_StgRegTable_rR7 48-#define OFFSET_StgRegTable_rR8 56-#define OFFSET_StgRegTable_rR9 64-#define OFFSET_StgRegTable_rR10 72-#define OFFSET_StgRegTable_rF1 80-#define OFFSET_StgRegTable_rF2 84-#define OFFSET_StgRegTable_rF3 88-#define OFFSET_StgRegTable_rF4 92-#define OFFSET_StgRegTable_rF5 96-#define OFFSET_StgRegTable_rF6 100-#define OFFSET_StgRegTable_rD1 104-#define OFFSET_StgRegTable_rD2 112-#define OFFSET_StgRegTable_rD3 120-#define OFFSET_StgRegTable_rD4 128-#define OFFSET_StgRegTable_rD5 136-#define OFFSET_StgRegTable_rD6 144-#define OFFSET_StgRegTable_rXMM1 152-#define OFFSET_StgRegTable_rXMM2 168-#define OFFSET_StgRegTable_rXMM3 184-#define OFFSET_StgRegTable_rXMM4 200-#define OFFSET_StgRegTable_rXMM5 216-#define OFFSET_StgRegTable_rXMM6 232-#define OFFSET_StgRegTable_rYMM1 248-#define OFFSET_StgRegTable_rYMM2 280-#define OFFSET_StgRegTable_rYMM3 312-#define OFFSET_StgRegTable_rYMM4 344-#define OFFSET_StgRegTable_rYMM5 376-#define OFFSET_StgRegTable_rYMM6 408-#define OFFSET_StgRegTable_rZMM1 440-#define OFFSET_StgRegTable_rZMM2 504-#define OFFSET_StgRegTable_rZMM3 568-#define OFFSET_StgRegTable_rZMM4 632-#define OFFSET_StgRegTable_rZMM5 696-#define OFFSET_StgRegTable_rZMM6 760-#define OFFSET_StgRegTable_rL1 824-#define OFFSET_StgRegTable_rSp 832-#define OFFSET_StgRegTable_rSpLim 840-#define OFFSET_StgRegTable_rHp 848-#define OFFSET_StgRegTable_rHpLim 856-#define OFFSET_StgRegTable_rCCCS 864-#define OFFSET_StgRegTable_rCurrentTSO 872-#define OFFSET_StgRegTable_rCurrentNursery 888-#define OFFSET_StgRegTable_rHpAlloc 904-#define OFFSET_StgRegTable_rRet 912-#define REP_StgRegTable_rRet b64-#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]-#define OFFSET_StgRegTable_rNursery 880-#define REP_StgRegTable_rNursery b64-#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]-#define OFFSET_stgEagerBlackholeInfo -24-#define OFFSET_stgGCEnter1 -16-#define OFFSET_stgGCFun -8-#define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216-#define OFFSET_Capability_no 944-#define REP_Capability_no b32-#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]-#define OFFSET_Capability_mut_lists 1016-#define REP_Capability_mut_lists b64-#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184-#define REP_Capability_context_switch b32-#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188-#define REP_Capability_interrupt b32-#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320-#define REP_Capability_sparks b64-#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192-#define REP_Capability_total_allocated b64-#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168-#define REP_Capability_weak_ptr_list_hd b64-#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176-#define REP_Capability_weak_ptr_list_tl b64-#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]-#define OFFSET_bdescr_start 0-#define REP_bdescr_start b64-#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]-#define OFFSET_bdescr_free 8-#define REP_bdescr_free b64-#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]-#define OFFSET_bdescr_blocks 48-#define REP_bdescr_blocks b32-#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]-#define OFFSET_bdescr_gen_no 40-#define REP_bdescr_gen_no b16-#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]-#define OFFSET_bdescr_link 16-#define REP_bdescr_link b64-#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]-#define OFFSET_bdescr_flags 46-#define REP_bdescr_flags b16-#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]-#define SIZEOF_generation 384-#define OFFSET_generation_n_new_large_words 56-#define REP_generation_n_new_large_words b64-#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]-#define OFFSET_generation_weak_ptr_list 112-#define REP_generation_weak_ptr_list b64-#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]-#define SIZEOF_CostCentreStack 96-#define OFFSET_CostCentreStack_ccsID 0-#define REP_CostCentreStack_ccsID b64-#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]-#define OFFSET_CostCentreStack_mem_alloc 72-#define REP_CostCentreStack_mem_alloc b64-#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]-#define OFFSET_CostCentreStack_scc_count 48-#define REP_CostCentreStack_scc_count b64-#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]-#define OFFSET_CostCentreStack_prevStack 16-#define REP_CostCentreStack_prevStack b64-#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]-#define OFFSET_CostCentre_ccID 0-#define REP_CostCentre_ccID b64-#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]-#define OFFSET_CostCentre_link 56-#define REP_CostCentre_link b64-#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]-#define OFFSET_StgHeader_info 0-#define REP_StgHeader_info b64-#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]-#define OFFSET_StgHeader_ccs 8-#define REP_StgHeader_ccs b64-#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]-#define OFFSET_StgHeader_ldvw 16-#define REP_StgHeader_ldvw b64-#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]-#define SIZEOF_StgSMPThunkHeader 8-#define OFFSET_StgClosure_payload 0-#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]-#define OFFSET_StgEntCounter_allocs 48-#define REP_StgEntCounter_allocs b64-#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]-#define OFFSET_StgEntCounter_allocd 16-#define REP_StgEntCounter_allocd b64-#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]-#define OFFSET_StgEntCounter_registeredp 0-#define REP_StgEntCounter_registeredp b64-#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]-#define OFFSET_StgEntCounter_link 56-#define REP_StgEntCounter_link b64-#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]-#define OFFSET_StgEntCounter_entry_count 40-#define REP_StgEntCounter_entry_count b64-#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]-#define SIZEOF_StgUpdateFrame_NoHdr 8-#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)-#define SIZEOF_StgCatchFrame_NoHdr 16-#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)-#define SIZEOF_StgStopFrame_NoHdr 0-#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)-#define SIZEOF_StgMutArrPtrs_NoHdr 16-#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)-#define OFFSET_StgMutArrPtrs_ptrs 0-#define REP_StgMutArrPtrs_ptrs b64-#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]-#define OFFSET_StgMutArrPtrs_size 8-#define REP_StgMutArrPtrs_size b64-#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]-#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8-#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)-#define OFFSET_StgSmallMutArrPtrs_ptrs 0-#define REP_StgSmallMutArrPtrs_ptrs b64-#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]-#define SIZEOF_StgArrBytes_NoHdr 8-#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)-#define OFFSET_StgArrBytes_bytes 0-#define REP_StgArrBytes_bytes b64-#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]-#define OFFSET_StgArrBytes_payload 8-#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]-#define OFFSET_StgTSO__link 0-#define REP_StgTSO__link b64-#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]-#define OFFSET_StgTSO_global_link 8-#define REP_StgTSO_global_link b64-#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]-#define OFFSET_StgTSO_what_next 24-#define REP_StgTSO_what_next b16-#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]-#define OFFSET_StgTSO_why_blocked 26-#define REP_StgTSO_why_blocked b16-#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]-#define OFFSET_StgTSO_block_info 32-#define REP_StgTSO_block_info b64-#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]-#define OFFSET_StgTSO_blocked_exceptions 80-#define REP_StgTSO_blocked_exceptions b64-#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]-#define OFFSET_StgTSO_id 40-#define REP_StgTSO_id b64-#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]-#define OFFSET_StgTSO_cap 64-#define REP_StgTSO_cap b64-#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 48-#define REP_StgTSO_saved_errno b32-#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]-#define OFFSET_StgTSO_trec 72-#define REP_StgTSO_trec b64-#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]-#define OFFSET_StgTSO_flags 28-#define REP_StgTSO_flags b32-#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 52-#define REP_StgTSO_dirty b32-#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]-#define OFFSET_StgTSO_bq 88-#define REP_StgTSO_bq b64-#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]-#define OFFSET_StgTSO_alloc_limit 96-#define REP_StgTSO_alloc_limit b64-#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]-#define OFFSET_StgTSO_cccs 112-#define REP_StgTSO_cccs b64-#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]-#define OFFSET_StgTSO_stackobj 16-#define REP_StgTSO_stackobj b64-#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]-#define OFFSET_StgStack_sp 8-#define REP_StgStack_sp b64-#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]-#define OFFSET_StgStack_stack 16-#define OFFSET_StgStack_stack_size 0-#define REP_StgStack_stack_size b32-#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]-#define OFFSET_StgStack_dirty 4-#define REP_StgStack_dirty b8-#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]-#define SIZEOF_StgTSOProfInfo 8-#define OFFSET_StgUpdateFrame_updatee 0-#define REP_StgUpdateFrame_updatee b64-#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]-#define OFFSET_StgCatchFrame_handler 8-#define REP_StgCatchFrame_handler b64-#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]-#define OFFSET_StgCatchFrame_exceptions_blocked 0-#define REP_StgCatchFrame_exceptions_blocked b64-#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]-#define SIZEOF_StgPAP_NoHdr 16-#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)-#define OFFSET_StgPAP_n_args 4-#define REP_StgPAP_n_args b32-#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]-#define OFFSET_StgPAP_fun 8-#define REP_StgPAP_fun gcptr-#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]-#define OFFSET_StgPAP_arity 0-#define REP_StgPAP_arity b32-#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]-#define OFFSET_StgPAP_payload 16-#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_NoThunkHdr 16-#define SIZEOF_StgAP_NoHdr 24-#define SIZEOF_StgAP (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_n_args 12-#define REP_StgAP_n_args b32-#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]-#define OFFSET_StgAP_fun 16-#define REP_StgAP_fun gcptr-#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]-#define OFFSET_StgAP_payload 24-#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_STACK_NoThunkHdr 16-#define SIZEOF_StgAP_STACK_NoHdr 24-#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_STACK_size 8-#define REP_StgAP_STACK_size b64-#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]-#define OFFSET_StgAP_STACK_fun 16-#define REP_StgAP_STACK_fun gcptr-#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]-#define OFFSET_StgAP_STACK_payload 24-#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]-#define SIZEOF_StgSelector_NoThunkHdr 8-#define SIZEOF_StgSelector_NoHdr 16-#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)-#define OFFSET_StgInd_indirectee 0-#define REP_StgInd_indirectee gcptr-#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]-#define SIZEOF_StgMutVar_NoHdr 8-#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)-#define OFFSET_StgMutVar_var 0-#define REP_StgMutVar_var b64-#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]-#define SIZEOF_StgAtomicallyFrame_NoHdr 16-#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgAtomicallyFrame_code 0-#define REP_StgAtomicallyFrame_code b64-#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]-#define OFFSET_StgAtomicallyFrame_result 8-#define REP_StgAtomicallyFrame_result b64-#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]-#define OFFSET_StgTRecHeader_enclosing_trec 0-#define REP_StgTRecHeader_enclosing_trec b64-#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]-#define SIZEOF_StgCatchSTMFrame_NoHdr 16-#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgCatchSTMFrame_handler 8-#define REP_StgCatchSTMFrame_handler b64-#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]-#define OFFSET_StgCatchSTMFrame_code 0-#define REP_StgCatchSTMFrame_code b64-#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]-#define SIZEOF_StgCatchRetryFrame_NoHdr 24-#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)-#define OFFSET_StgCatchRetryFrame_running_alt_code 0-#define REP_StgCatchRetryFrame_running_alt_code b64-#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]-#define OFFSET_StgCatchRetryFrame_first_code 8-#define REP_StgCatchRetryFrame_first_code b64-#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]-#define OFFSET_StgCatchRetryFrame_alt_code 16-#define REP_StgCatchRetryFrame_alt_code b64-#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]-#define OFFSET_StgTVarWatchQueue_closure 0-#define REP_StgTVarWatchQueue_closure b64-#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]-#define OFFSET_StgTVarWatchQueue_next_queue_entry 8-#define REP_StgTVarWatchQueue_next_queue_entry b64-#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]-#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16-#define REP_StgTVarWatchQueue_prev_queue_entry b64-#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]-#define SIZEOF_StgTVar_NoHdr 24-#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)-#define OFFSET_StgTVar_current_value 0-#define REP_StgTVar_current_value b64-#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]-#define OFFSET_StgTVar_first_watch_queue_entry 8-#define REP_StgTVar_first_watch_queue_entry b64-#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]-#define OFFSET_StgTVar_num_updates 16-#define REP_StgTVar_num_updates b64-#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]-#define SIZEOF_StgWeak_NoHdr 40-#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)-#define OFFSET_StgWeak_link 32-#define REP_StgWeak_link b64-#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]-#define OFFSET_StgWeak_key 8-#define REP_StgWeak_key b64-#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]-#define OFFSET_StgWeak_value 16-#define REP_StgWeak_value b64-#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]-#define OFFSET_StgWeak_finalizer 24-#define REP_StgWeak_finalizer b64-#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]-#define OFFSET_StgWeak_cfinalizers 0-#define REP_StgWeak_cfinalizers b64-#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]-#define SIZEOF_StgCFinalizerList_NoHdr 40-#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)-#define OFFSET_StgCFinalizerList_link 0-#define REP_StgCFinalizerList_link b64-#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]-#define OFFSET_StgCFinalizerList_fptr 8-#define REP_StgCFinalizerList_fptr b64-#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]-#define OFFSET_StgCFinalizerList_ptr 16-#define REP_StgCFinalizerList_ptr b64-#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]-#define OFFSET_StgCFinalizerList_eptr 24-#define REP_StgCFinalizerList_eptr b64-#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]-#define OFFSET_StgCFinalizerList_flag 32-#define REP_StgCFinalizerList_flag b64-#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]-#define SIZEOF_StgMVar_NoHdr 24-#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)-#define OFFSET_StgMVar_head 0-#define REP_StgMVar_head b64-#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]-#define OFFSET_StgMVar_tail 8-#define REP_StgMVar_tail b64-#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]-#define OFFSET_StgMVar_value 16-#define REP_StgMVar_value b64-#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]-#define SIZEOF_StgMVarTSOQueue_NoHdr 16-#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)-#define OFFSET_StgMVarTSOQueue_link 0-#define REP_StgMVarTSOQueue_link b64-#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]-#define OFFSET_StgMVarTSOQueue_tso 8-#define REP_StgMVarTSOQueue_tso b64-#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]-#define SIZEOF_StgBCO_NoHdr 32-#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)-#define OFFSET_StgBCO_instrs 0-#define REP_StgBCO_instrs b64-#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]-#define OFFSET_StgBCO_literals 8-#define REP_StgBCO_literals b64-#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]-#define OFFSET_StgBCO_ptrs 16-#define REP_StgBCO_ptrs b64-#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]-#define OFFSET_StgBCO_arity 24-#define REP_StgBCO_arity b32-#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]-#define OFFSET_StgBCO_size 28-#define REP_StgBCO_size b32-#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]-#define OFFSET_StgBCO_bitmap 32-#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]-#define SIZEOF_StgStableName_NoHdr 8-#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)-#define OFFSET_StgStableName_sn 0-#define REP_StgStableName_sn b64-#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]-#define SIZEOF_StgBlockingQueue_NoHdr 32-#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)-#define OFFSET_StgBlockingQueue_bh 8-#define REP_StgBlockingQueue_bh b64-#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]-#define OFFSET_StgBlockingQueue_owner 16-#define REP_StgBlockingQueue_owner b64-#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]-#define OFFSET_StgBlockingQueue_queue 24-#define REP_StgBlockingQueue_queue b64-#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]-#define OFFSET_StgBlockingQueue_link 0-#define REP_StgBlockingQueue_link b64-#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]-#define SIZEOF_MessageBlackHole_NoHdr 24-#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)-#define OFFSET_MessageBlackHole_link 0-#define REP_MessageBlackHole_link b64-#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]-#define OFFSET_MessageBlackHole_tso 8-#define REP_MessageBlackHole_tso b64-#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]-#define OFFSET_MessageBlackHole_bh 16-#define REP_MessageBlackHole_bh b64-#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]-#define SIZEOF_StgCompactNFData_NoHdr 72-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)-#define OFFSET_StgCompactNFData_totalW 0-#define REP_StgCompactNFData_totalW b64-#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]-#define OFFSET_StgCompactNFData_autoBlockW 8-#define REP_StgCompactNFData_autoBlockW b64-#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]-#define OFFSET_StgCompactNFData_nursery 32-#define REP_StgCompactNFData_nursery b64-#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]-#define OFFSET_StgCompactNFData_last 40-#define REP_StgCompactNFData_last b64-#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]-#define OFFSET_StgCompactNFData_hp 16-#define REP_StgCompactNFData_hp b64-#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]-#define OFFSET_StgCompactNFData_hpLim 24-#define REP_StgCompactNFData_hpLim b64-#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]-#define OFFSET_StgCompactNFData_hash 48-#define REP_StgCompactNFData_hash b64-#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]-#define OFFSET_StgCompactNFData_result 56-#define REP_StgCompactNFData_result b64-#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]-#define SIZEOF_StgCompactNFDataBlock 24-#define OFFSET_StgCompactNFDataBlock_self 0-#define REP_StgCompactNFDataBlock_self b64-#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]-#define OFFSET_StgCompactNFDataBlock_owner 8-#define REP_StgCompactNFDataBlock_owner b64-#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]-#define OFFSET_StgCompactNFDataBlock_next 16-#define REP_StgCompactNFDataBlock_next b64-#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280-#define REP_RtsFlags_ProfFlags_doHeapProfile b32-#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301-#define REP_RtsFlags_ProfFlags_showCCSOnException b8-#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 244-#define REP_RtsFlags_DebugFlags_apply b8-#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 239-#define REP_RtsFlags_DebugFlags_sanity b8-#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 234-#define REP_RtsFlags_DebugFlags_weak b8-#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]-#define OFFSET_RtsFlags_GcFlags_initialStkSize 16-#define REP_RtsFlags_GcFlags_initialStkSize b32-#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 200-#define REP_RtsFlags_MiscFlags_tickInterval b64-#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]-#define SIZEOF_StgFunInfoExtraFwd 32-#define OFFSET_StgFunInfoExtraFwd_slow_apply 24-#define REP_StgFunInfoExtraFwd_slow_apply b64-#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]-#define OFFSET_StgFunInfoExtraFwd_fun_type 0-#define REP_StgFunInfoExtraFwd_fun_type b32-#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]-#define OFFSET_StgFunInfoExtraFwd_arity 4-#define REP_StgFunInfoExtraFwd_arity b32-#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]-#define OFFSET_StgFunInfoExtraFwd_bitmap 16-#define REP_StgFunInfoExtraFwd_bitmap b64-#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]-#define SIZEOF_StgFunInfoExtraRev 24-#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0-#define REP_StgFunInfoExtraRev_slow_apply_offset b32-#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]-#define OFFSET_StgFunInfoExtraRev_fun_type 16-#define REP_StgFunInfoExtraRev_fun_type b32-#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]-#define OFFSET_StgFunInfoExtraRev_arity 20-#define REP_StgFunInfoExtraRev_arity b32-#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]-#define OFFSET_StgFunInfoExtraRev_bitmap 8-#define REP_StgFunInfoExtraRev_bitmap b64-#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]-#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8-#define REP_StgFunInfoExtraRev_bitmap_offset b32-#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]-#define OFFSET_StgLargeBitmap_size 0-#define REP_StgLargeBitmap_size b64-#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]-#define OFFSET_StgLargeBitmap_bitmap 8-#define SIZEOF_snEntry 24-#define OFFSET_snEntry_sn_obj 16-#define REP_snEntry_sn_obj b64-#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]-#define OFFSET_snEntry_addr 0-#define REP_snEntry_addr b64-#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]-#define SIZEOF_spEntry 8-#define OFFSET_spEntry_addr 0-#define REP_spEntry_addr b64-#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
− ghc-lib/stage0/lib/ghcautoconf.h
@@ -1,632 +0,0 @@-#if !defined(__GHCAUTOCONF_H__)-#define __GHCAUTOCONF_H__-/* mk/config.h. Generated from config.h.in by configure. */-/* mk/config.h.in. Generated from configure.ac by autoheader. */--/* Define if building universal (internal helper macro) */-/* #undef AC_APPLE_UNIVERSAL_BUILD */--/* The alignment of a `char'. */-#define ALIGNMENT_CHAR 1--/* The alignment of a `double'. */-#define ALIGNMENT_DOUBLE 8--/* The alignment of a `float'. */-#define ALIGNMENT_FLOAT 4--/* The alignment of a `int'. */-#define ALIGNMENT_INT 4--/* The alignment of a `int16_t'. */-#define ALIGNMENT_INT16_T 2--/* The alignment of a `int32_t'. */-#define ALIGNMENT_INT32_T 4--/* The alignment of a `int64_t'. */-#define ALIGNMENT_INT64_T 8--/* The alignment of a `int8_t'. */-#define ALIGNMENT_INT8_T 1--/* The alignment of a `long'. */-#define ALIGNMENT_LONG 8--/* The alignment of a `long long'. */-#define ALIGNMENT_LONG_LONG 8--/* The alignment of a `short'. */-#define ALIGNMENT_SHORT 2--/* The alignment of a `uint16_t'. */-#define ALIGNMENT_UINT16_T 2--/* The alignment of a `uint32_t'. */-#define ALIGNMENT_UINT32_T 4--/* The alignment of a `uint64_t'. */-#define ALIGNMENT_UINT64_T 8--/* The alignment of a `uint8_t'. */-#define ALIGNMENT_UINT8_T 1--/* The alignment of a `unsigned char'. */-#define ALIGNMENT_UNSIGNED_CHAR 1--/* The alignment of a `unsigned int'. */-#define ALIGNMENT_UNSIGNED_INT 4--/* The alignment of a `unsigned long'. */-#define ALIGNMENT_UNSIGNED_LONG 8--/* The alignment of a `unsigned long long'. */-#define ALIGNMENT_UNSIGNED_LONG_LONG 8--/* The alignment of a `unsigned short'. */-#define ALIGNMENT_UNSIGNED_SHORT 2--/* The alignment of a `void *'. */-#define ALIGNMENT_VOID_P 8--/* Define (to 1) if C compiler has an LLVM back end */-#define CC_LLVM_BACKEND 1--/* Define to 1 if __thread is supported */-#define CC_SUPPORTS_TLS 1--/* Define to 1 if using 'alloca.c'. */-/* #undef C_ALLOCA */--/* Enable Native I/O manager as default. */-/* #undef DEFAULT_NATIVE_IO_MANAGER */--/* Define to 1 if your processor stores words of floats with the most- significant byte first */-/* #undef FLOAT_WORDS_BIGENDIAN */--/* Has visibility hidden */-#define HAS_VISIBILITY_HIDDEN 1--/* Define to 1 if you have 'alloca', as a function or macro. */-#define HAVE_ALLOCA 1--/* Define to 1 if <alloca.h> works. */-#define HAVE_ALLOCA_H 1--/* Define to 1 if you have the <bfd.h> header file. */-/* #undef HAVE_BFD_H */--/* Does C compiler support __atomic primitives? */-#define HAVE_C11_ATOMICS 1--/* Define to 1 if you have the `clock_gettime' function. */-#define HAVE_CLOCK_GETTIME 1--/* Define to 1 if you have the `ctime_r' function. */-#define HAVE_CTIME_R 1--/* Define to 1 if you have the <ctype.h> header file. */-#define HAVE_CTYPE_H 1--/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you- don't. */-#define HAVE_DECL_CTIME_R 1--/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you- don't. */-/* #undef HAVE_DECL_MADV_DONTNEED */--/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you- don't. */-/* #undef HAVE_DECL_MADV_FREE */--/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you- don't. */-/* #undef HAVE_DECL_MAP_NORESERVE */--/* Define to 1 if you have the <dirent.h> header file. */-#define HAVE_DIRENT_H 1--/* Define to 1 if you have the <dlfcn.h> header file. */-#define HAVE_DLFCN_H 1--/* Define to 1 if you have the `dlinfo' function. */-/* #undef HAVE_DLINFO */--/* Define to 1 if you have the <elfutils/libdw.h> header file. */-/* #undef HAVE_ELFUTILS_LIBDW_H */--/* Define to 1 if you have the <errno.h> header file. */-#define HAVE_ERRNO_H 1--/* Define to 1 if you have the `eventfd' function. */-/* #undef HAVE_EVENTFD */--/* Define to 1 if you have the <fcntl.h> header file. */-#define HAVE_FCNTL_H 1--/* Define to 1 if you have the <ffi.h> header file. */-/* #undef HAVE_FFI_H */--/* Define to 1 if you have the `fork' function. */-#define HAVE_FORK 1--/* Define to 1 if you have the `getclock' function. */-/* #undef HAVE_GETCLOCK */--/* Define to 1 if you have the `GetModuleFileName' function. */-/* #undef HAVE_GETMODULEFILENAME */--/* Define to 1 if you have the `getrusage' function. */-#define HAVE_GETRUSAGE 1--/* Define to 1 if you have the `gettimeofday' function. */-#define HAVE_GETTIMEOFDAY 1--/* Define to 1 if you have the <grp.h> header file. */-#define HAVE_GRP_H 1--/* Define to 1 if you have the <inttypes.h> header file. */-#define HAVE_INTTYPES_H 1--/* Define to 1 if you have the `bfd' library (-lbfd). */-/* #undef HAVE_LIBBFD */--/* Define to 1 if you have the `dl' library (-ldl). */-#define HAVE_LIBDL 1--/* Define to 1 if you have the `iberty' library (-liberty). */-/* #undef HAVE_LIBIBERTY */--/* Define to 1 if you need to link with libm */-#define HAVE_LIBM 1--/* Define to 1 if you have libnuma */-#define HAVE_LIBNUMA 0--/* Define to 1 if you have the `pthread' library (-lpthread). */-#define HAVE_LIBPTHREAD 1--/* Define to 1 if you have the `rt' library (-lrt). */-/* #undef HAVE_LIBRT */--/* Define to 1 if you have the <limits.h> header file. */-#define HAVE_LIMITS_H 1--/* Define to 1 if you have the <locale.h> header file. */-#define HAVE_LOCALE_H 1--/* Define to 1 if the system has the type `long long'. */-#define HAVE_LONG_LONG 1--/* Define to 1 if you have the mingwex library. */-/* #undef HAVE_MINGWEX */--/* Define to 1 if you have the <minix/config.h> header file. */-/* #undef HAVE_MINIX_CONFIG_H */--/* Define to 1 if you have the <nlist.h> header file. */-#define HAVE_NLIST_H 1--/* Define to 1 if you have the <numaif.h> header file. */-/* #undef HAVE_NUMAIF_H */--/* Define to 1 if you have the <numa.h> header file. */-/* #undef HAVE_NUMA_H */--/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */-#define HAVE_PRINTF_LDBLSTUB 0--/* Define to 1 if you have the `pthread_condattr_setclock' function. */-/* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */--/* Define to 1 if you have the <pthread.h> header file. */-#define HAVE_PTHREAD_H 1--/* Define to 1 if you have the <pthread_np.h> header file. */-/* #undef HAVE_PTHREAD_NP_H */--/* Define to 1 if you have the glibc version of pthread_setname_np */-/* #undef HAVE_PTHREAD_SETNAME_NP */--/* Define to 1 if you have the Darwin version of pthread_setname_np */-#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1--/* Define to 1 if you have the NetBSD version of pthread_setname_np */-/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */--/* Define to 1 if you have pthread_set_name_np */-/* #undef HAVE_PTHREAD_SET_NAME_NP */--/* Define to 1 if you have the <pwd.h> header file. */-#define HAVE_PWD_H 1--/* Define to 1 if you have the `sched_getaffinity' function. */-/* #undef HAVE_SCHED_GETAFFINITY */--/* Define to 1 if you have the <sched.h> header file. */-#define HAVE_SCHED_H 1--/* Define to 1 if you have the `sched_setaffinity' function. */-/* #undef HAVE_SCHED_SETAFFINITY */--/* Define to 1 if you have the `setitimer' function. */-#define HAVE_SETITIMER 1--/* Define to 1 if you have the `setlocale' function. */-#define HAVE_SETLOCALE 1--/* Define to 1 if you have the `siginterrupt' function. */-#define HAVE_SIGINTERRUPT 1--/* Define to 1 if you have the <signal.h> header file. */-#define HAVE_SIGNAL_H 1--/* Define to 1 if you have the <stdint.h> header file. */-#define HAVE_STDINT_H 1--/* Define to 1 if you have the <stdio.h> header file. */-#define HAVE_STDIO_H 1--/* Define to 1 if you have the <stdlib.h> header file. */-#define HAVE_STDLIB_H 1--/* Define to 1 if you have the <strings.h> header file. */-#define HAVE_STRINGS_H 1--/* Define to 1 if you have the <string.h> header file. */-#define HAVE_STRING_H 1--/* Define to 1 if Apple-style dead-stripping is supported. */-#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1--/* Define to 1 if you have the `sysconf' function. */-#define HAVE_SYSCONF 1--/* Define to 1 if you have libffi. */-/* #undef HAVE_SYSTEM_LIBFFI */--/* Define to 1 if you have the <sys/cpuset.h> header file. */-/* #undef HAVE_SYS_CPUSET_H */--/* Define to 1 if you have the <sys/eventfd.h> header file. */-/* #undef HAVE_SYS_EVENTFD_H */--/* Define to 1 if you have the <sys/mman.h> header file. */-#define HAVE_SYS_MMAN_H 1--/* Define to 1 if you have the <sys/param.h> header file. */-#define HAVE_SYS_PARAM_H 1--/* Define to 1 if you have the <sys/resource.h> header file. */-#define HAVE_SYS_RESOURCE_H 1--/* Define to 1 if you have the <sys/select.h> header file. */-#define HAVE_SYS_SELECT_H 1--/* Define to 1 if you have the <sys/stat.h> header file. */-#define HAVE_SYS_STAT_H 1--/* Define to 1 if you have the <sys/timeb.h> header file. */-#define HAVE_SYS_TIMEB_H 1--/* Define to 1 if you have the <sys/timerfd.h> header file. */-/* #undef HAVE_SYS_TIMERFD_H */--/* Define to 1 if you have the <sys/timers.h> header file. */-/* #undef HAVE_SYS_TIMERS_H */--/* Define to 1 if you have the <sys/times.h> header file. */-#define HAVE_SYS_TIMES_H 1--/* Define to 1 if you have the <sys/time.h> header file. */-#define HAVE_SYS_TIME_H 1--/* Define to 1 if you have the <sys/types.h> header file. */-#define HAVE_SYS_TYPES_H 1--/* Define to 1 if you have the <sys/utsname.h> header file. */-#define HAVE_SYS_UTSNAME_H 1--/* Define to 1 if you have the <sys/wait.h> header file. */-#define HAVE_SYS_WAIT_H 1--/* Define to 1 if you have the <termios.h> header file. */-#define HAVE_TERMIOS_H 1--/* Define to 1 if you have the `timer_settime' function. */-/* #undef HAVE_TIMER_SETTIME */--/* Define to 1 if you have the `times' function. */-#define HAVE_TIMES 1--/* Define to 1 if you have the <time.h> header file. */-#define HAVE_TIME_H 1--/* Define to 1 if you have the <unistd.h> header file. */-#define HAVE_UNISTD_H 1--/* Define to 1 if you have the <utime.h> header file. */-#define HAVE_UTIME_H 1--/* Define to 1 if you have the `vfork' function. */-#define HAVE_VFORK 1--/* Define to 1 if you have the <vfork.h> header file. */-/* #undef HAVE_VFORK_H */--/* Define to 1 if you have the <wchar.h> header file. */-#define HAVE_WCHAR_H 1--/* Define to 1 if you have the <windows.h> header file. */-/* #undef HAVE_WINDOWS_H */--/* Define to 1 if you have the `WinExec' function. */-/* #undef HAVE_WINEXEC */--/* Define to 1 if you have the <winsock.h> header file. */-/* #undef HAVE_WINSOCK_H */--/* Define to 1 if `fork' works. */-#define HAVE_WORKING_FORK 1--/* Define to 1 if `vfork' works. */-#define HAVE_WORKING_VFORK 1--/* Define to 1 if C symbols have a leading underscore added by the compiler.- */-#define LEADING_UNDERSCORE 1--/* Define to 1 if we need -latomic for sub-word atomic operations. */-#define NEED_ATOMIC_LIB 0--/* Define 1 if we need to link code using pthreads with -lpthread */-#define NEED_PTHREAD_LIB 0--/* Define to the address where bug reports for this package should be sent. */-/* #undef PACKAGE_BUGREPORT */--/* Define to the full name of this package. */-/* #undef PACKAGE_NAME */--/* Define to the full name and version of this package. */-/* #undef PACKAGE_STRING */--/* Define to the one symbol short name of this package. */-/* #undef PACKAGE_TARNAME */--/* Define to the home page for this package. */-/* #undef PACKAGE_URL */--/* Define to the version of this package. */-/* #undef PACKAGE_VERSION */--/* Use mmap in the runtime linker */-#define RTS_LINKER_USE_MMAP 1--/* The size of `char', as computed by sizeof. */-#define SIZEOF_CHAR 1--/* The size of `double', as computed by sizeof. */-#define SIZEOF_DOUBLE 8--/* The size of `float', as computed by sizeof. */-#define SIZEOF_FLOAT 4--/* The size of `int', as computed by sizeof. */-#define SIZEOF_INT 4--/* The size of `int16_t', as computed by sizeof. */-#define SIZEOF_INT16_T 2--/* The size of `int32_t', as computed by sizeof. */-#define SIZEOF_INT32_T 4--/* The size of `int64_t', as computed by sizeof. */-#define SIZEOF_INT64_T 8--/* The size of `int8_t', as computed by sizeof. */-#define SIZEOF_INT8_T 1--/* The size of `long', as computed by sizeof. */-#define SIZEOF_LONG 8--/* The size of `long long', as computed by sizeof. */-#define SIZEOF_LONG_LONG 8--/* The size of `short', as computed by sizeof. */-#define SIZEOF_SHORT 2--/* The size of `uint16_t', as computed by sizeof. */-#define SIZEOF_UINT16_T 2--/* The size of `uint32_t', as computed by sizeof. */-#define SIZEOF_UINT32_T 4--/* The size of `uint64_t', as computed by sizeof. */-#define SIZEOF_UINT64_T 8--/* The size of `uint8_t', as computed by sizeof. */-#define SIZEOF_UINT8_T 1--/* The size of `unsigned char', as computed by sizeof. */-#define SIZEOF_UNSIGNED_CHAR 1--/* The size of `unsigned int', as computed by sizeof. */-#define SIZEOF_UNSIGNED_INT 4--/* The size of `unsigned long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG 8--/* The size of `unsigned long long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG_LONG 8--/* The size of `unsigned short', as computed by sizeof. */-#define SIZEOF_UNSIGNED_SHORT 2--/* The size of `void *', as computed by sizeof. */-#define SIZEOF_VOID_P 8--/* If using the C implementation of alloca, define if you know the- direction of stack growth for your system; otherwise it will be- automatically deduced at runtime.- STACK_DIRECTION > 0 => grows toward higher addresses- STACK_DIRECTION < 0 => grows toward lower addresses- STACK_DIRECTION = 0 => direction of growth unknown */-/* #undef STACK_DIRECTION */--/* Define to 1 if all of the C90 standard headers exist (not just the ones- required in a freestanding environment). This macro is provided for- backward compatibility; new code need not use it. */-#define STDC_HEADERS 1--/* Define to 1 if info tables are laid out next to code */-#define TABLES_NEXT_TO_CODE 1--/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This- macro is obsolete. */-#define TIME_WITH_SYS_TIME 1--/* Compile-in ASSERTs in all ways. */-/* #undef USE_ASSERTS_ALL_WAYS */--/* Enable single heap address space support */-#define USE_LARGE_ADDRESS_SPACE 1--/* Set to 1 to use libdw */-#define USE_LIBDW 0--/* Enable extensions on AIX 3, Interix. */-#ifndef _ALL_SOURCE-# define _ALL_SOURCE 1-#endif-/* Enable general extensions on macOS. */-#ifndef _DARWIN_C_SOURCE-# define _DARWIN_C_SOURCE 1-#endif-/* Enable general extensions on Solaris. */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1-#endif-/* Enable GNU extensions on systems that have them. */-#ifndef _GNU_SOURCE-# define _GNU_SOURCE 1-#endif-/* Enable X/Open compliant socket functions that do not require linking- with -lxnet on HP-UX 11.11. */-#ifndef _HPUX_ALT_XOPEN_SOCKET_API-# define _HPUX_ALT_XOPEN_SOCKET_API 1-#endif-/* Identify the host operating system as Minix.- This macro does not affect the system headers' behavior.- A future release of Autoconf may stop defining this macro. */-#ifndef _MINIX-/* # undef _MINIX */-#endif-/* Enable general extensions on NetBSD.- Enable NetBSD compatibility extensions on Minix. */-#ifndef _NETBSD_SOURCE-# define _NETBSD_SOURCE 1-#endif-/* Enable OpenBSD compatibility extensions on NetBSD.- Oddly enough, this does nothing on OpenBSD. */-#ifndef _OPENBSD_SOURCE-# define _OPENBSD_SOURCE 1-#endif-/* Define to 1 if needed for POSIX-compatible behavior. */-#ifndef _POSIX_SOURCE-/* # undef _POSIX_SOURCE */-#endif-/* Define to 2 if needed for POSIX-compatible behavior. */-#ifndef _POSIX_1_SOURCE-/* # undef _POSIX_1_SOURCE */-#endif-/* Enable POSIX-compatible threading on Solaris. */-#ifndef _POSIX_PTHREAD_SEMANTICS-# define _POSIX_PTHREAD_SEMANTICS 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-5:2014. */-#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__-# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-1:2014. */-#ifndef __STDC_WANT_IEC_60559_BFP_EXT__-# define __STDC_WANT_IEC_60559_BFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-2:2015. */-#ifndef __STDC_WANT_IEC_60559_DFP_EXT__-# define __STDC_WANT_IEC_60559_DFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-4:2015. */-#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__-# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */-#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__-# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TR 24731-2:2010. */-#ifndef __STDC_WANT_LIB_EXT2__-# define __STDC_WANT_LIB_EXT2__ 1-#endif-/* Enable extensions specified by ISO/IEC 24747:2009. */-#ifndef __STDC_WANT_MATH_SPEC_FUNCS__-# define __STDC_WANT_MATH_SPEC_FUNCS__ 1-#endif-/* Enable extensions on HP NonStop. */-#ifndef _TANDEM_SOURCE-# define _TANDEM_SOURCE 1-#endif-/* Enable X/Open extensions. Define to 500 only if necessary- to make mbstate_t available. */-#ifndef _XOPEN_SOURCE-/* # undef _XOPEN_SOURCE */-#endif---/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */-/* #undef USE_TIMER_CREATE */--/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most- significant byte first (like Motorola and SPARC, unlike Intel). */-#if defined AC_APPLE_UNIVERSAL_BUILD-# if defined __BIG_ENDIAN__-# define WORDS_BIGENDIAN 1-# endif-#else-# ifndef WORDS_BIGENDIAN-/* # undef WORDS_BIGENDIAN */-# endif-#endif--/* Number of bits in a file offset, on hosts where this is settable. */-/* #undef _FILE_OFFSET_BITS */--/* Define for large files, on AIX-style hosts. */-/* #undef _LARGE_FILES */--/* ARM pre v6 */-/* #undef arm_HOST_ARCH_PRE_ARMv6 */--/* ARM pre v7 */-/* #undef arm_HOST_ARCH_PRE_ARMv7 */--/* Define to empty if `const' does not conform to ANSI C. */-/* #undef const */--/* Define as a signed integer type capable of holding a process identifier. */-/* #undef pid_t */--/* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (13)--/* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (9)--/* Define to `unsigned int' if <sys/types.h> does not define. */-/* #undef size_t */--/* Define as `fork' if `vfork' does not work. */-/* #undef vfork */-#endif /* __GHCAUTOCONF_H__ */
− ghc-lib/stage0/lib/ghcplatform.h
@@ -1,28 +0,0 @@-#if !defined(__GHCPLATFORM_H__)-#define __GHCPLATFORM_H__--#define GHC_STAGE 1--#define BuildPlatform_TYPE x86_64_apple_darwin-#define HostPlatform_TYPE x86_64_apple_darwin--#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"--#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"--#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"---#endif /* __GHCPLATFORM_H__ */
ghc-lib/stage0/lib/settings view
@@ -41,7 +41,7 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")-,("BigNum backend", "native")+,("Use inplace MinGW toolchain", "NO") ,("Use interpreter", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr")
+ ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -0,0 +1,559 @@+/* This file is created automatically. Do not edit by hand.*/++#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,48,8,16,8,0,56,40,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"+#define CONTROL_GROUP_CONST_291 291+#define STD_HDR_SIZE 1+#define PROF_HDR_SIZE 2+#define STACK_DIRTY 1+#define BLOCK_SIZE 4096+#define MBLOCK_SIZE 1048576+#define BLOCKS_PER_MBLOCK 252+#define TICKY_BIN_COUNT 9+#define OFFSET_StgRegTable_rR1 0+#define OFFSET_StgRegTable_rR2 8+#define OFFSET_StgRegTable_rR3 16+#define OFFSET_StgRegTable_rR4 24+#define OFFSET_StgRegTable_rR5 32+#define OFFSET_StgRegTable_rR6 40+#define OFFSET_StgRegTable_rR7 48+#define OFFSET_StgRegTable_rR8 56+#define OFFSET_StgRegTable_rR9 64+#define OFFSET_StgRegTable_rR10 72+#define OFFSET_StgRegTable_rF1 80+#define OFFSET_StgRegTable_rF2 84+#define OFFSET_StgRegTable_rF3 88+#define OFFSET_StgRegTable_rF4 92+#define OFFSET_StgRegTable_rF5 96+#define OFFSET_StgRegTable_rF6 100+#define OFFSET_StgRegTable_rD1 104+#define OFFSET_StgRegTable_rD2 112+#define OFFSET_StgRegTable_rD3 120+#define OFFSET_StgRegTable_rD4 128+#define OFFSET_StgRegTable_rD5 136+#define OFFSET_StgRegTable_rD6 144+#define OFFSET_StgRegTable_rXMM1 152+#define OFFSET_StgRegTable_rXMM2 168+#define OFFSET_StgRegTable_rXMM3 184+#define OFFSET_StgRegTable_rXMM4 200+#define OFFSET_StgRegTable_rXMM5 216+#define OFFSET_StgRegTable_rXMM6 232+#define OFFSET_StgRegTable_rYMM1 248+#define OFFSET_StgRegTable_rYMM2 280+#define OFFSET_StgRegTable_rYMM3 312+#define OFFSET_StgRegTable_rYMM4 344+#define OFFSET_StgRegTable_rYMM5 376+#define OFFSET_StgRegTable_rYMM6 408+#define OFFSET_StgRegTable_rZMM1 440+#define OFFSET_StgRegTable_rZMM2 504+#define OFFSET_StgRegTable_rZMM3 568+#define OFFSET_StgRegTable_rZMM4 632+#define OFFSET_StgRegTable_rZMM5 696+#define OFFSET_StgRegTable_rZMM6 760+#define OFFSET_StgRegTable_rL1 824+#define OFFSET_StgRegTable_rSp 832+#define OFFSET_StgRegTable_rSpLim 840+#define OFFSET_StgRegTable_rHp 848+#define OFFSET_StgRegTable_rHpLim 856+#define OFFSET_StgRegTable_rCCCS 864+#define OFFSET_StgRegTable_rCurrentTSO 872+#define OFFSET_StgRegTable_rCurrentNursery 888+#define OFFSET_StgRegTable_rHpAlloc 904+#define OFFSET_StgRegTable_rRet 912+#define REP_StgRegTable_rRet b64+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]+#define OFFSET_StgRegTable_rNursery 880+#define REP_StgRegTable_rNursery b64+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]+#define OFFSET_stgEagerBlackholeInfo -24+#define OFFSET_stgGCEnter1 -16+#define OFFSET_stgGCFun -8+#define OFFSET_Capability_r 24+#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_no 944+#define REP_Capability_no b32+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]+#define OFFSET_Capability_mut_lists 1016+#define REP_Capability_mut_lists b64+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]+#define OFFSET_Capability_context_switch 1184+#define REP_Capability_context_switch b32+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]+#define OFFSET_Capability_interrupt 1188+#define REP_Capability_interrupt b32+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]+#define OFFSET_Capability_sparks 1320+#define REP_Capability_sparks b64+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]+#define OFFSET_Capability_total_allocated 1192+#define REP_Capability_total_allocated b64+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]+#define OFFSET_Capability_weak_ptr_list_hd 1168+#define REP_Capability_weak_ptr_list_hd b64+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]+#define OFFSET_Capability_weak_ptr_list_tl 1176+#define REP_Capability_weak_ptr_list_tl b64+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_bdescr_start 0+#define REP_bdescr_start b64+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]+#define OFFSET_bdescr_free 8+#define REP_bdescr_free b64+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]+#define OFFSET_bdescr_blocks 48+#define REP_bdescr_blocks b32+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]+#define OFFSET_bdescr_gen_no 40+#define REP_bdescr_gen_no b16+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]+#define OFFSET_bdescr_link 16+#define REP_bdescr_link b64+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]+#define OFFSET_bdescr_flags 46+#define REP_bdescr_flags b16+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]+#define SIZEOF_generation 384+#define OFFSET_generation_n_new_large_words 56+#define REP_generation_n_new_large_words b64+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]+#define OFFSET_generation_weak_ptr_list 112+#define REP_generation_weak_ptr_list b64+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]+#define SIZEOF_CostCentreStack 96+#define OFFSET_CostCentreStack_ccsID 0+#define REP_CostCentreStack_ccsID b64+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]+#define OFFSET_CostCentreStack_mem_alloc 72+#define REP_CostCentreStack_mem_alloc b64+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]+#define OFFSET_CostCentreStack_scc_count 48+#define REP_CostCentreStack_scc_count b64+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]+#define OFFSET_CostCentreStack_prevStack 16+#define REP_CostCentreStack_prevStack b64+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]+#define OFFSET_CostCentre_ccID 0+#define REP_CostCentre_ccID b64+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]+#define OFFSET_CostCentre_link 56+#define REP_CostCentre_link b64+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]+#define OFFSET_StgHeader_info 0+#define REP_StgHeader_info b64+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]+#define OFFSET_StgHeader_ccs 8+#define REP_StgHeader_ccs b64+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]+#define OFFSET_StgHeader_ldvw 16+#define REP_StgHeader_ldvw b64+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]+#define SIZEOF_StgSMPThunkHeader 8+#define OFFSET_StgClosure_payload 0+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]+#define OFFSET_StgEntCounter_allocs 48+#define REP_StgEntCounter_allocs b64+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]+#define OFFSET_StgEntCounter_allocd 16+#define REP_StgEntCounter_allocd b64+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]+#define OFFSET_StgEntCounter_registeredp 0+#define REP_StgEntCounter_registeredp b64+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]+#define OFFSET_StgEntCounter_link 56+#define REP_StgEntCounter_link b64+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]+#define OFFSET_StgEntCounter_entry_count 40+#define REP_StgEntCounter_entry_count b64+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]+#define SIZEOF_StgUpdateFrame_NoHdr 8+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgCatchFrame_NoHdr 16+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)+#define SIZEOF_StgStopFrame_NoHdr 0+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)+#define SIZEOF_StgMutArrPtrs_NoHdr 16+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)+#define OFFSET_StgMutArrPtrs_ptrs 0+#define REP_StgMutArrPtrs_ptrs b64+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]+#define OFFSET_StgMutArrPtrs_size 8+#define REP_StgMutArrPtrs_size b64+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)+#define OFFSET_StgSmallMutArrPtrs_ptrs 0+#define REP_StgSmallMutArrPtrs_ptrs b64+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]+#define SIZEOF_StgArrBytes_NoHdr 8+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)+#define OFFSET_StgArrBytes_bytes 0+#define REP_StgArrBytes_bytes b64+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]+#define OFFSET_StgArrBytes_payload 8+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]+#define OFFSET_StgTSO__link 0+#define REP_StgTSO__link b64+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]+#define OFFSET_StgTSO_global_link 8+#define REP_StgTSO_global_link b64+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]+#define OFFSET_StgTSO_what_next 24+#define REP_StgTSO_what_next b16+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]+#define OFFSET_StgTSO_why_blocked 26+#define REP_StgTSO_why_blocked b16+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]+#define OFFSET_StgTSO_block_info 32+#define REP_StgTSO_block_info b64+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]+#define OFFSET_StgTSO_blocked_exceptions 80+#define REP_StgTSO_blocked_exceptions b64+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]+#define OFFSET_StgTSO_id 40+#define REP_StgTSO_id b64+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]+#define OFFSET_StgTSO_cap 64+#define REP_StgTSO_cap b64+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]+#define OFFSET_StgTSO_saved_errno 48+#define REP_StgTSO_saved_errno b32+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]+#define OFFSET_StgTSO_trec 72+#define REP_StgTSO_trec b64+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]+#define OFFSET_StgTSO_flags 28+#define REP_StgTSO_flags b32+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]+#define OFFSET_StgTSO_dirty 52+#define REP_StgTSO_dirty b32+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]+#define OFFSET_StgTSO_bq 88+#define REP_StgTSO_bq b64+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]+#define OFFSET_StgTSO_alloc_limit 96+#define REP_StgTSO_alloc_limit b64+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]+#define OFFSET_StgTSO_cccs 112+#define REP_StgTSO_cccs b64+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]+#define OFFSET_StgTSO_stackobj 16+#define REP_StgTSO_stackobj b64+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]+#define OFFSET_StgStack_sp 8+#define REP_StgStack_sp b64+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]+#define OFFSET_StgStack_stack 16+#define OFFSET_StgStack_stack_size 0+#define REP_StgStack_stack_size b32+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]+#define OFFSET_StgStack_dirty 4+#define REP_StgStack_dirty b8+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define SIZEOF_StgTSOProfInfo 8+#define OFFSET_StgUpdateFrame_updatee 0+#define REP_StgUpdateFrame_updatee b64+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgCatchFrame_handler 8+#define REP_StgCatchFrame_handler b64+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define OFFSET_StgCatchFrame_exceptions_blocked 0+#define REP_StgCatchFrame_exceptions_blocked b64+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]+#define SIZEOF_StgPAP_NoHdr 16+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)+#define OFFSET_StgPAP_n_args 4+#define REP_StgPAP_n_args b32+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]+#define OFFSET_StgPAP_fun 8+#define REP_StgPAP_fun gcptr+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]+#define OFFSET_StgPAP_arity 0+#define REP_StgPAP_arity b32+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]+#define OFFSET_StgPAP_payload 16+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_NoThunkHdr 16+#define SIZEOF_StgAP_NoHdr 24+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_n_args 12+#define REP_StgAP_n_args b32+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]+#define OFFSET_StgAP_fun 16+#define REP_StgAP_fun gcptr+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]+#define OFFSET_StgAP_payload 24+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_STACK_NoThunkHdr 16+#define SIZEOF_StgAP_STACK_NoHdr 24+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_STACK_size 8+#define REP_StgAP_STACK_size b64+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]+#define OFFSET_StgAP_STACK_fun 16+#define REP_StgAP_STACK_fun gcptr+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]+#define OFFSET_StgAP_STACK_payload 24+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]+#define SIZEOF_StgSelector_NoThunkHdr 8+#define SIZEOF_StgSelector_NoHdr 16+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)+#define OFFSET_StgInd_indirectee 0+#define REP_StgInd_indirectee gcptr+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]+#define SIZEOF_StgMutVar_NoHdr 8+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)+#define OFFSET_StgMutVar_var 0+#define REP_StgMutVar_var b64+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]+#define SIZEOF_StgAtomicallyFrame_NoHdr 16+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgAtomicallyFrame_code 0+#define REP_StgAtomicallyFrame_code b64+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]+#define OFFSET_StgAtomicallyFrame_result 8+#define REP_StgAtomicallyFrame_result b64+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]+#define OFFSET_StgTRecHeader_enclosing_trec 0+#define REP_StgTRecHeader_enclosing_trec b64+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]+#define SIZEOF_StgCatchSTMFrame_NoHdr 16+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgCatchSTMFrame_handler 8+#define REP_StgCatchSTMFrame_handler b64+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]+#define OFFSET_StgCatchSTMFrame_code 0+#define REP_StgCatchSTMFrame_code b64+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]+#define SIZEOF_StgCatchRetryFrame_NoHdr 24+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)+#define OFFSET_StgCatchRetryFrame_running_alt_code 0+#define REP_StgCatchRetryFrame_running_alt_code b64+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]+#define OFFSET_StgCatchRetryFrame_first_code 8+#define REP_StgCatchRetryFrame_first_code b64+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]+#define OFFSET_StgCatchRetryFrame_alt_code 16+#define REP_StgCatchRetryFrame_alt_code b64+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]+#define OFFSET_StgTVarWatchQueue_closure 0+#define REP_StgTVarWatchQueue_closure b64+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8+#define REP_StgTVarWatchQueue_next_queue_entry b64+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16+#define REP_StgTVarWatchQueue_prev_queue_entry b64+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]+#define SIZEOF_StgTVar_NoHdr 24+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)+#define OFFSET_StgTVar_current_value 0+#define REP_StgTVar_current_value b64+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]+#define OFFSET_StgTVar_first_watch_queue_entry 8+#define REP_StgTVar_first_watch_queue_entry b64+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]+#define OFFSET_StgTVar_num_updates 16+#define REP_StgTVar_num_updates b64+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]+#define SIZEOF_StgWeak_NoHdr 40+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)+#define OFFSET_StgWeak_link 32+#define REP_StgWeak_link b64+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]+#define OFFSET_StgWeak_key 8+#define REP_StgWeak_key b64+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]+#define OFFSET_StgWeak_value 16+#define REP_StgWeak_value b64+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]+#define OFFSET_StgWeak_finalizer 24+#define REP_StgWeak_finalizer b64+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]+#define OFFSET_StgWeak_cfinalizers 0+#define REP_StgWeak_cfinalizers b64+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]+#define SIZEOF_StgCFinalizerList_NoHdr 40+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)+#define OFFSET_StgCFinalizerList_link 0+#define REP_StgCFinalizerList_link b64+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]+#define OFFSET_StgCFinalizerList_fptr 8+#define REP_StgCFinalizerList_fptr b64+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]+#define OFFSET_StgCFinalizerList_ptr 16+#define REP_StgCFinalizerList_ptr b64+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]+#define OFFSET_StgCFinalizerList_eptr 24+#define REP_StgCFinalizerList_eptr b64+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]+#define OFFSET_StgCFinalizerList_flag 32+#define REP_StgCFinalizerList_flag b64+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]+#define SIZEOF_StgMVar_NoHdr 24+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)+#define OFFSET_StgMVar_head 0+#define REP_StgMVar_head b64+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]+#define OFFSET_StgMVar_tail 8+#define REP_StgMVar_tail b64+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]+#define OFFSET_StgMVar_value 16+#define REP_StgMVar_value b64+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]+#define SIZEOF_StgMVarTSOQueue_NoHdr 16+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)+#define OFFSET_StgMVarTSOQueue_link 0+#define REP_StgMVarTSOQueue_link b64+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]+#define OFFSET_StgMVarTSOQueue_tso 8+#define REP_StgMVarTSOQueue_tso b64+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]+#define SIZEOF_StgBCO_NoHdr 32+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)+#define OFFSET_StgBCO_instrs 0+#define REP_StgBCO_instrs b64+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]+#define OFFSET_StgBCO_literals 8+#define REP_StgBCO_literals b64+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]+#define OFFSET_StgBCO_ptrs 16+#define REP_StgBCO_ptrs b64+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]+#define OFFSET_StgBCO_arity 24+#define REP_StgBCO_arity b32+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]+#define OFFSET_StgBCO_size 28+#define REP_StgBCO_size b32+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]+#define OFFSET_StgBCO_bitmap 32+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]+#define SIZEOF_StgStableName_NoHdr 8+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)+#define OFFSET_StgStableName_sn 0+#define REP_StgStableName_sn b64+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]+#define SIZEOF_StgBlockingQueue_NoHdr 32+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)+#define OFFSET_StgBlockingQueue_bh 8+#define REP_StgBlockingQueue_bh b64+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]+#define OFFSET_StgBlockingQueue_owner 16+#define REP_StgBlockingQueue_owner b64+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]+#define OFFSET_StgBlockingQueue_queue 24+#define REP_StgBlockingQueue_queue b64+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]+#define OFFSET_StgBlockingQueue_link 0+#define REP_StgBlockingQueue_link b64+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]+#define SIZEOF_MessageBlackHole_NoHdr 24+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)+#define OFFSET_MessageBlackHole_link 0+#define REP_MessageBlackHole_link b64+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]+#define OFFSET_MessageBlackHole_tso 8+#define REP_MessageBlackHole_tso b64+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]+#define OFFSET_MessageBlackHole_bh 16+#define REP_MessageBlackHole_bh b64+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]+#define SIZEOF_StgCompactNFData_NoHdr 72+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)+#define OFFSET_StgCompactNFData_totalW 0+#define REP_StgCompactNFData_totalW b64+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]+#define OFFSET_StgCompactNFData_autoBlockW 8+#define REP_StgCompactNFData_autoBlockW b64+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]+#define OFFSET_StgCompactNFData_nursery 32+#define REP_StgCompactNFData_nursery b64+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]+#define OFFSET_StgCompactNFData_last 40+#define REP_StgCompactNFData_last b64+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]+#define OFFSET_StgCompactNFData_hp 16+#define REP_StgCompactNFData_hp b64+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]+#define OFFSET_StgCompactNFData_hpLim 24+#define REP_StgCompactNFData_hpLim b64+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]+#define OFFSET_StgCompactNFData_hash 48+#define REP_StgCompactNFData_hash b64+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]+#define OFFSET_StgCompactNFData_result 56+#define REP_StgCompactNFData_result b64+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]+#define SIZEOF_StgCompactNFDataBlock 24+#define OFFSET_StgCompactNFDataBlock_self 0+#define REP_StgCompactNFDataBlock_self b64+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]+#define OFFSET_StgCompactNFDataBlock_owner 8+#define REP_StgCompactNFDataBlock_owner b64+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]+#define OFFSET_StgCompactNFDataBlock_next 16+#define REP_StgCompactNFDataBlock_next b64+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280+#define REP_RtsFlags_ProfFlags_doHeapProfile b32+#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301+#define REP_RtsFlags_ProfFlags_showCCSOnException b8+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]+#define OFFSET_RtsFlags_DebugFlags_apply 245+#define REP_RtsFlags_DebugFlags_apply b8+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]+#define OFFSET_RtsFlags_DebugFlags_sanity 239+#define REP_RtsFlags_DebugFlags_sanity b8+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]+#define OFFSET_RtsFlags_DebugFlags_weak 234+#define REP_RtsFlags_DebugFlags_weak b8+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16+#define REP_RtsFlags_GcFlags_initialStkSize b32+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]+#define OFFSET_RtsFlags_MiscFlags_tickInterval 200+#define REP_RtsFlags_MiscFlags_tickInterval b64+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]+#define SIZEOF_StgFunInfoExtraFwd 32+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24+#define REP_StgFunInfoExtraFwd_slow_apply b64+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]+#define OFFSET_StgFunInfoExtraFwd_fun_type 0+#define REP_StgFunInfoExtraFwd_fun_type b32+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]+#define OFFSET_StgFunInfoExtraFwd_arity 4+#define REP_StgFunInfoExtraFwd_arity b32+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]+#define OFFSET_StgFunInfoExtraFwd_bitmap 16+#define REP_StgFunInfoExtraFwd_bitmap b64+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]+#define SIZEOF_StgFunInfoExtraRev 24+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0+#define REP_StgFunInfoExtraRev_slow_apply_offset b32+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]+#define OFFSET_StgFunInfoExtraRev_fun_type 16+#define REP_StgFunInfoExtraRev_fun_type b32+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]+#define OFFSET_StgFunInfoExtraRev_arity 20+#define REP_StgFunInfoExtraRev_arity b32+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]+#define OFFSET_StgFunInfoExtraRev_bitmap 8+#define REP_StgFunInfoExtraRev_bitmap b64+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8+#define REP_StgFunInfoExtraRev_bitmap_offset b32+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]+#define OFFSET_StgLargeBitmap_size 0+#define REP_StgLargeBitmap_size b64+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]+#define OFFSET_StgLargeBitmap_bitmap 8+#define SIZEOF_snEntry 24+#define OFFSET_snEntry_sn_obj 16+#define REP_snEntry_sn_obj b64+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]+#define OFFSET_snEntry_addr 0+#define REP_snEntry_addr b64+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]+#define SIZEOF_spEntry 8+#define OFFSET_spEntry_addr 0+#define REP_spEntry_addr b64+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
+ ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -0,0 +1,635 @@+#if !defined(__GHCAUTOCONF_H__)+#define __GHCAUTOCONF_H__+/* mk/config.h. Generated from config.h.in by configure. */+/* mk/config.h.in. Generated from configure.ac by autoheader. */++/* Define if building universal (internal helper macro) */+/* #undef AC_APPLE_UNIVERSAL_BUILD */++/* The alignment of a `char'. */+#define ALIGNMENT_CHAR 1++/* The alignment of a `double'. */+#define ALIGNMENT_DOUBLE 8++/* The alignment of a `float'. */+#define ALIGNMENT_FLOAT 4++/* The alignment of a `int'. */+#define ALIGNMENT_INT 4++/* The alignment of a `int16_t'. */+#define ALIGNMENT_INT16_T 2++/* The alignment of a `int32_t'. */+#define ALIGNMENT_INT32_T 4++/* The alignment of a `int64_t'. */+#define ALIGNMENT_INT64_T 8++/* The alignment of a `int8_t'. */+#define ALIGNMENT_INT8_T 1++/* The alignment of a `long'. */+#define ALIGNMENT_LONG 8++/* The alignment of a `long long'. */+#define ALIGNMENT_LONG_LONG 8++/* The alignment of a `short'. */+#define ALIGNMENT_SHORT 2++/* The alignment of a `uint16_t'. */+#define ALIGNMENT_UINT16_T 2++/* The alignment of a `uint32_t'. */+#define ALIGNMENT_UINT32_T 4++/* The alignment of a `uint64_t'. */+#define ALIGNMENT_UINT64_T 8++/* The alignment of a `uint8_t'. */+#define ALIGNMENT_UINT8_T 1++/* The alignment of a `unsigned char'. */+#define ALIGNMENT_UNSIGNED_CHAR 1++/* The alignment of a `unsigned int'. */+#define ALIGNMENT_UNSIGNED_INT 4++/* The alignment of a `unsigned long'. */+#define ALIGNMENT_UNSIGNED_LONG 8++/* The alignment of a `unsigned long long'. */+#define ALIGNMENT_UNSIGNED_LONG_LONG 8++/* The alignment of a `unsigned short'. */+#define ALIGNMENT_UNSIGNED_SHORT 2++/* The alignment of a `void *'. */+#define ALIGNMENT_VOID_P 8++/* Define (to 1) if C compiler has an LLVM back end */+#define CC_LLVM_BACKEND 1++/* Define to 1 if __thread is supported */+#define CC_SUPPORTS_TLS 1++/* Define to 1 if using 'alloca.c'. */+/* #undef C_ALLOCA */++/* Enable Native I/O manager as default. */+/* #undef DEFAULT_NATIVE_IO_MANAGER */++/* Define to 1 if your processor stores words of floats with the most+ significant byte first */+/* #undef FLOAT_WORDS_BIGENDIAN */++/* Has visibility hidden */+#define HAS_VISIBILITY_HIDDEN 1++/* Define to 1 if you have 'alloca', as a function or macro. */+#define HAVE_ALLOCA 1++/* Define to 1 if <alloca.h> works. */+#define HAVE_ALLOCA_H 1++/* Define to 1 if you have the <bfd.h> header file. */+/* #undef HAVE_BFD_H */++/* Does C compiler support __atomic primitives? */+#define HAVE_C11_ATOMICS 1++/* Define to 1 if you have the `clock_gettime' function. */+#define HAVE_CLOCK_GETTIME 1++/* Define to 1 if you have the `ctime_r' function. */+#define HAVE_CTIME_R 1++/* Define to 1 if you have the <ctype.h> header file. */+#define HAVE_CTYPE_H 1++/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you+ don't. */+#define HAVE_DECL_CTIME_R 1++/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you+ don't. */+/* #undef HAVE_DECL_MADV_DONTNEED */++/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you+ don't. */+/* #undef HAVE_DECL_MADV_FREE */++/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you+ don't. */+/* #undef HAVE_DECL_MAP_NORESERVE */++/* Define to 1 if you have the <dirent.h> header file. */+#define HAVE_DIRENT_H 1++/* Define to 1 if you have the <dlfcn.h> header file. */+#define HAVE_DLFCN_H 1++/* Define to 1 if you have the `dlinfo' function. */+/* #undef HAVE_DLINFO */++/* Define to 1 if you have the <elfutils/libdw.h> header file. */+/* #undef HAVE_ELFUTILS_LIBDW_H */++/* Define to 1 if you have the <errno.h> header file. */+#define HAVE_ERRNO_H 1++/* Define to 1 if you have the `eventfd' function. */+/* #undef HAVE_EVENTFD */++/* Define to 1 if you have the <fcntl.h> header file. */+#define HAVE_FCNTL_H 1++/* Define to 1 if you have the <ffi.h> header file. */+/* #undef HAVE_FFI_H */++/* Define to 1 if you have the `fork' function. */+#define HAVE_FORK 1++/* Define to 1 if you have the `getclock' function. */+/* #undef HAVE_GETCLOCK */++/* Define to 1 if you have the `GetModuleFileName' function. */+/* #undef HAVE_GETMODULEFILENAME */++/* Define to 1 if you have the `getrusage' function. */+#define HAVE_GETRUSAGE 1++/* Define to 1 if you have the `gettimeofday' function. */+#define HAVE_GETTIMEOFDAY 1++/* Define to 1 if you have the <grp.h> header file. */+#define HAVE_GRP_H 1++/* Define to 1 if you have the <inttypes.h> header file. */+#define HAVE_INTTYPES_H 1++/* Define to 1 if you have the `bfd' library (-lbfd). */+/* #undef HAVE_LIBBFD */++/* Define to 1 if you have the `dl' library (-ldl). */+#define HAVE_LIBDL 1++/* Define to 1 if you have the `iberty' library (-liberty). */+/* #undef HAVE_LIBIBERTY */++/* Define to 1 if you need to link with libm */+#define HAVE_LIBM 1++/* Define to 1 if you have libnuma */+#define HAVE_LIBNUMA 0++/* Define to 1 if you have the `pthread' library (-lpthread). */+#define HAVE_LIBPTHREAD 1++/* Define to 1 if you have the `rt' library (-lrt). */+/* #undef HAVE_LIBRT */++/* Define to 1 if you have the <limits.h> header file. */+#define HAVE_LIMITS_H 1++/* Define to 1 if you have the <locale.h> header file. */+#define HAVE_LOCALE_H 1++/* Define to 1 if the system has the type `long long'. */+#define HAVE_LONG_LONG 1++/* Define to 1 if you have the mingwex library. */+/* #undef HAVE_MINGWEX */++/* Define to 1 if you have the <minix/config.h> header file. */+/* #undef HAVE_MINIX_CONFIG_H */++/* Define to 1 if you have the <nlist.h> header file. */+#define HAVE_NLIST_H 1++/* Define to 1 if you have the <numaif.h> header file. */+/* #undef HAVE_NUMAIF_H */++/* Define to 1 if you have the <numa.h> header file. */+/* #undef HAVE_NUMA_H */++/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */+#define HAVE_PRINTF_LDBLSTUB 0++/* Define to 1 if you have the `pthread_condattr_setclock' function. */+/* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */++/* Define to 1 if you have the <pthread.h> header file. */+#define HAVE_PTHREAD_H 1++/* Define to 1 if you have the <pthread_np.h> header file. */+/* #undef HAVE_PTHREAD_NP_H */++/* Define to 1 if you have the glibc version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP */++/* Define to 1 if you have the Darwin version of pthread_setname_np */+#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1++/* Define to 1 if you have the NetBSD version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */++/* Define to 1 if you have pthread_set_name_np */+/* #undef HAVE_PTHREAD_SET_NAME_NP */++/* Define to 1 if you have the <pwd.h> header file. */+#define HAVE_PWD_H 1++/* Define to 1 if you have the `sched_getaffinity' function. */+/* #undef HAVE_SCHED_GETAFFINITY */++/* Define to 1 if you have the <sched.h> header file. */+#define HAVE_SCHED_H 1++/* Define to 1 if you have the `sched_setaffinity' function. */+/* #undef HAVE_SCHED_SETAFFINITY */++/* Define to 1 if you have the `setitimer' function. */+#define HAVE_SETITIMER 1++/* Define to 1 if you have the `setlocale' function. */+#define HAVE_SETLOCALE 1++/* Define to 1 if you have the `siginterrupt' function. */+#define HAVE_SIGINTERRUPT 1++/* Define to 1 if you have the <signal.h> header file. */+#define HAVE_SIGNAL_H 1++/* Define to 1 if you have the <stdint.h> header file. */+#define HAVE_STDINT_H 1++/* Define to 1 if you have the <stdio.h> header file. */+#define HAVE_STDIO_H 1++/* Define to 1 if you have the <stdlib.h> header file. */+#define HAVE_STDLIB_H 1++/* Define to 1 if you have the <strings.h> header file. */+#define HAVE_STRINGS_H 1++/* Define to 1 if you have the <string.h> header file. */+#define HAVE_STRING_H 1++/* Define to 1 if Apple-style dead-stripping is supported. */+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1++/* Define to 1 if you have the `sysconf' function. */+#define HAVE_SYSCONF 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_SYSTEM_LIBFFI */++/* Define to 1 if you have the <sys/cpuset.h> header file. */+/* #undef HAVE_SYS_CPUSET_H */++/* Define to 1 if you have the <sys/eventfd.h> header file. */+/* #undef HAVE_SYS_EVENTFD_H */++/* Define to 1 if you have the <sys/mman.h> header file. */+#define HAVE_SYS_MMAN_H 1++/* Define to 1 if you have the <sys/param.h> header file. */+#define HAVE_SYS_PARAM_H 1++/* Define to 1 if you have the <sys/resource.h> header file. */+#define HAVE_SYS_RESOURCE_H 1++/* Define to 1 if you have the <sys/select.h> header file. */+#define HAVE_SYS_SELECT_H 1++/* Define to 1 if you have the <sys/stat.h> header file. */+#define HAVE_SYS_STAT_H 1++/* Define to 1 if you have the <sys/timeb.h> header file. */+#define HAVE_SYS_TIMEB_H 1++/* Define to 1 if you have the <sys/timerfd.h> header file. */+/* #undef HAVE_SYS_TIMERFD_H */++/* Define to 1 if you have the <sys/timers.h> header file. */+/* #undef HAVE_SYS_TIMERS_H */++/* Define to 1 if you have the <sys/times.h> header file. */+#define HAVE_SYS_TIMES_H 1++/* Define to 1 if you have the <sys/time.h> header file. */+#define HAVE_SYS_TIME_H 1++/* Define to 1 if you have the <sys/types.h> header file. */+#define HAVE_SYS_TYPES_H 1++/* Define to 1 if you have the <sys/utsname.h> header file. */+#define HAVE_SYS_UTSNAME_H 1++/* Define to 1 if you have the <sys/wait.h> header file. */+#define HAVE_SYS_WAIT_H 1++/* Define to 1 if you have the <termios.h> header file. */+#define HAVE_TERMIOS_H 1++/* Define to 1 if you have the `timer_settime' function. */+/* #undef HAVE_TIMER_SETTIME */++/* Define to 1 if you have the `times' function. */+#define HAVE_TIMES 1++/* Define to 1 if you have the <time.h> header file. */+#define HAVE_TIME_H 1++/* Define to 1 if you have the <unistd.h> header file. */+#define HAVE_UNISTD_H 1++/* Define to 1 if you have the `uselocale' function. */+#define HAVE_USELOCALE 1++/* Define to 1 if you have the <utime.h> header file. */+#define HAVE_UTIME_H 1++/* Define to 1 if you have the `vfork' function. */+#define HAVE_VFORK 1++/* Define to 1 if you have the <vfork.h> header file. */+/* #undef HAVE_VFORK_H */++/* Define to 1 if you have the <wchar.h> header file. */+#define HAVE_WCHAR_H 1++/* Define to 1 if you have the <windows.h> header file. */+/* #undef HAVE_WINDOWS_H */++/* Define to 1 if you have the `WinExec' function. */+/* #undef HAVE_WINEXEC */++/* Define to 1 if you have the <winsock.h> header file. */+/* #undef HAVE_WINSOCK_H */++/* Define to 1 if `fork' works. */+#define HAVE_WORKING_FORK 1++/* Define to 1 if `vfork' works. */+#define HAVE_WORKING_VFORK 1++/* Define to 1 if C symbols have a leading underscore added by the compiler.+ */+#define LEADING_UNDERSCORE 1++/* Define to 1 if we need -latomic. */+#define NEED_ATOMIC_LIB 0++/* Define 1 if we need to link code using pthreads with -lpthread */+#define NEED_PTHREAD_LIB 0++/* Define to the address where bug reports for this package should be sent. */+/* #undef PACKAGE_BUGREPORT */++/* Define to the full name of this package. */+/* #undef PACKAGE_NAME */++/* Define to the full name and version of this package. */+/* #undef PACKAGE_STRING */++/* Define to the one symbol short name of this package. */+/* #undef PACKAGE_TARNAME */++/* Define to the home page for this package. */+/* #undef PACKAGE_URL */++/* Define to the version of this package. */+/* #undef PACKAGE_VERSION */++/* Use mmap in the runtime linker */+#define RTS_LINKER_USE_MMAP 1++/* The size of `char', as computed by sizeof. */+#define SIZEOF_CHAR 1++/* The size of `double', as computed by sizeof. */+#define SIZEOF_DOUBLE 8++/* The size of `float', as computed by sizeof. */+#define SIZEOF_FLOAT 4++/* The size of `int', as computed by sizeof. */+#define SIZEOF_INT 4++/* The size of `int16_t', as computed by sizeof. */+#define SIZEOF_INT16_T 2++/* The size of `int32_t', as computed by sizeof. */+#define SIZEOF_INT32_T 4++/* The size of `int64_t', as computed by sizeof. */+#define SIZEOF_INT64_T 8++/* The size of `int8_t', as computed by sizeof. */+#define SIZEOF_INT8_T 1++/* The size of `long', as computed by sizeof. */+#define SIZEOF_LONG 8++/* The size of `long long', as computed by sizeof. */+#define SIZEOF_LONG_LONG 8++/* The size of `short', as computed by sizeof. */+#define SIZEOF_SHORT 2++/* The size of `uint16_t', as computed by sizeof. */+#define SIZEOF_UINT16_T 2++/* The size of `uint32_t', as computed by sizeof. */+#define SIZEOF_UINT32_T 4++/* The size of `uint64_t', as computed by sizeof. */+#define SIZEOF_UINT64_T 8++/* The size of `uint8_t', as computed by sizeof. */+#define SIZEOF_UINT8_T 1++/* The size of `unsigned char', as computed by sizeof. */+#define SIZEOF_UNSIGNED_CHAR 1++/* The size of `unsigned int', as computed by sizeof. */+#define SIZEOF_UNSIGNED_INT 4++/* The size of `unsigned long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG 8++/* The size of `unsigned long long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG_LONG 8++/* The size of `unsigned short', as computed by sizeof. */+#define SIZEOF_UNSIGNED_SHORT 2++/* The size of `void *', as computed by sizeof. */+#define SIZEOF_VOID_P 8++/* If using the C implementation of alloca, define if you know the+ direction of stack growth for your system; otherwise it will be+ automatically deduced at runtime.+ STACK_DIRECTION > 0 => grows toward higher addresses+ STACK_DIRECTION < 0 => grows toward lower addresses+ STACK_DIRECTION = 0 => direction of growth unknown */+/* #undef STACK_DIRECTION */++/* Define to 1 if all of the C90 standard headers exist (not just the ones+ required in a freestanding environment). This macro is provided for+ backward compatibility; new code need not use it. */+#define STDC_HEADERS 1++/* Define to 1 if info tables are laid out next to code */+#define TABLES_NEXT_TO_CODE 1++/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This+ macro is obsolete. */+#define TIME_WITH_SYS_TIME 1++/* Compile-in ASSERTs in all ways. */+/* #undef USE_ASSERTS_ALL_WAYS */++/* Enable single heap address space support */+#define USE_LARGE_ADDRESS_SPACE 1++/* Set to 1 to use libdw */+#define USE_LIBDW 0++/* Enable extensions on AIX 3, Interix. */+#ifndef _ALL_SOURCE+# define _ALL_SOURCE 1+#endif+/* Enable general extensions on macOS. */+#ifndef _DARWIN_C_SOURCE+# define _DARWIN_C_SOURCE 1+#endif+/* Enable general extensions on Solaris. */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif+/* Enable GNU extensions on systems that have them. */+#ifndef _GNU_SOURCE+# define _GNU_SOURCE 1+#endif+/* Enable X/Open compliant socket functions that do not require linking+ with -lxnet on HP-UX 11.11. */+#ifndef _HPUX_ALT_XOPEN_SOCKET_API+# define _HPUX_ALT_XOPEN_SOCKET_API 1+#endif+/* Identify the host operating system as Minix.+ This macro does not affect the system headers' behavior.+ A future release of Autoconf may stop defining this macro. */+#ifndef _MINIX+/* # undef _MINIX */+#endif+/* Enable general extensions on NetBSD.+ Enable NetBSD compatibility extensions on Minix. */+#ifndef _NETBSD_SOURCE+# define _NETBSD_SOURCE 1+#endif+/* Enable OpenBSD compatibility extensions on NetBSD.+ Oddly enough, this does nothing on OpenBSD. */+#ifndef _OPENBSD_SOURCE+# define _OPENBSD_SOURCE 1+#endif+/* Define to 1 if needed for POSIX-compatible behavior. */+#ifndef _POSIX_SOURCE+/* # undef _POSIX_SOURCE */+#endif+/* Define to 2 if needed for POSIX-compatible behavior. */+#ifndef _POSIX_1_SOURCE+/* # undef _POSIX_1_SOURCE */+#endif+/* Enable POSIX-compatible threading on Solaris. */+#ifndef _POSIX_PTHREAD_SEMANTICS+# define _POSIX_PTHREAD_SEMANTICS 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-5:2014. */+#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__+# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-1:2014. */+#ifndef __STDC_WANT_IEC_60559_BFP_EXT__+# define __STDC_WANT_IEC_60559_BFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-2:2015. */+#ifndef __STDC_WANT_IEC_60559_DFP_EXT__+# define __STDC_WANT_IEC_60559_DFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-4:2015. */+#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__+# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */+#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__+# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TR 24731-2:2010. */+#ifndef __STDC_WANT_LIB_EXT2__+# define __STDC_WANT_LIB_EXT2__ 1+#endif+/* Enable extensions specified by ISO/IEC 24747:2009. */+#ifndef __STDC_WANT_MATH_SPEC_FUNCS__+# define __STDC_WANT_MATH_SPEC_FUNCS__ 1+#endif+/* Enable extensions on HP NonStop. */+#ifndef _TANDEM_SOURCE+# define _TANDEM_SOURCE 1+#endif+/* Enable X/Open extensions. Define to 500 only if necessary+ to make mbstate_t available. */+#ifndef _XOPEN_SOURCE+/* # undef _XOPEN_SOURCE */+#endif+++/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */+/* #undef USE_TIMER_CREATE */++/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most+ significant byte first (like Motorola and SPARC, unlike Intel). */+#if defined AC_APPLE_UNIVERSAL_BUILD+# if defined __BIG_ENDIAN__+# define WORDS_BIGENDIAN 1+# endif+#else+# ifndef WORDS_BIGENDIAN+/* # undef WORDS_BIGENDIAN */+# endif+#endif++/* Number of bits in a file offset, on hosts where this is settable. */+/* #undef _FILE_OFFSET_BITS */++/* Define for large files, on AIX-style hosts. */+/* #undef _LARGE_FILES */++/* ARM pre v6 */+/* #undef arm_HOST_ARCH_PRE_ARMv6 */++/* ARM pre v7 */+/* #undef arm_HOST_ARCH_PRE_ARMv7 */++/* Define to empty if `const' does not conform to ANSI C. */+/* #undef const */++/* Define as a signed integer type capable of holding a process identifier. */+/* #undef pid_t */++/* The maximum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MAX (13)++/* The minimum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MIN (9)++/* Define to `unsigned int' if <sys/types.h> does not define. */+/* #undef size_t */++/* Define as `fork' if `vfork' does not work. */+/* #undef vfork */+#endif /* __GHCAUTOCONF_H__ */
+ ghc-lib/stage0/rts/build/include/ghcplatform.h view
@@ -0,0 +1,26 @@+#if !defined(__GHCPLATFORM_H__)+#define __GHCPLATFORM_H__++#define BuildPlatform_TYPE x86_64_apple_darwin+#define HostPlatform_TYPE x86_64_apple_darwin++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"+++#endif /* __GHCPLATFORM_H__ */