diff --git a/GHC/Builtin/Types/Prim.hs b/GHC/Builtin/Types/Prim.hs --- a/GHC/Builtin/Types/Prim.hs +++ b/GHC/Builtin/Types/Prim.hs @@ -35,7 +35,7 @@ tYPETyCon, tYPETyConName, -- Kinds - tYPE, primRepToRuntimeRep, + tYPE, primRepToRuntimeRep, primRepsToRuntimeRep, functionWithMultiplicity, funTyCon, funTyConName, @@ -587,7 +587,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 @@ -625,6 +625,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 diff --git a/GHC/Cmm/LayoutStack.hs b/GHC/Cmm/LayoutStack.hs --- a/GHC/Cmm/LayoutStack.hs +++ b/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/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs --- a/GHC/Cmm/Lint.hs +++ b/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/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs --- a/GHC/Cmm/MachOp.hs +++ b/GHC/Cmm/MachOp.hs @@ -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] diff --git a/GHC/Cmm/Parser.y b/GHC/Cmm/Parser.y --- a/GHC/Cmm/Parser.y +++ b/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/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs --- a/GHC/Cmm/Utils.hs +++ b/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/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/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/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -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. diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs --- a/GHC/Core/Make.hs +++ b/GHC/Core/Make.hs @@ -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] diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -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 ; 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 diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs --- a/GHC/Core/Opt/Simplify.hs +++ b/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/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/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/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs --- a/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/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/GHC/Core/TyCon.hs b/GHC/Core/TyCon.hs --- a/GHC/Core/TyCon.hs +++ b/GHC/Core/TyCon.hs @@ -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 - {- ************************************************************************ diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -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 diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs --- a/GHC/CoreToStg.hs +++ b/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/GHC/Iface/Ext/Types.hs b/GHC/Iface/Ext/Types.hs --- a/GHC/Iface/Ext/Types.hs +++ b/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/GHC/Settings/Config.hs b/GHC/Settings/Config.hs --- a/GHC/Settings/Config.hs +++ b/GHC/Settings/Config.hs @@ -22,7 +22,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "9.2.3" +cBooterVersion = "9.2.4" cStage :: String cStage = show (2 :: Int) diff --git a/GHC/Stg/Unarise.hs b/GHC/Stg/Unarise.hs --- a/GHC/Stg/Unarise.hs +++ b/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/GHC/StgToCmm/ArgRep.hs b/GHC/StgToCmm/ArgRep.hs --- a/GHC/StgToCmm/ArgRep.hs +++ b/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/GHC/StgToCmm/Env.hs b/GHC/StgToCmm/Env.hs --- a/GHC/StgToCmm/Env.hs +++ b/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/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/GHC/StgToCmm/Expr.hs @@ -10,7 +10,7 @@ -- ----------------------------------------------------------------------------- -module GHC.StgToCmm.Expr ( cgExpr ) where +module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where #include "HsVersions.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/GHC/StgToCmm/Expr.hs-boot b/GHC/StgToCmm/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/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/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/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/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/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/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs --- a/GHC/StgToCmm/Layout.hs +++ b/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/GHC/StgToCmm/Lit.hs b/GHC/StgToCmm/Lit.hs new file mode 100644 --- /dev/null +++ b/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 "HsVersions.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/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/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/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/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/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs --- a/GHC/StgToCmm/Prof.hs +++ b/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/GHC/StgToCmm/Ticky.hs b/GHC/StgToCmm/Ticky.hs --- a/GHC/StgToCmm/Ticky.hs +++ b/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/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/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/Types/Literal.hs b/GHC/Types/Literal.hs --- a/GHC/Types/Literal.hs +++ b/GHC/Types/Literal.hs @@ -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 "HsVersions.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 = - 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 ? -* For lifted values 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. + -} diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs --- a/GHC/Types/RepType.hs +++ b/GHC/Types/RepType.hs @@ -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] diff --git a/GHC/Types/SrcLoc.hs b/GHC/Types/SrcLoc.hs --- a/GHC/Types/SrcLoc.hs +++ b/GHC/Types/SrcLoc.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Utils/Binary.hs b/GHC/Utils/Binary.hs --- a/GHC/Utils/Binary.hs +++ b/GHC/Utils/Binary.hs @@ -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) diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs --- a/GHC/Utils/Misc.hs +++ b/GHC/Utils/Misc.hs @@ -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} diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ Cabal-Version: 1.22 Name: ghc -Version: 9.2.4 +Version: 9.2.5 License: BSD3 License-File: LICENSE Author: The GHC Team @@ -71,9 +71,9 @@ hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*, - ghc-boot == 9.2.4, - ghc-heap == 9.2.4, - ghci == 9.2.4 + ghc-boot == 9.2.5, + ghc-heap == 9.2.5, + ghci == 9.2.5 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13 @@ -556,6 +556,7 @@ GHC.StgToCmm.Heap GHC.StgToCmm.Hpc GHC.StgToCmm.Layout + GHC.StgToCmm.Lit GHC.StgToCmm.Monad GHC.StgToCmm.Prim GHC.StgToCmm.Prof