diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -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 diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -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 diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -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 diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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'@. diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -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 ************************************************************************ * * diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -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 _ _ -> -Then f gets a strictness sig of . We make worker $wf thus: -$wf :: [Int] -> blah -$wf xs = case ps of MkT 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 -> -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 . 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 _ _ -> + 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" diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -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] diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -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) diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -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] diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -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 ) } ------------------------------------------------------------------------ diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -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) = diff --git a/compiler/GHC/StgToCmm/Expr.hs-boot b/compiler/GHC/StgToCmm/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/StgToCmm/Expr.hs-boot @@ -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 diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -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 ) } ------------------------------------------------------------------------- -- diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/StgToCmm/Lit.hs @@ -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) + diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -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