ghc-lib 9.2.4.20220729 → 9.2.5.20221107
raw patch · 26 files changed
+362/−238 lines, 26 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC/Cmm/LayoutStack.hs +2/−1
- compiler/GHC/Cmm/Lint.hs +15/−3
- compiler/GHC/Cmm/Parser.y +1/−0
- compiler/GHC/Cmm/Utils.hs +2/−1
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +20/−12
- compiler/GHC/Core/Opt/Simplify.hs +37/−11
- compiler/GHC/Core/Opt/Simplify/Utils.hs +1/−3
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +89/−105
- compiler/GHC/CoreToStg.hs +3/−7
- compiler/GHC/Iface/Ext/Types.hs +2/−2
- compiler/GHC/Stg/Unarise.hs +31/−2
- compiler/GHC/StgToCmm/ArgRep.hs +1/−1
- compiler/GHC/StgToCmm/Env.hs +0/−20
- compiler/GHC/StgToCmm/Expr.hs +4/−3
- compiler/GHC/StgToCmm/Expr.hs-boot +7/−0
- compiler/GHC/StgToCmm/Foreign.hs +0/−1
- compiler/GHC/StgToCmm/Heap.hs +0/−1
- compiler/GHC/StgToCmm/Layout.hs +21/−1
- compiler/GHC/StgToCmm/Lit.hs +105/−0
- compiler/GHC/StgToCmm/Monad.hs +6/−0
- compiler/GHC/StgToCmm/Prim.hs +0/−1
- compiler/GHC/StgToCmm/Prof.hs +1/−0
- compiler/GHC/StgToCmm/Ticky.hs +1/−0
- compiler/GHC/StgToCmm/Utils.hs +2/−61
- ghc-lib.cabal +3/−2
- includes/CodeGen.Platform.hs +8/−0
compiler/GHC/Cmm/LayoutStack.hs view
@@ -8,7 +8,8 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation+import GHC.StgToCmm.Monad ( newTemp ) -- XXX layering violation+import GHC.StgToCmm.Utils ( callerSaveVolatileRegs ) -- XXX layering violation import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation import GHC.Types.Basic
compiler/GHC/Cmm/Lint.hs view
@@ -170,9 +170,21 @@ platform <- getPlatform erep <- lintCmmExpr expr let reg_ty = cmmRegType platform reg- if (erep `cmmEqType_ignoring_ptrhood` reg_ty)- then return ()- else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+ unless (compat_regs erep reg_ty) $+ cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+ where+ compat_regs :: CmmType -> CmmType -> Bool+ compat_regs ty1 ty2+ -- As noted in #22297, SIMD vector registers can be used for+ -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,+ -- or 4 Int32s, or 2 Word64s, ...+ -- To allow this, we relax the check: we only ensure that the widths+ -- match, until we can find a more robust solution.+ | isVecType ty1+ , isVecType ty2+ = typeWidth ty1 == typeWidth ty2+ | otherwise+ = cmmEqType_ignoring_ptrhood ty1 ty2 CmmStore l r _alignment -> do _ <- lintCmmExpr l
compiler/GHC/Cmm/Parser.y view
@@ -218,6 +218,7 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign import GHC.StgToCmm.Expr+import GHC.StgToCmm.Lit import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout hiding (ArgRep(..)) import GHC.StgToCmm.Ticky
compiler/GHC/Cmm/Utils.hs view
@@ -115,7 +115,7 @@ AddrRep -> bWord platform FloatRep -> f32 DoubleRep -> f64- (VecRep len rep) -> vec len (primElemRepCmmType rep)+ VecRep len rep -> vec len (primElemRepCmmType rep) slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case@@ -125,6 +125,7 @@ Word64Slot -> b64 FloatSlot -> f32 DoubleSlot -> f64+ VecSlot l e -> vec l (primElemRepCmmType e) primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep = b8
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -664,10 +664,11 @@ -- See Note [Signed arithmetic on AArch64]. negate code w reg = do let w' = opRegWidth w+ (reg', code_sx) <- signExtendReg w w' reg return $ Any (intFormat w) $ \dst -> code `appOL`- signExtendReg w w' reg `snocOL`- NEG (OpReg w' dst) (OpReg w' reg) `appOL`+ code_sx `snocOL`+ NEG (OpReg w' dst) (OpReg w' reg') `appOL` truncateReg w' w dst ss_conv from to reg code =@@ -817,15 +818,17 @@ -- should be performed. let w' = opRegWidth w signExt r- | not is_signed = nilOL+ | not is_signed = return (r, nilOL) | otherwise = signExtendReg w w' r+ (reg_x_sx, code_x_sx) <- signExt reg_x+ (reg_y_sx, code_y_sx) <- signExt reg_y return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` -- sign-extend both operands- signExt reg_x `appOL`- signExt reg_y `appOL`- op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+ code_x_sx `appOL`+ code_y_sx `appOL`+ op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` truncateReg w' w dst -- truncate back to the operand's original width floatOp w op = do@@ -1021,16 +1024,21 @@ -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) signExtendReg w w' r = case w of- W64 -> nilOL+ W64 -> noop W32- | w' == W32 -> nilOL- | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W16 -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W8 -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+ | w' == W32 -> noop+ | otherwise -> extend SXTH+ W16 -> extend SXTH+ W8 -> extend SXTB _ -> panic "intOp"+ where+ noop = return (r, nilOL)+ extend instr = do+ r' <- getNewRegNat II64+ return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) -- | Instructions to truncate the value in the given register from width @w@ -- down to width @w'@.
compiler/GHC/Core/Opt/Simplify.hs view
@@ -2064,19 +2064,32 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey- , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args- = do { s <- newId (fsLit "s") Many realWorldStatePrimTy- ; let (m,_,_) = splitFunTy fun_ty- env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+ -- Do this even if (contIsStop cont)+ -- See Note [No eta-expansion in runRW#]+ = do { let arg_env = arg_se `setInScopeFromE` env ty' = contResultType cont- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s- , sc_env = env', sc_cont = cont- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }- -- cont' applies to s, then K- ; body' <- simplExprC env' arg cont'- ; let arg' = Lam s body'- rr' = getRuntimeRep ty'++ -- If the argument is a literal lambda already, take a short cut+ -- This isn't just efficiency; if we don't do this we get a beta-redex+ -- every time, so the simplifier keeps doing more iterations.+ ; arg' <- case arg of+ Lam s body -> do { (env', s') <- simplBinder arg_env s+ ; body' <- simplExprC env' body cont+ ; return (Lam s' body') }+ -- Important: do not try to eta-expand this lambda+ -- See Note [No eta-expansion in runRW#]+ _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy+ ; let (m,_,_) = splitFunTy fun_ty+ env' = arg_env `addNewInScopeIds` [s']+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'+ , sc_env = env', sc_cont = cont+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }+ -- cont' applies to s', then K+ ; body' <- simplExprC env' arg cont'+ ; return (Lam s' body') }++ ; let rr' = getRuntimeRep ty' call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] ; return (emptyFloats env, call') } @@ -2183,6 +2196,19 @@ discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! +Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda. Why not? Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ * *
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -1697,9 +1697,7 @@ tryEtaExpandRhs mode bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs- oss = [idOneShotInfo id | id <- join_bndrs, isId id]- arity_type | exprIsDeadEnd join_body = mkBotArityType oss- | otherwise = mkTopArityType oss+ arity_type = mkManifestArityType join_bndrs join_body ; return (arity_type, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -20,7 +20,7 @@ import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase- , dataConRepFSInstPat )+ , bindNonRec, dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon@@ -29,14 +29,14 @@ import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup , mkCoreApp, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types ( tupleDataCon, unboxedUnitTy )-import GHC.Types.Literal ( absentLiteralOf, rubbishLit )+import GHC.Builtin.Types ( tupleDataCon )+import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred )-import GHC.Types.RepType ( isVoidTy, typePrimRep )+import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe ) import GHC.Core.Coercion import GHC.Core.FamInstEnv import GHC.Types.Basic ( Boxity(..) )@@ -895,9 +895,9 @@ = return (False, [arg], nop_fn, nop_fn) | isAbsDmd dmd- , Just work_fn <- mk_absent_let dflags fam_envs arg dmd- -- Absent case. We can't always handle absence for arbitrary- -- unlifted types, so we need to choose just the cases we can+ , Just work_fn <- mk_absent_let dflags arg dmd+ -- Absent case. We can't always handle absence for rep-polymorphic+ -- types, so we need to choose just the cases we can -- (that's what mk_absent_let does) = return (True, [], nop_fn, work_fn) @@ -1281,70 +1281,74 @@ * * ************************************************************************ -Note [Absent errors]-~~~~~~~~~~~~~~~~~~~~+Note [Absent fillers]+~~~~~~~~~~~~~~~~~~~~~ Consider- data T = MkT [Int] [Int] ![Int]- f :: T -> Int# -> blah- f ps w = case ps of MkT xs _ _ -> <body mentioning xs>-Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus: -$wf :: [Int] -> blah-$wf xs = case ps of MkT xs _ _ -> <body mentioning xs>- where- ys = absentError "ys :: [Int]"- zs = LitRubbish True- ps = MkT xs ys zs- w = 0#+ data T = MkT [Int] [Int] ![Int] -- NB: last field is strict+ f :: T -> Int# -> blah+ f ps w = case ps of MkT xs ys zs -> <body mentioning xs> -We make a let-binding for Absent arguments, such as ys and w, that are not even-passed to the worker. They should, of course, never be used. We distinguish four-cases:+Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus: -1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids- that are marked absent, thus- let ys = absentError "ys :: [Int]"- The idea is that this binding will never be used; but if it- buggily is used we'll get a runtime error message.+ $wf :: [Int] -> blah+ $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+ where+ ys = absentError "ys :: [Int]"+ zs = RUBBISH[LiftedRep] @[Int]+ ps = MkT xs ys zs+ w = RUBBISH[IntRep] @Int# -2. Boxed, lifted types, with a strict demand, like 'zs'. You may ask: how the- demand be both absent and strict? That's exactly what happens for 'zs': it- is not used, so its demand is Absent, but then during w/w, in- addDataConStrictness, we strictify the demand. So it gets cardinality C_10,- the empty interval.+The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.+And neither should they! They are never used, their value is irrelevant (hence+they are *dead code*) and they are probably discarded after the next run of the+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up+with "filler" values that we bind the absent arg Ids to. - We don't want to use an error-thunk for 'zs' because MkT's third argument has- a bang, and hence should be always evaluated. This turned out to be- important when fixing #16970, which establishes the invariant that strict- constructor arguments are always evaluated. So we use LitRubbish instead- of an error thunk -- see #19133.+That is exactly what Note [Rubbish values] are for: A convenient way to+conjure filler values at any type (and any representation or levity!). - These first two cases are distinguished by isStrictDmd in lifted_rhs.+Needless to say, there are some wrinkles: -3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence- for unboxed types is important; see, for example, #4306 and #15627. We- simply find a suitable literal, using Literal.absentLiteralOf. We don't have- literals for every primitive type, so the function is partial.+ 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+ instead. If absence analysis was wrong (e.g., #11126) and the binding+ in fact is used, then we get a nice panic message instead of undefined+ runtime behavior (See Modes of failure from Note [Rubbish values]). -4. Boxed, unlifted types, like (Array# t). We can't use absentError because- unlifted bindings ares strict. So we use LitRubbish, which we need to apply- to the required type.+ Obviously, we can't use an error-thunk if the value is of unlifted rep+ (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. -Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish-literals] in GHC.Types.Literal. We could do that in case (1) as well, but we-get slightly better self-checking with an error thunk.+ 2. We also mustn't put an error-thunk (that fills in for an absent value of+ lifted rep) in a strict field, because #16970 establishes the invariant+ that strict fields are always evaluated, by (re-)evaluating what is put in+ a strict field. That's the reason why 'zs' binds a rubbish literal instead+ of an error-thunk, see #19133. -Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"-value is used after all. Then in case (2) we could get a seg-fault, because we-may have replaced, say, a [Either Int Bool] by (), and that will fail if we do-case analysis on it. Similarly with boxed unlifted types, case (4).+ How do we detect when we are about to put an error-thunk in a strict field?+ Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but+ it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.+ So we rather look out for a necessary condition for strict fields:+ Note [Add demands for strict constructors] makes it so that the demand on+ 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty+ interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees+ we never fill in an error-thunk for an absent strict field.+ But that also means we emit a rubbish lit for other args that have+ cardinality 'C_10' (say, the arg to a bottoming function) where we could've+ used an error-thunk, but that's a small price to pay for simplicity. -In case (3), if absence analysis is wrong we could conceivably get an exception,-from a divide-by-zero with the absent value. But it's very unlikely.+ 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.+ of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+ Why? Because if we don't know its representation (e.g. size in memory,+ register class), we don't know what or how much rubbish to emit in codegen.+ 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall+ back to passing the original parameter to the worker. -Only in case (1) can we guarantee a civilised runtime error. Not much we can do-about this; we really rely on absence analysis to be correct.+ Note that currently this case should not occur, because binders always+ have to be representation monomorphic. But in the future, we might allow+ levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. +While (1) and (2) are simply an optimisation in terms of compiler debugging+experience, (3) should be irrelevant in most programs, if not all. Historical note: I did try the experiment of using an error thunk for unlifted things too, relying on the simplifier to drop it as dead code. But this is@@ -1368,66 +1372,46 @@ -- -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found (currently only happens for bindings of 'VecRep' representation).-mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags fam_envs arg dmd-- -- The lifted case: Bind 'absentError'- -- See Note [Absent errors]- | not (isUnliftedType arg_ty)- = Just (Let (NonRec lifted_arg lifted_rhs))- -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@- -- See Note [Absent errors]-- | [UnliftedRep] <- typePrimRep arg_ty- = Just (Let (NonRec arg unlifted_rhs))-- -- The monomorphic unlifted cases: Bind to some literal, if possible- -- See Note [Absent errors]- | Just tc <- tyConAppTyCon_maybe nty- , Just lit <- absentLiteralOf tc- = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))+-- found.+mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags arg dmd+ -- The lifted case: Bind 'absentError' for a nice panic message if we are+ -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+ | Just [LiftedRep] <- mb_mono_prim_reps+ , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]+ = Just (Let (NonRec arg panic_rhs)) - | nty `eqType` unboxedUnitTy- = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))+ -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@+ -- See Note [Absent fillers], the main part+ | Just prim_reps <- mb_mono_prim_reps+ = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty])) - | otherwise+ -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.+ -- See (3) in Note [Absent fillers]+ | Nothing <- mb_mono_prim_reps = WARN( True, text "No absent value for" <+> ppr arg_ty )- Nothing -- Can happen for 'State#' and things of 'VecRep'+ Nothing where- lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr- -- Note in strictness signature that this is bottoming- -- (for the sake of the "empty case scrutinee not known to- -- diverge for sure lint" warning)-- lifted_rhs | isStrictDmd dmd = mkTyApps (Lit (rubbishLit True)) [arg_ty]- | otherwise = mkAbsentErrorApp arg_ty msg- unlifted_rhs = mkTyApps (Lit (rubbishLit False)) [arg_ty]-- arg_ty = idType arg+ arg_ty = idType arg+ mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty - -- Normalise the type to have best chance of finding an absent literal- -- e.g. (#17852) data unlifted N = MkN Int#- -- f :: N -> a -> a- -- f _ x = x- (co, nty) = topNormaliseType_maybe fam_envs arg_ty- `orElse` (mkRepReflCo arg_ty, arg_ty)+ panic_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques)- (vcat- [ text "Arg:" <+> ppr arg- , text "Type:" <+> ppr arg_ty- , file_msg- ])- file_msg = case outputFile dflags of- Nothing -> empty- Just f -> text "In output file " <+> quotes (text f)+ msg = showSDoc (gopt_set dflags Opt_SuppressUniques)+ (vcat+ [ text "Arg:" <+> ppr arg+ , text "Type:" <+> ppr arg_ty+ , file_msg+ ]) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for -- determinism, because with different uniques the strings -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique+ file_msg = case outputFile dflags of+ Nothing -> empty+ Just f -> text "In output file " <+> quotes (text f) ww_prefix :: FastString ww_prefix = fsLit "ww"
compiler/GHC/CoreToStg.hs view
@@ -39,7 +39,7 @@ import GHC.Unit.Module import GHC.Types.Name ( isExternalName, nameModule_maybe ) import GHC.Types.Basic ( Arity )-import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )+import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Types.Literal import GHC.Utils.Outputable import GHC.Utils.Monad@@ -388,12 +388,8 @@ -- CorePrep should have converted them all to a real core representation. coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"-coreToStgExpr (Lit l) = return (StgLit l)-coreToStgExpr (App (Lit lit) _some_boxed_type)- | isRubbishLit lit- -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in- -- a STG to Cmm pass. Doesn't matter whether it is lifted or unlifted- = coreToStgExpr (Var unitDataConId)+coreToStgExpr (Lit l) = return (StgLit l)+coreToStgExpr (App l@(Lit LitRubbish{}) Type{}) = coreToStgExpr l coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _) -- See Note [Coercion tokens]
compiler/GHC/Iface/Ext/Types.hs view
@@ -780,5 +780,5 @@ | isKnownKeyName name = KnownKeyName (nameUnique name) | isExternalName name = ExternalName (nameModule name) (nameOccName name)- (nameSrcSpan name)- | otherwise = LocalName (nameOccName name) (nameSrcSpan name)+ (removeBufSpan $ nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
compiler/GHC/Stg/Unarise.hs view
@@ -219,6 +219,9 @@ This means that it's safe to wrap `StgArg`s of DataCon applications with `GHC.StgToCmm.Env.NonVoid`, for example. + * Similar to unboxed tuples, Note [Rubbish values] of TupleRep may only+ appear in return position.+ * Alt binders (binders in patterns) are always non-void. * Binders always have zero (for void arguments) or one PrimRep.@@ -233,6 +236,7 @@ import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon+import GHC.Core.TyCon ( isVoidRep ) import GHC.Data.FastString (FastString, mkFastString) import GHC.Types.Id import GHC.Types.Literal@@ -385,6 +389,11 @@ , Just args' <- unariseMulti_maybe rho dc args ty_args = elimCase rho args' bndr alt_ty alts + -- See (3) of Note [Rubbish values] in GHC.Types.Literal+ | StgLit lit <- scrut+ , Just args' <- unariseRubbish_maybe lit+ = elimCase rho args' bndr alt_ty alts+ -- general case | otherwise = do scrut' <- unariseExpr rho scrut@@ -415,6 +424,22 @@ | otherwise = Nothing +-- Doesn't return void args.+unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]+unariseRubbish_maybe lit+ | LitRubbish preps <- lit+ , [prep] <- preps+ , not (isVoidRep prep)+ -- Single, non-void PrimRep. Nothing to do!+ = Nothing++ | LitRubbish preps <- lit+ -- Multiple reps, possibly with VoidRep. Eliminate!+ = Just [ StgLitArg (LitRubbish [prep]) | prep <- preps, not (isVoidRep prep) ]++ | otherwise+ = Nothing+ -------------------------------------------------------------------------------- elimCase :: UnariseEnv@@ -633,6 +658,7 @@ ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)+ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish [VecRep n e]) -------------------------------------------------------------------------------- @@ -756,8 +782,11 @@ -- Here realWorld# is not in the envt, but -- is a void, and so should be eliminated | otherwise -> [StgVarArg x]-unariseConArg _ arg@(StgLitArg lit) =- ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals+unariseConArg _ arg@(StgLitArg lit)+ | Just as <- unariseRubbish_maybe lit+ = as+ | otherwise+ = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals [arg] unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -87,7 +87,7 @@ PW8 -> N FloatRep -> F DoubleRep -> D- (VecRep len elem) -> case len*primElemRepSizeB elem of+ (VecRep len elem) -> case len*primElemRepSizeB platform elem of 16 -> V16 32 -> V32 64 -> V64
compiler/GHC/StgToCmm/Env.hs view
@@ -17,7 +17,6 @@ bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg,- getArgAmode, getNonVoidArgAmodes, getCgIdInfo, maybeLetNoEscape, ) where@@ -26,10 +25,8 @@ import GHC.Prelude -import GHC.Core.TyCon import GHC.Platform import GHC.StgToCmm.Monad-import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure import GHC.Cmm.CLabel@@ -40,7 +37,6 @@ import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name-import GHC.Stg.Syntax import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM@@ -160,22 +156,6 @@ pprUFM local_binds $ \infos -> vcat [ ppr (cg_id info) | info <- infos ] ])------------------------getArgAmode :: NonVoid StgArg -> FCode CmmExpr-getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var-getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit--getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]--- NB: Filters out void args,--- so the result list may be shorter than the argument list-getNonVoidArgAmodes [] = return []-getNonVoidArgAmodes (arg:args)- | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args- | otherwise = do { amode <- getArgAmode (NonVoid arg)- ; amodes <- getNonVoidArgAmodes args- ; return ( amode : amodes ) } ------------------------------------------------------------------------
compiler/GHC/StgToCmm/Expr.hs view
@@ -10,7 +10,7 @@ -- ----------------------------------------------------------------------------- -module GHC.StgToCmm.Expr ( cgExpr ) where+module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where #include "GhclibHsVersions.h" @@ -24,6 +24,7 @@ import GHC.StgToCmm.DataCon import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC) import GHC.StgToCmm.Layout+import GHC.StgToCmm.Lit import GHC.StgToCmm.Prim import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky@@ -115,8 +116,8 @@ cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con mn args _) = cgConApp con mn args cgExpr (StgTick t e) = cgTick t >> cgExpr e-cgExpr (StgLit lit) = do cmm_lit <- cgLit lit- emitReturn [CmmLit cmm_lit]+cgExpr (StgLit lit) = do cmm_expr <- cgLit lit+ emitReturn [cmm_expr] cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape _ binds expr) =
+ compiler/GHC/StgToCmm/Expr.hs-boot view
@@ -0,0 +1,7 @@+module GHC.StgToCmm.Expr where++import GHC.Cmm.Expr+import GHC.StgToCmm.Monad+import GHC.Types.Literal++cgLit :: Literal -> FCode CmmExpr
compiler/GHC/StgToCmm/Foreign.hs view
@@ -29,7 +29,6 @@ import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType)-import GHC.StgToCmm.Env import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure
compiler/GHC/StgToCmm/Heap.hs view
@@ -32,7 +32,6 @@ import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Closure-import GHC.StgToCmm.Env import GHC.Cmm.Graph
compiler/GHC/StgToCmm/Layout.hs view
@@ -26,7 +26,8 @@ mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW -- re-exported from GHC.StgToCmm.ArgRep+ ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep+ getArgAmode, getNonVoidArgAmodes ) where @@ -42,6 +43,7 @@ import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern ) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Monad+import GHC.StgToCmm.Lit import GHC.StgToCmm.Utils import GHC.Cmm.Graph@@ -589,6 +591,24 @@ [P,P,P,P,P,P] -> Just ARG_PPPPPP _ -> Nothing++-------------------------------------------------------------------------+-- Amodes for arguments+-------------------------------------------------------------------------++getArgAmode :: NonVoid StgArg -> FCode CmmExpr+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var+getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit++getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]+-- NB: Filters out void args,+-- so the result list may be shorter than the argument list+getNonVoidArgAmodes [] = return []+getNonVoidArgAmodes (arg:args)+ | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args+ | otherwise = do { amode <- getArgAmode (NonVoid arg)+ ; amodes <- getNonVoidArgAmodes args+ ; return ( amode : amodes ) } ------------------------------------------------------------------------- --
+ compiler/GHC/StgToCmm/Lit.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP, LambdaCase #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: literals+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Lit (+ cgLit, mkSimpleLit,+ newStringCLit, newByteStringCLit+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Platform+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Utils++import GHC.Types.Literal+import GHC.Builtin.Types ( unitDataConId )+import GHC.Core.TyCon+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.Char (ord)++newStringCLit :: String -> FCode CmmLit+-- ^ Make a global definition for the string,+-- and return its label+newStringCLit str = newByteStringCLit (BS8.pack str)++newByteStringCLit :: ByteString -> FCode CmmLit+newByteStringCLit bytes+ = do { uniq <- newUnique+ ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes+ ; emitDecl decl+ ; return lit }++cgLit :: Literal -> FCode CmmExpr+cgLit (LitString s) =+ CmmLit <$> newByteStringCLit s+ -- not unpackFS; we want the UTF-8 byte stream.+cgLit (LitRubbish preps) =+ case expectOnly "cgLit:Rubbish" preps of -- Note [Post-unarisation invariants]+ VoidRep -> panic "cgLit:VoidRep" -- dito+ LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId+ UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId+ AddrRep -> cgLit LitNullAddr+ VecRep n elem -> do+ platform <- getPlatform+ let elem_lit = mkSimpleLit platform (num_rep_lit (primElemRepToPrimRep elem))+ pure (CmmLit (CmmVec (replicate n elem_lit)))+ prep -> cgLit (num_rep_lit prep)+ where+ num_rep_lit IntRep = mkLitIntUnchecked 0+ num_rep_lit Int8Rep = mkLitInt8Unchecked 0+ num_rep_lit Int16Rep = mkLitInt16Unchecked 0+ num_rep_lit Int32Rep = mkLitInt32Unchecked 0+ num_rep_lit Int64Rep = mkLitInt64Unchecked 0+ num_rep_lit WordRep = mkLitWordUnchecked 0+ num_rep_lit Word8Rep = mkLitWord8Unchecked 0+ num_rep_lit Word16Rep = mkLitWord16Unchecked 0+ num_rep_lit Word32Rep = mkLitWord32Unchecked 0+ num_rep_lit Word64Rep = mkLitWord64Unchecked 0+ num_rep_lit FloatRep = LitFloat 0+ num_rep_lit DoubleRep = LitDouble 0+ num_rep_lit other = pprPanic "num_rep_lit: Not a num lit" (ppr other)+cgLit other_lit = do+ platform <- getPlatform+ pure (CmmLit (mkSimpleLit platform other_lit))++mkSimpleLit :: Platform -> Literal -> CmmLit+mkSimpleLit platform = \case+ (LitChar c) -> CmmInt (fromIntegral (ord c))+ (wordWidth platform)+ LitNullAddr -> zeroCLit platform+ (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)+ (LitNumber LitNumInt8 i) -> CmmInt i W8+ (LitNumber LitNumInt16 i) -> CmmInt i W16+ (LitNumber LitNumInt32 i) -> CmmInt i W32+ (LitNumber LitNumInt64 i) -> CmmInt i W64+ (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)+ (LitNumber LitNumWord8 i) -> CmmInt i W8+ (LitNumber LitNumWord16 i) -> CmmInt i W16+ (LitNumber LitNumWord32 i) -> CmmInt i W32+ (LitNumber LitNumWord64 i) -> CmmInt i W64+ (LitFloat r) -> CmmFloat r W32+ (LitDouble r) -> CmmFloat r W64+ (LitLabel fs ms fod)+ -> let -- TODO: Literal labels might not actually be in the current package...+ labelSrc = ForeignLabelInThisPackage+ in CmmLabel (mkForeignLabel fs ms labelSrc fod)+ other -> pprPanic "mkSimpleLit" (ppr other)+
compiler/GHC/StgToCmm/Monad.hs view
@@ -24,6 +24,8 @@ emitOutOfLine, emitAssign, emitStore, emitStore', emitComment, emitTick, emitUnwind, + newTemp,+ getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage, getCallOpts, getPtrOpts,@@ -478,6 +480,10 @@ let (u,us') = takeUniqFromSupply (cgs_uniqs state) setState $ state { cgs_uniqs = us' } return u++newTemp :: MonadUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- getUniqueM+ ; return (LocalReg uniq rep) } ------------------ getInfoDown :: FCode CgInfoDownwards
compiler/GHC/StgToCmm/Prim.hs view
@@ -26,7 +26,6 @@ import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Env import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.StgToCmm.Ticky
compiler/GHC/StgToCmm/Prof.hs view
@@ -36,6 +36,7 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad+import GHC.StgToCmm.Lit import GHC.Runtime.Heap.Layout import GHC.Cmm.Graph
compiler/GHC/StgToCmm/Ticky.hs view
@@ -110,6 +110,7 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall )+import GHC.StgToCmm.Lit ( newStringCLit ) import GHC.Stg.Syntax import GHC.Cmm.Expr
compiler/GHC/StgToCmm/Utils.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- --@@ -10,11 +9,10 @@ ----------------------------------------------------------------------------- module GHC.StgToCmm.Utils (- cgLit, mkSimpleLit, emitDataLits, emitRODataLits, emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,- assignTemp, newTemp,+ assignTemp, newUnboxedTupleRegs, @@ -38,7 +36,6 @@ cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl,- newStringCLit, newByteStringCLit, -- * Update remembered set operations whenUpdRemSetEnabled,@@ -55,6 +52,7 @@ import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure+import GHC.StgToCmm.Lit (mkSimpleLit) import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph@@ -74,7 +72,6 @@ import GHC.Data.Graph.Directed import GHC.Utils.Misc import GHC.Types.Unique-import GHC.Types.Unique.Supply (MonadUnique(..)) import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable@@ -83,10 +80,7 @@ import GHC.Types.CostCentre import GHC.Types.IPE -import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as M-import Data.Char import Data.List (sortBy) import Data.Ord import GHC.Types.Unique.Map@@ -98,42 +92,6 @@ import GHC.Data.Maybe import Control.Monad -------------------------------------------------------------------------------- Literals-------------------------------------------------------------------------------cgLit :: Literal -> FCode CmmLit-cgLit (LitString s) = newByteStringCLit s- -- not unpackFS; we want the UTF-8 byte stream.-cgLit other_lit = do platform <- getPlatform- return (mkSimpleLit platform other_lit)--mkSimpleLit :: Platform -> Literal -> CmmLit-mkSimpleLit platform = \case- (LitChar c) -> CmmInt (fromIntegral (ord c))- (wordWidth platform)- LitNullAddr -> zeroCLit platform- (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)- (LitNumber LitNumInt8 i) -> CmmInt i W8- (LitNumber LitNumInt16 i) -> CmmInt i W16- (LitNumber LitNumInt32 i) -> CmmInt i W32- (LitNumber LitNumInt64 i) -> CmmInt i W64- (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)- (LitNumber LitNumWord8 i) -> CmmInt i W8- (LitNumber LitNumWord16 i) -> CmmInt i W16- (LitNumber LitNumWord32 i) -> CmmInt i W32- (LitNumber LitNumWord64 i) -> CmmInt i W64- (LitFloat r) -> CmmFloat r W32- (LitDouble r) -> CmmFloat r W64- (LitLabel fs ms fod)- -> let -- TODO: Literal labels might not actually be in the current package...- labelSrc = ForeignLabelInThisPackage- in CmmLabel (mkForeignLabel fs ms labelSrc fod)- -- NB: LitRubbish should have been lowered in "CoreToStg"- other -> pprPanic "mkSimpleLit" (ppr other)- -------------------------------------------------------------------------- -- -- Incrementing a memory location@@ -307,18 +265,6 @@ emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) -newStringCLit :: String -> FCode CmmLit--- Make a global definition for the string,--- and return its label-newStringCLit str = newByteStringCLit (BS8.pack str)--newByteStringCLit :: ByteString -> FCode CmmLit-newByteStringCLit bytes- = do { uniq <- newUnique- ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes- ; emitDecl decl- ; return lit }- ------------------------------------------------------------------------- -- -- Assigning expressions to temporaries@@ -339,10 +285,6 @@ ; emitAssign (CmmLocal reg) e ; return reg } -newTemp :: MonadUnique m => CmmType -> m LocalReg-newTemp rep = do { uniq <- getUniqueM- ; return (LocalReg uniq rep) }- newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components -- of an unboxed tuple that we are about to return to@@ -608,7 +550,6 @@ let reg = CmmLocal lreg emitAssign reg e return (CmmReg reg)- --------------------------------------------------------------------------- -- Pushing to the update remembered set
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 9.2.4.20220729+version: 9.2.5.20221107 license: BSD3 license-file: LICENSE category: Development@@ -79,7 +79,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 9.2.4.20220729+ ghc-lib-parser == 9.2.5.20221107 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns@@ -687,6 +687,7 @@ GHC.StgToCmm.Heap GHC.StgToCmm.Hpc GHC.StgToCmm.Layout+ GHC.StgToCmm.Lit GHC.StgToCmm.Monad GHC.StgToCmm.Prim GHC.StgToCmm.Prof
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