ghc-lib-parser 9.2.4.20220729 → 9.2.5.20221107
raw patch · 16 files changed
+482/−276 lines, 16 files
Files
- compiler/GHC/Builtin/Types/Prim.hs +13/−2
- compiler/GHC/Cmm/MachOp.hs +4/−4
- compiler/GHC/Core.hs +1/−0
- compiler/GHC/Core/Make.hs +1/−1
- compiler/GHC/Core/Opt/Arity.hs +232/−107
- compiler/GHC/Core/TyCon.hs +66/−18
- compiler/GHC/Core/Utils.hs +6/−3
- compiler/GHC/Types/Literal.hs +97/−113
- compiler/GHC/Types/RepType.hs +26/−4
- compiler/GHC/Types/SrcLoc.hs +5/−0
- compiler/GHC/Utils/Binary.hs +4/−17
- compiler/GHC/Utils/Misc.hs +13/−1
- ghc-lib-parser.cabal +1/−1
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- includes/CodeGen.Platform.hs +8/−0
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/GHC/Builtin/Types/Prim.hs view
@@ -35,7 +35,7 @@ tYPETyCon, tYPETyConName, -- Kinds- tYPE, primRepToRuntimeRep,+ tYPE, primRepToRuntimeRep, primRepsToRuntimeRep, functionWithMultiplicity, funTyCon, funTyConName,@@ -593,7 +593,7 @@ -- Defined here to avoid (more) module loops primRepToRuntimeRep :: PrimRep -> Type primRepToRuntimeRep rep = case rep of- VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]+ VoidRep -> mkTupleRep [] LiftedRep -> liftedRepTy UnliftedRep -> unliftedRepTy IntRep -> intRepDataConTy@@ -631,6 +631,17 @@ Word64ElemRep -> word64ElemRepDataConTy FloatElemRep -> floatElemRepDataConTy DoubleElemRep -> doubleElemRepDataConTy++-- | Given a list of types representing 'RuntimeRep's @reps@, construct+-- @'TupleRep' reps@.+mkTupleRep :: [Type] -> Type+mkTupleRep reps = TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy reps]++-- | Convert a list of 'PrimRep's to a 'Type' of kind RuntimeRep+-- Defined here to avoid (more) module loops+primRepsToRuntimeRep :: [PrimRep] -> Type+primRepsToRuntimeRep [rep] = primRepToRuntimeRep rep+primRepsToRuntimeRep reps = mkTupleRep $ map primRepToRuntimeRep reps pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep
compiler/GHC/Cmm/MachOp.hs view
@@ -515,8 +515,8 @@ MO_FS_Conv from _ -> [from] MO_FF_Conv from _ -> [from] - MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]- MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform]+ MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r, W32]+ MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)), W32] MO_V_Add _ r -> [r,r] MO_V_Sub _ r -> [r,r]@@ -529,8 +529,8 @@ MO_VU_Quot _ r -> [r,r] MO_VU_Rem _ r -> [r,r] - MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]- MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]+ MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,W32]+ MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),W32] MO_VF_Add _ r -> [r,r] MO_VF_Sub _ r -> [r,r]
compiler/GHC/Core.hs view
@@ -695,6 +695,7 @@ The arity of a join point isn't very important; but short of setting it to zero, it is helpful to have an invariant. E.g. #17294.+ See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points.
compiler/GHC/Core/Make.hs view
@@ -1051,7 +1051,7 @@ where absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy) -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for- -- lifted-type things; see Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils+ -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils arity_info = vanillaIdInfo `setArityInfo` 1 -- NB: no bottoming strictness info, unlike other error-ids. -- See Note [aBSENT_ERROR_ID]
compiler/GHC/Core/Opt/Arity.hs view
@@ -18,7 +18,7 @@ , exprBotStrictness_maybe -- ** ArityType- , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType+ , ArityType(..), mkBotArityType, mkManifestArityType, expandableArityType , arityTypeArity, maxWithArity, idArityType -- ** Join points@@ -56,7 +56,6 @@ import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy ) import GHC.Core.Multiplicity-import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish import GHC.Builtin.Uniques@@ -532,7 +531,8 @@ -- where the @at@ fields of @ALam@ are inductively subject to the same order. -- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. ----- Why the strange Top element? See Note [Combining case branches].+-- Why the strange Top element?+-- See Note [Combining case branches: optimistic one-shot-ness] -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].@@ -579,11 +579,16 @@ botArityType :: ArityType botArityType = mkBotArityType [] -mkTopArityType :: [OneShotInfo] -> ArityType-mkTopArityType oss = AT oss topDiv+mkManifestArityType :: [Var] -> CoreExpr -> ArityType+mkManifestArityType bndrs body+ = AT oss div+ where+ oss = [idOneShotInfo bndr | bndr <- bndrs, isId bndr]+ div | exprIsDeadEnd body = botDiv+ | otherwise = topDiv topArityType :: ArityType-topArityType = mkTopArityType []+topArityType = AT [] topDiv -- | The number of value args for the arity type arityTypeArity :: ArityType -> Arity@@ -623,7 +628,7 @@ exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y-exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e+exprEtaExpandArity dflags e = arityType (findRhsArityEnv dflags) e getBotArity :: ArityType -> Maybe Arity -- Arity of a divergent function@@ -763,6 +768,7 @@ | otherwise = takeWhileOneShot at arityApp :: ArityType -> Bool -> ArityType+ -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)@@ -772,17 +778,31 @@ -- See the haddocks on 'ArityType' for the lattice. -- -- Used for branches of a @case@.-andArityType :: ArityType -> ArityType -> ArityType-andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2)- | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2)- = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]-andArityType at1@(AT [] div1) at2- | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins]- | otherwise = at1 -- See Note [Combining case branches]-andArityType at1 at2@(AT [] div2)- | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins]- | otherwise = at2 -- See Note [Combining case branches]+andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType+andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2)+ | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2)+ = AT ((lam1 `and_lam` lam2) : lams') div'+ where+ (os1) `and_lam` (os2)+ = ( os1 `bestOneShot` os2)+ -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] +andArityType env (AT [] div1) at2 = andWithTail env div1 at2+andArityType env at1 (AT [] div2) = andWithTail env div2 at1++andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType+andWithTail env div1 at2@(AT lams2 _)+ | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e }+ = at2 -- Note [ABot branches: max arity wins]++ | pedanticBottoms env -- Note [Combining case branches: andWithTail]+ = AT [] topDiv++ | otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e }+ = AT lams2 topDiv -- We know div1 = topDiv+ -- See Note [Combining case branches: andWithTail]++ {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case x of@@ -792,16 +812,66 @@ Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". So we need \??.⊥ for the whole thing, the /max/ of both arities. -Note [Combining case branches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Combining case branches: optimistic one-shot-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and both ArityTypes have ATLamInfo, then we just combine their+expensive-ness and one-shot info. The tricky point is when we have+ case x of True -> \x{one-shot). blah1+ Fale -> \y. blah2 -Unless we can conclude that **all** branches are safe to eta-expand then we-must pessimisticaly conclude that we can't eta-expand. See #21694 for where this-went wrong.-We can do better in the long run, but for the 9.4/9.2 branches we choose to simply-ignore oneshot annotations for the time being.+Since one-shot-ness is about the /consumer/ not the /producer/, we+optimistically assume that if either branch is one-shot, we combine+the best of the two branches, on the (slightly dodgy) basis that if we+know one branch is one-shot, then they all must be. Surprisingly,+this means that the one-shot arity type is effectively the top element+of the lattice. +Hence the call to `bestOneShot` in `andArityType`. +Note [Combining case branches: andWithTail]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and one side or the other has run out of ATLamInfo; then we get+into `andWithTail`.++* If one branch is guaranteed bottom (isDeadEndDiv), we just take+ the other; see Note [ABot branches: max arity wins]++* Otherwise, if pedantic-bottoms is on, we just have to return+ AT [] topDiv. E.g. if we have+ f x z = case x of True -> \y. blah+ False -> z+ then we can't eta-expand, because that would change the behaviour+ of (f False bottom().++* But if pedantic-bottoms is not on, we allow ourselves to push+ `z` under a lambda (much as we allow ourselves to put the `case x`+ under a lambda). However we know nothing about the expensiveness+ or one-shot-ness of `z`, so we'd better assume it looks like+ (Expensive, NoOneShotInfo) all the way. Remembering+ Note [Combining case branches: optimistic one-shot-ness],+ we just add work to ever ATLamInfo, keeping the one-shot-ness.++Here's an example:+ go = \x. let z = go e0+ go2 = \x. case x of+ True -> z+ False -> \s(one-shot). e1+ in go2 x+We *really* want to respect the one-shot annotation provided by the+user and eta-expand go and go2.+When combining the branches of the case we have+ T `andAT` \1.T+and we want to get \1.T.+But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.+(We need a usage analysis to justify that.)++So we combine the best of the two branches, on the (slightly dodgy)+basis that if we know one branch is one-shot, then they all must be.+Surprisingly, this means that the one-shot arity type is effectively the top+element of the lattice.+ Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and@@ -861,22 +931,21 @@ = AE { ae_mode :: !AnalysisMode -- ^ The analysis mode. See 'AnalysisMode'.- , ae_joins :: !IdSet- -- ^ In-scope join points. See Note [Eta-expansion and join points]- -- INVARIANT: Disjoint with the domain of 'am_sigs' (if present). } -- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms -- and no application is ever considered cheap. botStrictnessArityEnv :: ArityEnv-botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }+botStrictnessArityEnv = AE { ae_mode = BotStrictness } +{- -- | The @ArityEnv@ used by 'exprEtaExpandArity'. etaExpandArityEnv :: DynFlags -> ArityEnv etaExpandArityEnv dflags = AE { ae_mode = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags , am_dicts_cheap = gopt Opt_DictsCheap dflags } , ae_joins = emptyVarSet }+-} -- | The @ArityEnv@ used by 'findRhsArity'. findRhsArityEnv :: DynFlags -> ArityEnv@@ -884,8 +953,12 @@ = AE { ae_mode = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags , am_dicts_cheap = gopt Opt_DictsCheap dflags , am_sigs = emptyVarEnv }- , ae_joins = emptyVarSet }+ } +isFindRhsArity :: ArityEnv -> Bool+isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True+isFindRhsArity _ = False+ -- First some internal functions in snake_case for deleting in certain VarEnvs -- of the ArityType. Don't call these; call delInScope* instead! @@ -903,32 +976,17 @@ del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) {-# INLINE del_sig_env_list #-} -del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal!-del_join_env id env@(AE { ae_joins = joins })- = env { ae_joins = delVarSet joins id }-{-# INLINE del_join_env #-}--del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal!-del_join_env_list ids env@(AE { ae_joins = joins })- = env { ae_joins = delVarSetList joins ids }-{-# INLINE del_join_env_list #-}- -- end of internal deletion functions -extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv-extendJoinEnv env@(AE { ae_joins = joins }) join_ids- = del_sig_env_list join_ids- $ env { ae_joins = joins `extendVarSetList` join_ids }- extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv extendSigEnv env id ar_ty- = del_join_env id (modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env)+ = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env delInScope :: ArityEnv -> Id -> ArityEnv-delInScope env id = del_join_env id $ del_sig_env id env+delInScope env id = del_sig_env id env delInScopeList :: ArityEnv -> [Id] -> ArityEnv-delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env+delInScopeList env ids = del_sig_env_list ids env lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType lookupSigEnv AE{ ae_mode = mode } id = case mode of@@ -967,8 +1025,11 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of -- Nothing means not a local function, fall back to regular -- 'GHC.Core.Utils.isCheapApp'- Nothing -> isCheapApp fn n_val_args- -- @Just at@ means local function with @at@ as current ArityType.+ Nothing -> isCheapApp fn n_val_args++ -- `Just at` means local function with `at` as current SafeArityType.+ -- NB the SafeArityType bit: that means we can ignore the cost flags+ -- in 'lams', and just consider the length -- Roughly approximate what 'isCheapApp' is doing. Just (AT oss div) | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils@@ -976,7 +1037,10 @@ | otherwise -> False -----------------arityType :: ArityEnv -> CoreExpr -> ArityType+arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType+-- Precondition: all the free join points of the expression+-- are bound by the ArityEnv+-- See Note [No free join points in arityType] arityType env (Cast e co) = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]@@ -988,12 +1052,13 @@ -- #5441 is a nice demo arityType env (Var v)- | v `elemVarSet` ae_joins env- = botArityType -- See Note [Eta-expansion and join points] | Just at <- lookupSigEnv env v -- Local binding = at | otherwise- = idArityType v+ = ASSERT2( (not (isFindRhsArity env && isJoinId v)) , (ppr v) )+ -- All join-point should be in the ae_sigs+ -- See Note [No free join points in arityType]+ idArityType v -- Lambdas; increase arity arityType env (Lam x e)@@ -1030,32 +1095,11 @@ where env' = delInScope env bndr arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs- alts_type = foldr1 andArityType (map arity_type_alt alts)--arityType env (Let (NonRec j rhs) body)- | Just join_arity <- isJoinId_maybe j- , (_, rhs_body) <- collectNBinders join_arity rhs- = -- See Note [Eta-expansion and join points]- andArityType (arityType env rhs_body)- (arityType env' body)- where- env' = extendJoinEnv env [j]--arityType env (Let (Rec pairs) body)- | ((j,_):_) <- pairs- , isJoinId j- = -- See Note [Eta-expansion and join points]- foldr (andArityType . do_one) (arityType env' body) pairs- where- env' = extendJoinEnv env (map fst pairs)- do_one (j,rhs)- | Just arity <- isJoinId_maybe j- = arityType env' $ snd $ collectNBinders arity rhs- | otherwise- = pprPanic "arityType:joinrec" (ppr pairs)+ alts_type = foldr1 (andArityType env) (map arity_type_alt alts) arityType env (Let (NonRec b r) e)- = floatIn cheap_rhs (arityType env' e)+ = -- See Note [arityType for let-bindings]+ floatIn cheap_rhs (arityType env' e) where cheap_rhs = myExprIsCheap env r (Just (idType b)) env' = extendSigEnv env b (arityType env r)@@ -1063,18 +1107,77 @@ arityType env (Let (Rec prs) e) = floatIn (all is_cheap prs) (arityType env' e) where- env' = delInScopeList env (map fst prs) is_cheap (b,e) = myExprIsCheap env' e (Just (idType b))+ env' = foldl extend_rec env prs+ extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv+ extend_rec env (b,e) = extendSigEnv env b $+ mkManifestArityType bndrs body+ where+ (bndrs, body) = collectBinders e+ -- We can't call arityType on the RHS, because it might mention+ -- join points bound in this very letrec, and we don't want to+ -- do a fixpoint calculation here. So we make do with the+ -- manifest arity arityType env (Tick t e) | not (tickishIsCode t) = arityType env e arityType _ _ = topArityType -{- Note [Eta-expansion and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#18328) +{- Note [No free join points in arityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we call arityType on this expression (EX1)+ \x . case x of True -> \y. e+ False -> $j 3+where $j is a join point. It really makes no sense to talk of the arity+of this expression, because it has a free join point. In particular, we+can't eta-expand the expression because we'd have do the same thing to the+binding of $j, and we can't see that binding.++If we had (EX2)+ \x. join $j y = blah+ case x of True -> \y. e+ False -> $j 3+then it would make perfect sense: we can determine $j's ArityType, and+propagate it to the usage site as usual.++But how can we get (EX1)? It doesn't make much sense, because $j can't+be a join point under the \x anyway. So we make it a precondition of+arityType that the argument has no free join-point Ids. (This is checked+with an assesrt in the Var case of arityType.)++BUT the invariant risks being invalidated by one very narrow special case: runRW#+ join $j y = blah+ runRW# (\s. case x of True -> \y. e+ False -> $j x)++We have special magic in OccurAnal, and Simplify to allow continuations to+move into the body of a runRW# call.++So we are careful never to attempt to eta-expand the (\s.blah) in the+argument to runRW#, at least not when there is a literal lambda there,+so that OccurAnal has seen it and allowed join points bound outside.+See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration.++Note [arityType for let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For non-recursive let-bindings, we just get the arityType of the RHS,+and extend the environment. That works nicely for things like this+(#18793):+ go = \ ds. case ds_a2CF of {+ [] -> id+ : y ys -> case y of { GHC.Types.I# x ->+ let acc = go ys in+ case x ># 42# of {+ __DEFAULT -> acc+ 1# -> \x1. acc (negate x2)++Here we want to get a good arity for `acc`, based on the ArityType+of `go`.++All this is particularly important for join points. Consider this (#18328)+ f x = join j y = case y of True -> \a. blah False -> \b. blah@@ -1086,42 +1189,64 @@ and suppose the join point is too big to inline. Now, what is the arity of f? If we inlined the join point, we'd definitely say "arity 2" because we are prepared to push case-scrutinisation inside a-lambda. But currently the join point totally messes all that up,-because (thought of as a vanilla let-binding) the arity pinned on 'j'-is just 1.+lambda. It's important that we extend the envt with j's ArityType,+so that we can use that information in the A/C branch of the case. -Why don't we eta-expand j? Because of-Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils+For /recursive/ bindings it's more difficult, to call arityType,+because we don't have an ArityType to put in the envt for the+recursively bound Ids. So for non-join-point bindings we satisfy+ourselves with mkManifestArityType. Typically we'll have eta-expanded+the binding (based on an earlier fixpoint calculation in+findRhsArity), so the manifest arity is good. -Even if we don't eta-expand j, why is its arity only 1?-See invariant 2b in Note [Invariants on join points] in GHC.Core.+But for /recursive join points/ things are not so good.+See Note [Arity type for recursive join bindings] -So we do this:+See Note [Arity type for recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f x = joinrec j 0 = \ a b c -> (a,x,b)+ j n = j (n-1)+ in j 20 -* Treat the RHS of a join-point binding, /after/ stripping off- join-arity lambda-binders, as very like the body of the let.- More precisely, do andArityType with the arityType from the- body of the let.+Obviously `f` should get arity 4. But the manifest arity of `j`+is 1. Remember, we don't eta-expand join points; see+GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points].+And the ArityInfo on `j` will be just 1 too; see GHC.Core+Note [Invariants on join points], item (2b). So using+Note [ArityType for let-bindings] won't work well. -* Dually, when we come to a /call/ of a join point, just no-op- by returning ABot, the bottom element of ArityType,- which so that: bot `andArityType` x = x+We could do a fixpoint iteration, but that's a heavy hammer+to use in arityType. So we take advantage of it being a join+point: -* This works if the join point is bound in the expression we are- taking the arityType of. But if it's bound further out, it makes- no sense to say that (say) the arityType of (j False) is ABot.- Bad things happen. So we keep track of the in-scope join-point Ids- in ae_join.+* Extend the ArityEnv to bind each of the recursive binders+ (all join points) to `botArityType`. This means that any+ jump to the join point will return botArityType, which is+ unit for `andArityType`:+ botAritType `andArityType` at = at+ So it's almost as if those "jump" branches didn't exist. -This will make f, above, have arity 2. Then, we'll eta-expand it thus:+* In this extended env, find the ArityType of each of the RHS, after+ stripping off the join-point binders. - f x eta = (join j y = ... in case x of ...) eta+* Use andArityType to combine all these RHS ArityTypes. -and the Simplify will automatically push that application of eta into-the join points.+* Find the ArityType of the body, also in this strange extended+ environment -An alternative (roughly equivalent) idea would be to carry an-environment mapping let-bound Ids to their ArityType.+* And combine that into the result with andArityType.++In our example, the jump (j 20) will yield Bot, as will the jump+(j (n-1)). We'll 'and' those the ArityType of (\abc. blah). Good!++In effect we are treating the RHSs as alternative bodies (like+in a case), and ignoring all jumps. In this way we don't need+to take a fixpoint. Tricky!++NB: we treat /non-recursive/ join points in the same way, but+actually it works fine to treat them uniformly with normal+let-bindings, and that takes less code. -} idArityType :: Id -> ArityType
compiler/GHC/Core/TyCon.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveDataTypeable #-} {- (c) The University of Glasgow 2006@@ -122,6 +123,7 @@ -- * Primitive representations of Types PrimRep(..), PrimElemRep(..),+ primElemRepToPrimRep, isVoidRep, isGcPtrRep, primRepSizeB, primElemRepSizeB,@@ -1483,7 +1485,7 @@ | FloatRep | DoubleRep | VecRep Int PrimElemRep -- ^ A vector- deriving( Eq, Show )+ deriving( Data.Data, Eq, Ord, Show ) data PrimElemRep = Int8ElemRep@@ -1496,7 +1498,7 @@ | Word64ElemRep | FloatElemRep | DoubleElemRep- deriving( Eq, Show )+ deriving( Data.Data, Eq, Ord, Show, Enum ) instance Outputable PrimRep where ppr r = text (show r)@@ -1504,6 +1506,50 @@ instance Outputable PrimElemRep where ppr r = text (show r) +instance Binary PrimRep where+ put_ bh VoidRep = putByte bh 0+ put_ bh LiftedRep = putByte bh 1+ put_ bh UnliftedRep = putByte bh 2+ put_ bh Int8Rep = putByte bh 3+ put_ bh Int16Rep = putByte bh 4+ put_ bh Int32Rep = putByte bh 5+ put_ bh Int64Rep = putByte bh 6+ put_ bh IntRep = putByte bh 7+ put_ bh Word8Rep = putByte bh 8+ put_ bh Word16Rep = putByte bh 9+ put_ bh Word32Rep = putByte bh 10+ put_ bh Word64Rep = putByte bh 11+ put_ bh WordRep = putByte bh 12+ put_ bh AddrRep = putByte bh 13+ put_ bh FloatRep = putByte bh 14+ put_ bh DoubleRep = putByte bh 15+ put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per+ get bh = do+ h <- getByte bh+ case h of+ 0 -> pure VoidRep+ 1 -> pure LiftedRep+ 2 -> pure UnliftedRep+ 3 -> pure Int8Rep+ 4 -> pure Int16Rep+ 5 -> pure Int32Rep+ 6 -> pure Int64Rep+ 7 -> pure IntRep+ 8 -> pure Word8Rep+ 9 -> pure Word16Rep+ 10 -> pure Word32Rep+ 11 -> pure Word64Rep+ 12 -> pure WordRep+ 13 -> pure AddrRep+ 14 -> pure FloatRep+ 15 -> pure DoubleRep+ 16 -> VecRep <$> get bh <*> get bh+ _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h))++instance Binary PrimElemRep where+ put_ bh per = putByte bh (fromIntegral (fromEnum per))+ get bh = toEnum . fromIntegral <$> getByte bh+ isVoidRep :: PrimRep -> Bool isVoidRep VoidRep = True isVoidRep _other = False@@ -1555,20 +1601,23 @@ LiftedRep -> platformWordSizeInBytes platform UnliftedRep -> platformWordSizeInBytes platform VoidRep -> 0- (VecRep len rep) -> len * primElemRepSizeB rep+ (VecRep len rep) -> len * primElemRepSizeB platform rep -primElemRepSizeB :: PrimElemRep -> Int-primElemRepSizeB Int8ElemRep = 1-primElemRepSizeB Int16ElemRep = 2-primElemRepSizeB Int32ElemRep = 4-primElemRepSizeB Int64ElemRep = 8-primElemRepSizeB Word8ElemRep = 1-primElemRepSizeB Word16ElemRep = 2-primElemRepSizeB Word32ElemRep = 4-primElemRepSizeB Word64ElemRep = 8-primElemRepSizeB FloatElemRep = 4-primElemRepSizeB DoubleElemRep = 8+primElemRepSizeB :: Platform -> PrimElemRep -> Int+primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep +primElemRepToPrimRep :: PrimElemRep -> PrimRep+primElemRepToPrimRep Int8ElemRep = Int8Rep+primElemRepToPrimRep Int16ElemRep = Int16Rep+primElemRepToPrimRep Int32ElemRep = Int32Rep+primElemRepToPrimRep Int64ElemRep = Int64Rep+primElemRepToPrimRep Word8ElemRep = Word8Rep+primElemRepToPrimRep Word16ElemRep = Word16Rep+primElemRepToPrimRep Word32ElemRep = Word32Rep+primElemRepToPrimRep Word64ElemRep = Word64Rep+primElemRepToPrimRep FloatElemRep = FloatRep+primElemRepToPrimRep DoubleElemRep = DoubleRep+ -- | Return if Rep stands for floating type, -- returns Nothing for vector types. primRepIsFloat :: PrimRep -> Maybe Bool@@ -1576,7 +1625,6 @@ primRepIsFloat DoubleRep = Just True primRepIsFloat (VecRep _ _) = Nothing primRepIsFloat _ = Just False- {- ************************************************************************
compiler/GHC/Core/Utils.hs view
@@ -1625,11 +1625,14 @@ expr_ok primop_ok other_expr | (expr, args) <- collectArgs other_expr = case stripTicksTopE (not . tickishCounts) expr of- Var f -> app_ok primop_ok f args+ Var f -> app_ok primop_ok f args -- 'LitRubbish' is the only literal that can occur in the head of an -- application and will not be matched by the above case (Var /= Lit).- Lit lit -> ASSERT( isRubbishLit lit ) True- _ -> False+ Lit LitRubbish{} -> True+#if defined(DEBUG)+ Lit _ -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)+#endif+ _ -> False ----------------------------- app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
compiler/GHC/Types/Literal.hs view
@@ -20,23 +20,23 @@ -- ** Creating Literals , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked- , mkLitWord, mkLitWordWrap, mkLitWordWrapC- , mkLitInt8, mkLitInt8Wrap- , mkLitWord8, mkLitWord8Wrap- , mkLitInt16, mkLitInt16Wrap- , mkLitWord16, mkLitWord16Wrap- , mkLitInt32, mkLitInt32Wrap- , mkLitWord32, mkLitWord32Wrap- , mkLitInt64, mkLitInt64Wrap- , mkLitWord64, mkLitWord64Wrap+ , mkLitWord, mkLitWordWrap, mkLitWordWrapC, mkLitWordUnchecked+ , mkLitInt8, mkLitInt8Wrap, mkLitInt8Unchecked+ , mkLitWord8, mkLitWord8Wrap, mkLitWord8Unchecked+ , mkLitInt16, mkLitInt16Wrap, mkLitInt16Unchecked+ , mkLitWord16, mkLitWord16Wrap, mkLitWord16Unchecked+ , mkLitInt32, mkLitInt32Wrap, mkLitInt32Unchecked+ , mkLitWord32, mkLitWord32Wrap, mkLitWord32Unchecked+ , mkLitInt64, mkLitInt64Wrap, mkLitInt64Unchecked+ , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked , mkLitFloat, mkLitDouble , mkLitChar, mkLitString , mkLitInteger, mkLitNatural , mkLitNumber, mkLitNumberWrap+ , mkLitRubbish -- ** Operations on Literals , literalType- , absentLiteralOf , pprLiteral , litNumIsSigned , litNumCheckRange@@ -62,7 +62,6 @@ , charToIntLit, intToCharLit , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit , nullAddrLit, floatToDoubleLit, doubleToFloatLit- , rubbishLit, isRubbishLit ) where #include "GhclibHsVersions.h"@@ -71,7 +70,6 @@ import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types-import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.TyCon import GHC.Utils.Outputable@@ -80,7 +78,6 @@ import GHC.Utils.Binary import GHC.Settings.Constants import GHC.Platform-import GHC.Types.Unique.FM import GHC.Utils.Misc import GHC.Utils.Panic @@ -115,8 +112,7 @@ -- * The literal derived from the label mentioned in a \"foreign label\" -- declaration ('LitLabel') ----- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'--- (i.e. 'MutVar#') when the value is never used.+-- * A 'LitRubbish' to be used in place of values that are never used. -- -- * A character -- * A string@@ -139,10 +135,13 @@ -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | LitRubbish Bool -- ^ A nonsense value; always boxed, but- -- True <=> lifted, False <=> unlifted- -- Used when a binding is absent.- -- See Note [Rubbish literals]+ | LitRubbish [PrimRep] -- ^ A nonsense value of the given+ -- representation. See Note [Rubbish values].+ --+ -- The @[PrimRep]@ of a 'Type' can be obtained+ -- from 'typeMonoPrimRep_maybe'. The field+ -- becomes empty or singleton post-unarisation,+ -- see Note [Post-unarisation invariants]. | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble'@@ -289,9 +288,10 @@ nt <- get bh i <- get bh return (LitNumber nt i)- _ -> do+ 7 -> do b <- get bh return (LitRubbish b)+ _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) instance Outputable Literal where ppr = pprLiteral id@@ -572,6 +572,12 @@ mkLitNatural x = ASSERT2( inNaturalRange x, integer x ) (LitNumber LitNumNatural x) +-- | Create a rubbish literal of the given representation.+-- The representation of a 'Type' can be obtained via 'typeMonoPrimRep_maybe'.+-- See Note [Rubbish values].+mkLitRubbish :: [PrimRep] -> Literal+mkLitRubbish = LitRubbish+ inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 @@ -714,14 +720,6 @@ nullAddrLit :: Literal nullAddrLit = LitNullAddr --- | A rubbish literal; see Note [Rubbish literals]-rubbishLit :: Bool -> Literal-rubbishLit is_lifted = LitRubbish is_lifted--isRubbishLit :: Literal -> Bool-isRubbishLit (LitRubbish {}) = True-isRubbishLit _ = False- {- Predicates ~~~~~~~~~~@@ -817,7 +815,8 @@ LitNumWord16 -> False LitNumWord32 -> False LitNumWord64 -> False-litIsLifted _ = False+litIsLifted _ = False+ -- Even RUBBISH[LiftedRep] is unlifted, as rubbish values are always evaluated. {- Types@@ -845,40 +844,10 @@ LitNumWord16 -> word16PrimTy LitNumWord32 -> word32PrimTy LitNumWord64 -> word64PrimTy-literalType (LitRubbish is_lifted) = mkForAllTy a Inferred (mkTyVarTy a)+literalType (LitRubbish preps) = mkForAllTy a Inferred (mkTyVarTy a) where- -- See Note [Rubbish literals]- a | is_lifted = alphaTyVar- | otherwise = alphaTyVarUnliftedRep--absentLiteralOf :: TyCon -> Maybe Literal--- Return a literal of the appropriate primitive--- TyCon, to use as a placeholder when it doesn't matter--- Rubbish literals are handled in GHC.Core.Opt.WorkWrap.Utils, because--- 1. Looking at the TyCon is not enough, we need the actual type--- 2. This would need to return a type application to a literal-absentLiteralOf tc = lookupUFM absent_lits tc---- We do not use TyConEnv here to avoid import cycles.-absent_lits :: UniqFM TyCon Literal-absent_lits = listToUFM_Directly- -- Explicitly construct the mape from the known- -- keys of these tyCons.- [ (addrPrimTyConKey, LitNullAddr)- , (charPrimTyConKey, LitChar 'x')- , (intPrimTyConKey, mkLitIntUnchecked 0)- , (int8PrimTyConKey, mkLitInt8Unchecked 0)- , (int16PrimTyConKey, mkLitInt16Unchecked 0)- , (int32PrimTyConKey, mkLitInt32Unchecked 0)- , (int64PrimTyConKey, mkLitInt64Unchecked 0)- , (wordPrimTyConKey, mkLitWordUnchecked 0)- , (word8PrimTyConKey, mkLitWord8Unchecked 0)- , (word16PrimTyConKey, mkLitWord16Unchecked 0)- , (word32PrimTyConKey, mkLitWord32Unchecked 0)- , (word64PrimTyConKey, mkLitWord64Unchecked 0)- , (floatPrimTyConKey, LitFloat 0)- , (doublePrimTyConKey, LitDouble 0)- ]+ -- See Note [Rubbish values]+ a = head $ mkTemplateTyVars [tYPE (primRepsToRuntimeRep preps)] {- Comparison@@ -930,9 +899,8 @@ where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))-pprLiteral _ (LitRubbish is_lifted)- = text "__RUBBISH"- <> parens (if is_lifted then text "lifted" else text "unlifted")+pprLiteral _ (LitRubbish reps)+ = text "RUBBISH" <> ppr reps pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core].@@ -974,61 +942,77 @@ LitDouble -1.0## LitInteger -1 (-1) LitLabel "__label" ... ("__label" ...)-LitRubbish "__RUBBISH"--Note [Rubbish literals]-~~~~~~~~~~~~~~~~~~~~~~~-During worker/wrapper after demand analysis, where an argument-is unused (absent) we do the following w/w split (supposing that-y is absent):-- f x y z = e-===>- f x y z = $wf x z- $wf x z = let y = <absent value>- in e--Usually the binding for y is ultimately optimised away, and-even if not it should never be evaluated -- but that's the-way the w/w split starts off.+LitRubbish "RUBBISH[...]" -What is <absent value>?-* For lifted values <absent value> can be a call to 'error'.-* For primitive types like Int# or Word# we can use any random- value of that type.-* But what about /unlifted/ but /boxed/ types like MutVar# or- Array#? Or /lifted/ but /strict/ values, such as a field of- a strict data constructor. For these we use LitRubbish.- See Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils.hs+Note [Rubbish values]+~~~~~~~~~~~~~~~~~~~~~+Sometimes, we need to cough up a rubbish value of a certain type that is used+in place of dead code we thus aim to eliminate. The value of a dead occurrence+has no effect on the dynamic semantics of the program, so we can pick any value+of the same representation.+Exploiting the results of absence analysis in worker/wrapper is a scenario where+we need such a rubbish value, see Note [Absent fillers] for examples. -The literal (LitRubbish is_lifted)-has type- LitRubbish :: forall (a :: TYPE LiftedRep). a if is_lifted- LitRubbish :: forall (a :: TYPE UnliftedRep). a otherwise+It's completely undefined what the *value* of a rubbish value is, e.g., we could+pick @0#@ for @Int#@ or @42#@; it mustn't matter where it's inserted into a Core+program. We embed these rubbish values in the 'LitRubbish' case of the 'Literal'+data type. Here are the moving parts: -So we might see a w/w split like- $wf x z = let y :: Array# Int = (LitRubbish False) @(Array# Int)- in e+ 1. Source Haskell: No way to produce rubbish lits in source syntax. Purely+ an IR feature. -Here are the moving parts, but see also Note [Absent errors] in-GHC.Core.Opt.WorkWrap.Utils+ 2. Core: 'LitRubbish' carries a @[PrimRep]@ which represents the monomorphic+ 'RuntimeRep' of the type it is substituting for.+ We have it that @RUBBISH[IntRep]@ has type @forall (a :: TYPE IntRep). a@,+ and the type application @RUBBISH[IntRep] \@Int# :: Int#@ represents+ a rubbish value of type @Int#@. Rubbish lits are completely opaque in Core.+ In general, @RUBBISH[preps] :: forall (a :: TYPE rep). a@, where @rep@+ is the 'RuntimeRep' corresponding to @preps :: [PrimRep]@+ (via 'primRepsToRuntimeRep'). See 'literalType'.+ Why not encode a 'RuntimeRep' via a @Type@? Thus+ > data Literal = ... | LitRubbish Type | ...+ Because+ * We have to provide an Eq and Ord instance and @Type@ has none+ * The encoded @Type@ might be polymorphic and we can only emit code for+ monomorphic 'RuntimeRep's anyway. -* We define LitRubbish as a constructor in GHC.Types.Literal.Literal+ 3. STG: The type app in @RUBBISH[IntRep] \@Int# :: Int#@ is erased and we get+ the (untyped) 'StgLit' @RUBBISH[IntRep] :: Int#@ in STG.+ It's treated mostly opaque, with the exception of the Unariser, where we+ take apart a case scrutinisation on, or arg occurrence of, e.g.,+ @RUBBISH[IntRep,DoubleRep]@ (which may stand in for @(# Int#, Double# #)@)+ into its sub-parts @RUBBISH[IntRep]@ and @RUBBISH[DoubleRep]@, similar to+ unboxed tuples. @RUBBISH[VoidRep]@ is erased.+ See 'unariseRubbish_maybe' and also Note [Post-unarisation invariants]. -* It is given its polymorphic type by Literal.literalType+ 4. Cmm: We translate 'LitRubbish' to their actual rubbish value in 'cgLit'.+ The particulars are boring, and only matter when debugging illicit use of+ a rubbish value; see Modes of failure below. -* GHC.Core.Opt.WorkWrap.Utils.mk_absent_let introduces a LitRubbish for absent- arguments of boxed, unlifted type; or boxed, lifted arguments of strict data- constructors.+ 5. Bytecode: In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's+ all boxed to the host GC anyway. -* In CoreToSTG we convert (RubishLit @t) to just (). STG is untyped, so this- will work OK for both lifted and unlifted (but boxed) values. The important- thing is that it is a heap pointer, which the garbage collector can follow if- it encounters it.+Why not lower LitRubbish in CoreToStg? Because it enables us to use RubbishLit+when unarising unboxed sums in the future, and it allows rubbish values of e.g.+VecRep, for which we can't cough up dummy values in STG. - We considered maintaining LitRubbish in STG, and lowering it in the code- generators, but it seems simpler to do it once and for all in CoreToSTG.+Modes of failure+----------------+Suppose there is a bug in GHC, and a rubbish value is used after all. That is+undefined behavior, of course, but let us list a few examples for failure modes: - In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's all boxed to- the host GC anyway.--}+ a) For an value of unboxed numeric type like @Int#@, we just use a silly+ value like 42#. The error might propoagate indefinitely, hence we better+ pick a rather unique literal. Same for Word, Floats, Char and VecRep.+ b) For AddrRep (like String lits), we mit a null pointer, resulting in a+ definitive segfault when accessed.+ c) For boxed values, unlifted or not, we use a pointer to a fixed closure,+ like @()@, so that the GC has a pointer to follow.+ If we use that pointer as an 'Array#', we will likely access fields of the+ array that don't exist, and a seg-fault is likely, but not guaranteed.+ If we use that pointer as @Either Int Bool@, we might try to access the+ 'Int' field of the 'Left' constructor (which has the same ConTag as '()'),+ which doesn't exists. In the best case, we'll find an invalid pointer in its+ position and get a seg-fault, in the worst case the error manifests only one+ or two indirections later.+ -}
compiler/GHC/Types/RepType.hs view
@@ -11,7 +11,7 @@ isVoidTy, -- * Type representation for the code generator- typePrimRep, typePrimRep1,+ typePrimRep, typePrimRep1, typeMonoPrimRep_maybe, runtimeRepPrimRep, typePrimRepArgs, PrimRep(..), primRepToType, countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,@@ -34,7 +34,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind )+import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind, runtimeRepTy ) import GHC.Utils.Misc import GHC.Utils.Outputable@@ -235,7 +235,7 @@ -- -- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit -- values, so that we can pack things more tightly.-data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot+data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot | VecSlot Int PrimElemRep deriving (Eq, Ord) -- Constructor order is important! If slot A could fit into slot B -- then slot A must occur first. E.g. FloatSlot before DoubleSlot@@ -250,6 +250,7 @@ ppr WordSlot = text "WordSlot" ppr DoubleSlot = text "DoubleSlot" ppr FloatSlot = text "FloatSlot"+ ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e typeSlotTy :: UnaryType -> Maybe SlotTy typeSlotTy ty@@ -275,7 +276,7 @@ primRepSlot AddrRep = WordSlot primRepSlot FloatRep = FloatSlot primRepSlot DoubleRep = DoubleSlot-primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep")+primRepSlot (VecRep n e) = VecSlot n e slotPrimRep :: SlotTy -> PrimRep slotPrimRep PtrLiftedSlot = LiftedRep@@ -284,6 +285,7 @@ slotPrimRep WordSlot = WordRep slotPrimRep DoubleSlot = DoubleRep slotPrimRep FloatSlot = FloatRep+slotPrimRep (VecSlot n e) = VecRep n e -- | Returns the bigger type if one fits into the other. (commutative) fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy@@ -493,6 +495,14 @@ [rep] -> rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +-- | Like 'typePrimRep', but returns 'Nothing' instead of panicking, when+--+-- * The @ty@ was not of form @TYPE rep@+-- * @rep@ was not monomorphic+--+typeMonoPrimRep_maybe :: Type -> Maybe [PrimRep]+typeMonoPrimRep_maybe ty = getRuntimeRep_maybe ty >>= runtimeRepMonoPrimRep_maybe+ -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -524,6 +534,18 @@ runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc)++-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that+-- it encodes if it's a monomorphic rep. Otherwise returns 'Nothing'.+-- See also Note [Getting from RuntimeRep to PrimRep]+runtimeRepMonoPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep]+runtimeRepMonoPrimRep_maybe rr_ty+ | Just (rr_dc, args) <- splitTyConApp_maybe rr_ty+ , ASSERT2( runtimeRepTy `eqType` typeKind rr_ty, ppr rr_ty ) True+ , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc+ = Just (fun args)+ | otherwise+ = Nothing -- not mono rep -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]
compiler/GHC/Types/SrcLoc.hs view
@@ -68,6 +68,7 @@ getBufPos, BufSpan(..), getBufSpan,+ removeBufSpan, -- * Located Located,@@ -394,6 +395,10 @@ | UnhelpfulGenerated | UnhelpfulOther !FastString deriving (Eq, Show)++removeBufSpan :: SrcSpan -> SrcSpan+removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Nothing+removeBufSpan s = s {- Note [Why Maybe BufPos] ~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Utils/Binary.hs view
@@ -1240,19 +1240,6 @@ return (mkRealSrcSpan (mkRealSrcLoc f sl sc) (mkRealSrcLoc f el ec)) -instance Binary BufPos where- put_ bh (BufPos i) = put_ bh i- get bh = BufPos <$> get bh--instance Binary BufSpan where- put_ bh (BufSpan start end) = do- put_ bh start- put_ bh end- get bh = do- start <- get bh- end <- get bh- return (BufSpan start end)- instance Binary UnhelpfulSpanReason where put_ bh r = case r of UnhelpfulNoLocationInfo -> putByte bh 0@@ -1271,10 +1258,11 @@ _ -> UnhelpfulOther <$> get bh instance Binary SrcSpan where- put_ bh (RealSrcSpan ss sb) = do+ put_ bh (RealSrcSpan ss _sb) = do putByte bh 0+ -- BufSpan doesn't ever get serialised because the positions depend+ -- on build location. put_ bh ss- put_ bh sb put_ bh (UnhelpfulSpan s) = do putByte bh 1@@ -1284,7 +1272,6 @@ h <- getByte bh case h of 0 -> do ss <- get bh- sb <- get bh- return (RealSrcSpan ss sb)+ return (RealSrcSpan ss Nothing) _ -> do s <- get bh return (UnhelpfulSpan s)
compiler/GHC/Utils/Misc.hs view
@@ -43,7 +43,7 @@ listLengthCmp, atLength, equalLength, compareLength, leLength, ltLength, - isSingleton, only, GHC.Utils.Misc.singleton,+ isSingleton, only, expectOnly, GHC.Utils.Misc.singleton, notNull, snocView, isIn, isn'tIn,@@ -561,6 +561,18 @@ only (a:_) = a #endif only _ = panic "Util: only"++-- | Extract the single element of a list and panic with the given message if+-- there are more elements or the list was empty.+-- Like 'expectJust', but for lists.+expectOnly :: HasCallStack => String -> [a] -> a+{-# INLINE expectOnly #-}+#if defined(DEBUG)+expectOnly _ [a] = a+#else+expectOnly _ (a:_) = a+#endif+expectOnly msg _ = panic ("expectOnly: " ++ msg) -- Debugging/specialising versions of \tr{elem} and \tr{notElem}
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.2.4.20220729+version: 9.2.5.20221107 license: BSD3 license-file: LICENSE category: Development
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "a54827e0b48af33fa9cfde6ad131c6751c2fe321"+cProjectGitCommitId = "74ca6191fa0dbbe8cee3dc53741b8d59fbf16b09" cProjectVersion :: String-cProjectVersion = "9.2.4"+cProjectVersion = "9.2.5" cProjectVersionInt :: String cProjectVersionInt = "902" cProjectPatchLevel :: String-cProjectPatchLevel = "4"+cProjectPatchLevel = "5" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "4"+cProjectPatchLevel1 = "5" cProjectPatchLevel2 :: String cProjectPatchLevel2 = ""
includes/CodeGen.Platform.hs view
@@ -1028,6 +1028,14 @@ -- ip0 -- used for spill offset computations freeReg 16 = False +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)+-- x18 is reserved by the platform on Darwin/iOS, and can not be used+-- More about ARM64 ABI that Apple platforms support:+-- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms+-- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md+freeReg 18 = False+#endif+ # if defined(REG_Base) freeReg REG_Base = False # endif
libraries/ghci/GHCi/Message.hs view
@@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 2 || \- (major1) == 9 && (major2) == 2 && (minor) <= 4)+ (major1) == 9 && (major2) == 2 && (minor) <= 5) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo