ghc-lib 9.4.2.20220822 → 9.4.3.20221104
raw patch · 22 files changed
+569/−405 lines, 22 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC/Cmm/Parser.y +9/−4
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +20/−12
- compiler/GHC/CmmToLlvm/Base.hs +16/−4
- compiler/GHC/Core/Opt/CprAnal.hs +7/−6
- compiler/GHC/Core/Opt/Simplify.hs +43/−14
- compiler/GHC/Core/Opt/Simplify/Env.hs +25/−25
- compiler/GHC/Core/Opt/Simplify/Utils.hs +3/−4
- compiler/GHC/Core/Opt/SpecConstr.hs +31/−14
- compiler/GHC/CoreToStg/Prep.hs +81/−10
- compiler/GHC/Data/Graph/UnVar.hs +0/−181
- compiler/GHC/Driver/CodeOutput.hs +8/−17
- compiler/GHC/Driver/Main.hs +6/−5
- compiler/GHC/Hs/Syn/Type.hs +3/−3
- compiler/GHC/Iface/Ext/Ast.hs +5/−2
- compiler/GHC/Iface/Ext/Types.hs +2/−2
- compiler/GHC/Iface/Tidy.hs +83/−40
- compiler/GHC/StgToCmm/InfoTableProv.hs +131/−0
- compiler/GHC/StgToCmm/Prof.hs +11/−38
- compiler/GHC/Tc/Deriv/Functor.hs +30/−2
- compiler/GHC/Tc/Deriv/Generics.hs +18/−3
- compiler/GHC/Tc/Deriv/Infer.hs +33/−16
- ghc-lib.cabal +4/−3
compiler/GHC/Cmm/Parser.y view
@@ -229,6 +229,7 @@ import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )+import GHC.StgToCmm.InfoTableProv import GHC.Cmm.Opt import GHC.Cmm.Graph@@ -1519,14 +1520,18 @@ POk pst code -> do st <- initC let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)+ let config = initStgToCmmConfig dflags no_module let fcode = do ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)- let used_info = map (cmmInfoTableToInfoProvEnt this_mod)- (mapMaybe topInfoTable cmm)- ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info+ let used_info+ | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)+ | otherwise = []+ where+ do_ipe = stgToCmmInfoTableMap config+ ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info return (cmm ++ cmm2, used_info)- (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode+ (cmm, _) = runC config fstate st fcode (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing)
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -662,10 +662,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 =@@ -815,15 +816,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@@ -1019,16 +1022,21 @@ -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) signExtendReg w w' r = case w of- W64 -> nilOL+ W64 -> noop W32- | w' == W32 -> nilOL- | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W16 -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W8 -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+ | w' == W32 -> noop+ | otherwise -> extend SXTH+ W16 -> extend SXTH+ W8 -> extend SXTB _ -> panic "intOp"+ where+ noop = return (r, nilOL)+ extend instr = do+ r' <- getNewRegNat II64+ return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) -- | Instructions to truncate the value in the given register from width @w@ -- down to width @w'@.
compiler/GHC/CmmToLlvm/Base.hs view
@@ -67,7 +67,7 @@ import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit)-import Data.List (sortBy, groupBy, intercalate)+import Data.List (sortBy, groupBy, intercalate, isPrefixOf) import Data.Ord (comparing) import qualified Data.List.NonEmpty as NE @@ -550,6 +550,12 @@ modifyEnv $ \env -> env { envAliases = emptyUniqSet } return (concat defss, []) +-- | Is a variable one of the special @$llvm@ globals?+isBuiltinLlvmVar :: LlvmVar -> Bool+isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =+ "$llvm" `isPrefixOf` unpackFS lbl+isBuiltinLlvmVar _ = False+ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]@@ -557,8 +563,9 @@ -- Here we obtain the indirectee's precise type and introduce -- fresh aliases to both the precise typed label (lbl$def) and the i8* -- typed (regular) label of it with the matching new names.-aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)- (Just orig)) = do+aliasify (LMGlobal var@(LMGlobalVar lbl ty@LMAlias{} link sect align Alias)+ (Just orig))+ | not $ isBuiltinLlvmVar var = do let defLbl = llvmDefLabel lbl LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig defOrigLbl = llvmDefLabel origLbl@@ -571,7 +578,8 @@ pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') ]-aliasify (LMGlobal var val) = do+aliasify (LMGlobal var val)+ | not $ isBuiltinLlvmVar var = do let LMGlobalVar lbl ty link sect align const = var defLbl = llvmDefLabel lbl@@ -589,6 +597,7 @@ return [ LMGlobal defVar val , LMGlobal aliasVar (Just aliasVal) ]+aliasify global = pure [global] -- Note [Llvm Forward References] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -647,3 +656,6 @@ -- away with casting the alias to the desired type in @getSymbolPtr@ -- and instead just emit a reference to the definition symbol directly. -- This is the @Just@ case in @getSymbolPtr@.+--+-- Note that we must take care not to turn LLVM's builtin variables into+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -398,8 +398,10 @@ where init_sig id -- See Note [CPR for data structures]- | isDataStructure id = topCprSig- | otherwise = mkCprSig 0 botCpr+ -- Don't set the sig to bottom in this case, because cprAnalBind won't+ -- update it to something reasonable. Result: Assertion error in WW+ | isDataStructure id || isDFunId id = topCprSig+ | otherwise = mkCprSig 0 botCpr -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal orig_virgin = ae_virgin orig_env init_pairs | orig_virgin = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]@@ -464,10 +466,10 @@ | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs. = (id, rhs, extendSigEnv env id topCprSig) -- See Note [CPR for data structures]- | isDataStructure id- = (id, rhs, env) -- Data structure => no code => no need to analyse rhs+ | isDataStructure id -- Data structure => no code => no need to analyse rhs+ = (id, rhs, env) | otherwise- = (id', rhs', env')+ = (id `setIdCprSig` sig', rhs', env') where (rhs_ty, rhs') = cprAnal env rhs -- possibly trim thunk CPR info@@ -481,7 +483,6 @@ -- See Note [The OPAQUE pragma and avoiding the reboxing of results] sig' | isOpaquePragma (idInlinePragma id) = topCprSig | otherwise = sig- id' = setIdCprSig id sig' env' = extendSigEnv env id sig' -- See Note [CPR for thunks]
compiler/GHC/Core/Opt/Simplify.hs view
@@ -64,6 +64,7 @@ import GHC.Data.Maybe ( isNothing, orElse ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName, pprModuleName )+import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -256,9 +257,11 @@ -> [(InId, InExpr)] -> SimplM (SimplFloats, SimplEnv) simplRecBind env0 bind_cxt pairs0- = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0- ; (rec_floats, env1) <- go env_with_info triples- ; return (mkRecFloats rec_floats, env1) }+ = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0+ ; let new_bndrs = map sndOf3 triples+ ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+ go env triples+ ; return (mkRecFloats rec_floats, env2) } where add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) -- Add the (substituted) rules to the binder@@ -2141,19 +2144,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') } @@ -2260,6 +2276,19 @@ discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! +Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda. Why not? Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ * *
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -17,7 +17,7 @@ zapSubstEnv, setSubstEnv, bumpCaseDepth, getInScope, setInScopeFromE, setInScopeFromF, setInScopeSet, modifyInScope, addNewInScopeIds,- getSimplRules,+ getSimplRules, enterRecGroupRHSs, -- * Substitution results SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,@@ -55,6 +55,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Data.OrdList+import GHC.Data.Graph.UnVar import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags )@@ -96,6 +97,10 @@ , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + -- | Fast OutVarSet tracking which recursive RHSs we are analysing.+ -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.+ , seRecIds :: !UnVarSet+ ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where -- the expression finally ends up@@ -286,6 +291,7 @@ , seTvSubst = emptyVarEnv , seCvSubst = emptyVarEnv , seIdSubst = emptyVarEnv+ , seRecIds = emptyUnVarSet , seCaseDepth = 0 } -- The top level "enclosing CC" is "SUBSUMED". @@ -391,6 +397,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v = env {seInScope = extendInScopeSet in_scope v} +enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))+ -> SimplM (r, SimplEnv)+enterRecGroupRHSs env bndrs k = do+ --pprTraceM "enterRecGroupRHSs" (ppr bndrs)+ (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}+ return (r, env''{seRecIds = seRecIds env})+ {- Note [Setting the right in-scope set] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -886,31 +899,18 @@ Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~ We *do* transfer the arity from the in_id of a let binding to the-out_id. This is important, so that the arity of an Id is visible in-its own RHS. For example:- f = \x. ....g (\y. f y)....-We can eta-reduce the arg to g, because f is a value. But that-needs to be visible.--This interacts with the 'state hack' too:- f :: Bool -> IO Int- f = \x. case x of- True -> f y- False -> \s -> ...-Can we eta-expand f? Only if we see that f has arity 1, and then we-take advantage of the 'state hack' on the result of-(f y) :: State# -> (State#, Int) to expand the arity one more.--There is a disadvantage though. Making the arity visible in the RHS-allows us to eta-reduce- f = \x -> f x-to- f = f-which technically is not sound. This is very much a corner case, so-I'm not worried about it. Another idea is to ensure that f's arity-never decreases; its arity started as 1, and we should never eta-reduce-below that.+out_id so that its arity is visible in its RHS. Examples: + * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)+ Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a+ hard time figuring that out when `f` only has arity 0 in its own RHS.+ * f = \x y. ....(f `seq` blah)....+ We want to drop the seq.+ * f = \x. g (\y. f y)+ You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.+ Unfortunately, it is not sound in general to eta-reduce in f's RHS.+ Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how+ we prevent that. Note [Robust OccInfo] ~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -1610,6 +1610,7 @@ ; mkLam' dflags bndrs body } where mode = getMode env+ rec_ids = seRecIds env mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam' dflags bndrs body@(Lam {})@@ -1633,7 +1634,7 @@ mkLam' dflags bndrs body | gopt Opt_DoEtaReduction dflags- , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body+ , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } @@ -1731,9 +1732,7 @@ tryEtaExpandRhs env bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs- oss = [idOneShotInfo id | id <- join_bndrs, isId id]- arity_type | exprIsDeadEnd join_body = mkBotArityType oss- | otherwise = mkTopArityType oss+ arity_type = mkManifestArityType join_bndrs join_body ; return (arity_type, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -1732,14 +1732,6 @@ -- changes (#4012). rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) spec_name = mkInternalName spec_uniq spec_occ fn_loc--- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)--- , text "sc_count:" <+> ppr (sc_count env)--- , text "pats:" <+> ppr pats--- , text "-->" <+> ppr spec_name--- , text "bndrs" <+> ppr arg_bndrs--- , text "body" <+> ppr body--- , text "how_bound" <+> ppr (sc_how_bound env) ]) $--- return () -- Specialise the body -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)@@ -1754,9 +1746,10 @@ = calcSpecInfo fn call_pat extra_bndrs -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders])-+ add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1 (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)- | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+ | add_void_arg+ -- See Note [SpecConst needs to add void args first] , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 [] -- needsVoidWorkerArg: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args.@@ -1777,13 +1770,32 @@ -- Conditionally use result of new worker-wrapper transform spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)- rule_rhs = mkVarApps (Var spec_id) $- dropTail (length extra_bndrs) spec_call_args+ rule_rhs = mkVarApps (Var spec_id) $+ -- This will give us all the arguments we quantify over+ -- in the rule plus the void argument if present+ -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`+ dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn this_mod = sc_module env rule = mkRule this_mod True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation]++ -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+ -- , text "sc_count:" <+> ppr (sc_count env)+ -- , text "pats:" <+> ppr pats+ -- , text "call_pat:" <+> ppr call_pat+ -- , text "-->" <+> ppr spec_name+ -- , text "bndrs" <+> ppr arg_bndrs+ -- , text "extra_bndrs" <+> ppr extra_bndrs+ -- , text "spec_lam_args" <+> ppr spec_lam_args+ -- , text "spec_call_args" <+> ppr spec_call_args+ -- , text "rule_rhs" <+> ppr rule_rhs+ -- , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg+ -- , text "body" <+> ppr body+ -- , text "spec_rhs" <+> ppr spec_rhs+ -- , text "how_bound" <+> ppr (sc_how_bound env) ]) $+ -- return () ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id , os_rhs = spec_rhs }) }@@ -2262,9 +2274,14 @@ "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ if interesting && isEmptyVarSet bad_covars- then+ then do -- pprTraceM "callToPatsOut" (- -- text "fun" <> ppr fn $$+ -- text "fn:" <+> ppr fn $$+ -- text "args:" <+> ppr args $$+ -- text "in_scope:" <+> ppr in_scope $$+ -- -- text "in_scope:" <+> ppr in_scope $$+ -- text "pat_fvs:" <+> ppr pat_fvs+ -- ) -- ppr (CP { cp_qvars = qvars', cp_args = pats })) >> return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids })) else return Nothing }
compiler/GHC/CoreToStg/Prep.hs view
@@ -49,6 +49,7 @@ import GHC.Data.OrdList import GHC.Data.FastString import GHC.Data.Pair+import GHC.Data.Graph.UnVar import GHC.Utils.Error import GHC.Utils.Misc@@ -594,7 +595,7 @@ | otherwise = addFloat floats new_float - new_float = mkFloat dmd is_unlifted bndr1 rhs1+ new_float = mkFloat env dmd is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -608,24 +609,27 @@ cpeBind top_lvl env (Rec pairs) | not (isJoinId (head bndrs))- = do { (env', bndrs1) <- cpCloneBndrs env bndrs+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs+ ; let env' = enterRecGroupRHSs env bndrs1 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss ; let (floats_s, rhss1) = unzip stuff all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (concatFloats floats_s)-+ -- use env below, so that we reset cpe_rec_ids ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), unitFloat (FloatLet (Rec all_pairs)), Nothing) } | otherwise -- See Note [Join points and floating]- = do { (env', bndrs1) <- cpCloneBndrs env bndrs+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs+ ; let env' = enterRecGroupRHSs env bndrs1 ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss ; let bndrs2 = map fst pairs1- ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+ -- use env below, so that we reset cpe_rec_ids+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), emptyFloats, Just (Rec pairs1)) } where@@ -657,7 +661,7 @@ else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr)- ; let float = mkFloat topDmd False v rhs2+ ; let float = mkFloat env topDmd False v rhs2 ; return ( addFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -1464,7 +1468,7 @@ ; if okCpeArg arg2 then do { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2- arg_float = mkFloat dmd is_unlifted v arg3+ arg_float = mkFloat env dmd is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } else return (floats2, arg2) }@@ -1669,6 +1673,66 @@ long as the callee might evaluate it. And if it is evaluated on most code paths anyway, we get to turn the unknown eval in the callee into a known call at the call site.++However, we must be very careful not to speculate recursive calls!+Doing so might well change termination behavior.++That comes up in practice for DFuns, which are considered ok-for-spec,+because they always immediately return a constructor.+Not so if you speculate the recursive call, as #20836 shows:++ class Foo m => Foo m where+ runFoo :: m a -> m a+ newtype Trans m a = Trans { runTrans :: m a }+ instance Monad m => Foo (Trans m) where+ runFoo = id++(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The+example in #20836 is more compelling, but boils down to the same thing.)+This program compiles to the following DFun for the `Trans` instance:++ Rec {+ $fFooTrans+ = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)+ end Rec }++Note that the DFun immediately terminates and produces a dictionary, just+like DFuns ought to, but it calls itself recursively to produce the `Foo m`+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so+that we can speculate its calls, and hence use call-by-value, we get:++ $fFooTrans+ = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->+ C:Foo sc (\ @a -> id)++and that's an infinite loop!+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the+*body* of the letrec, it's absolutely fine to use call-by-value on+`foo ($fFooTrans d)`.++Our solution is this: we track in cpe_rec_ids the set of enclosing+recursively-bound Ids, the RHSs of which we are currently transforming and then+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',+basically) we'll say that any binder in this set is not ok-for-spec.++Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we+prep up `rhs1`, we have to include not only `f1`, but all binders of the group+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive+DFuns.++NB: If at some point we decide to have a termination analysis for general+functions (#8655, !1866), we need to take similar precautions for (guarded)+recursive functions:++ repeat x = x : repeat x++Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.+Fortunately, pce_rec_ids already has all the information we need in that case.++The problem is very similar to Note [Eta reduction in recursive RHSs].+Here as well as there it is *unsound* to change the termination properties+of the very function whose termination properties we are exploiting. -} data FloatingBind@@ -1715,8 +1779,8 @@ -- ok-to-speculate unlifted bindings | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind-mkFloat dmd is_unlifted bndr rhs+mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat env dmd is_unlifted bndr rhs | is_strict || ok_for_spec -- See Note [Speculative evaluation] , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec -- Don't make a case for a HNF binding, even if it's strict@@ -1743,7 +1807,8 @@ where is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd- ok_for_spec = exprOkForSpeculation rhs+ ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs+ is_rec_call = (`elemUnVarSet` cpe_rec_ids env) emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL@@ -1941,6 +2006,7 @@ , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr -- ^ Convert some numeric literals (Integer, Natural) into their -- final Core form+ , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] } mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv@@ -1951,6 +2017,7 @@ , cpe_env = emptyVarEnv , cpe_tyco_env = Nothing , cpe_convertNumLit = convertNumLit+ , cpe_rec_ids = emptyUnVarSet } extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv@@ -1971,6 +2038,10 @@ = case lookupVarEnv (cpe_env cpe) id of Nothing -> Var id Just exp -> exp++enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv+enterRecGroupRHSs env grp+ = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } ------------------------------------------------------------------------------ -- CpeTyCoEnv
− compiler/GHC/Data/Graph/UnVar.hs
@@ -1,181 +0,0 @@-{---Copyright (c) 2014 Joachim Breitner--A data structure for undirected graphs of variables-(or in plain terms: Sets of unordered pairs of numbers)---This is very specifically tailored for the use in CallArity. In particular it-stores the graph as a union of complete and complete bipartite graph, which-would be very expensive to store as sets of edges or as adjanceny lists.--It does not normalize the graphs. This means that g `unionUnVarGraph` g is-equal to g, but twice as expensive and large.---}-module GHC.Data.Graph.UnVar- ( UnVarSet- , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets- , extendUnVarSet, delUnVarSet- , elemUnVarSet, isEmptyUnVarSet- , UnVarGraph- , emptyUnVarGraph- , unionUnVarGraph, unionUnVarGraphs- , completeGraph, completeBipartiteGraph- , neighbors- , hasLoopAt- , delNode- ) where--import GHC.Prelude--import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.FM-import GHC.Utils.Outputable-import GHC.Types.Unique--import qualified Data.IntSet as S---- We need a type for sets of variables (UnVarSet).--- We do not use VarSet, because for that we need to have the actual variable--- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.--- Therefore, use a IntSet directly (which is likely also a bit more efficient).---- Set of uniques, i.e. for adjancet nodes-newtype UnVarSet = UnVarSet (S.IntSet)- deriving Eq--k :: Var -> Int-k v = getKey (getUnique v)--emptyUnVarSet :: UnVarSet-emptyUnVarSet = UnVarSet S.empty--elemUnVarSet :: Var -> UnVarSet -> Bool-elemUnVarSet v (UnVarSet s) = k v `S.member` s---isEmptyUnVarSet :: UnVarSet -> Bool-isEmptyUnVarSet (UnVarSet s) = S.null s--delUnVarSet :: UnVarSet -> Var -> UnVarSet-delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s--minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet-minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'--sizeUnVarSet :: UnVarSet -> Int-sizeUnVarSet (UnVarSet s) = S.size s--mkUnVarSet :: [Var] -> UnVarSet-mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs--varEnvDom :: VarEnv a -> UnVarSet-varEnvDom ae = UnVarSet $ ufmToSet_Directly ae--extendUnVarSet :: Var -> UnVarSet -> UnVarSet-extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s--unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet-unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)--unionUnVarSets :: [UnVarSet] -> UnVarSet-unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet--instance Outputable UnVarSet where- ppr (UnVarSet s) = braces $- hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]--data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph- | CG !UnVarSet -- ^ complete graph- | Union UnVarGraph UnVarGraph- | Del !UnVarSet UnVarGraph--emptyUnVarGraph :: UnVarGraph-emptyUnVarGraph = CG emptyUnVarSet--unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph-{--Premature optimisation, it seems.-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])- | s1 == s3 && s2 == s4- = pprTrace "unionUnVarGraph fired" empty $- completeGraph (s1 `unionUnVarSet` s2)-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])- | s2 == s3 && s1 == s4- = pprTrace "unionUnVarGraph fired2" empty $- completeGraph (s1 `unionUnVarSet` s2)--}-unionUnVarGraph a b- | is_null a = b- | is_null b = a- | otherwise = Union a b--unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph-unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph---- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }-completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph-completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2--completeGraph :: UnVarSet -> UnVarGraph-completeGraph s = prune $ CG s---- (v' ∈ neighbors G v) <=> v--v' ∈ G-neighbors :: UnVarGraph -> Var -> UnVarSet-neighbors = go- where- go (Del d g) v- | v `elemUnVarSet` d = emptyUnVarSet- | otherwise = go g v `minusUnVarSet` d- go (Union g1 g2) v = go g1 v `unionUnVarSet` go g2 v- go (CG s) v = if v `elemUnVarSet` s then s else emptyUnVarSet- go (CBPG s1 s2) v = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`- (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)---- hasLoopAt G v <=> v--v ∈ G-hasLoopAt :: UnVarGraph -> Var -> Bool-hasLoopAt = go- where- go (Del d g) v- | v `elemUnVarSet` d = False- | otherwise = go g v- go (Union g1 g2) v = go g1 v || go g2 v- go (CG s) v = v `elemUnVarSet` s- go (CBPG s1 s2) v = v `elemUnVarSet` s1 && v `elemUnVarSet` s2--delNode :: UnVarGraph -> Var -> UnVarGraph-delNode (Del d g) v = Del (extendUnVarSet v d) g-delNode g v- | is_null g = emptyUnVarGraph- | otherwise = Del (mkUnVarSet [v]) g---- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`-prune :: UnVarGraph -> UnVarGraph-prune = go emptyUnVarSet- where- go :: UnVarSet -> UnVarGraph -> UnVarGraph- go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g- go dels (Union g1 g2)- | is_null g1' = g2'- | is_null g2' = g1'- | otherwise = Union g1' g2'- where- g1' = go dels g1- g2' = go dels g2- go dels (CG s) = CG (s `minusUnVarSet` dels)- go dels (CBPG s1 s2) = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)---- | Shallow empty check.-is_null :: UnVarGraph -> Bool-is_null (CBPG s1 s2) = isEmptyUnVarSet s1 || isEmptyUnVarSet s2-is_null (CG s) = isEmptyUnVarSet s-is_null _ = False--instance Outputable UnVarGraph where- ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)- ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)- ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)- ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)
compiler/GHC/Driver/CodeOutput.hs view
@@ -370,26 +370,17 @@ :: Bool -- is Opt_InfoTableMap enabled or not -> Platform -> Module- -> [InfoProvEnt] -> CStub-ipInitCode do_info_table platform this_mod ents+ipInitCode do_info_table platform this_mod | not do_info_table = mempty- | otherwise = initializerCStub platform fn_nm decls body+ | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body where fn_nm = mkInitializerStubLabel this_mod "ip_init"- decls = vcat- $ map emit_ipe_decl ents- ++ [emit_ipe_list ents]- body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi- emit_ipe_decl ipe =- text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"- where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)- local_ipe_list_label = text "local_ipe_" <> ppr this_mod- emit_ipe_list ipes =- text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="- <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma- | ipe <- ipes- ] ++ [text "NULL"])- <> semi + body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi++ ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)++ ipe_buffer_decl =+ text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
compiler/GHC/Driver/Main.hs view
@@ -1770,7 +1770,7 @@ -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ original_filename cmm_mod = mkHomeModule home_unit mod_name- (cmm, ents) <- ioMsgMaybe+ (cmm, ipe_ents) <- ioMsgMaybe $ do (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename@@ -1796,10 +1796,11 @@ Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) Just h -> h dflags Nothing (Stream.yield cmmgroup) - let foreign_stubs _ =- let ip_init = ipInitCode do_info_table platform cmm_mod ents- in NoStubs `appendStubC` ip_init-+ let foreign_stubs _+ | not $ null ipe_ents =+ let ip_init = ipInitCode do_info_table platform cmm_mod+ in NoStubs `appendStubC` ip_init+ | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty rawCmms
compiler/GHC/Hs/Syn/Type.hs view
@@ -133,9 +133,9 @@ hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE" (ppr e)- -- Typed splices should have been eliminated during zonking, but we- -- can't use `dataConCantHappen` since they are still present before- -- than in the typechecked AST.+ -- Typed splices should have been eliminated during zonking, but we+ -- can't use `dataConCantHappen` since they are still present before+ -- than in the typechecked AST hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e
compiler/GHC/Iface/Ext/Ast.hs view
@@ -744,6 +744,9 @@ RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e+ -- By this point all splices are lifted into splice environments so+ -- the remaining HsSpliceE in the syntax tree contain bogus information.+ HsSpliceE {} -> Nothing XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e XExpr (HsTick _ e) -> computeLType e@@ -1873,10 +1876,10 @@ toHie _ = pure [] instance ToHie PendingRnSplice where- toHie _ = pure []+ toHie (PendingRnSplice _ _ e) = toHie e instance ToHie PendingTcSplice where- toHie _ = pure []+ toHie (PendingTcSplice _ e) = toHie e instance ToHie (LBooleanFormula (LocatedN Name)) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of
compiler/GHC/Iface/Ext/Types.hs view
@@ -781,5 +781,5 @@ | isKnownKeyName name = KnownKeyName (nameUnique name) | isExternalName name = ExternalName (nameModule name) (nameOccName name)- (nameSrcSpan name)- | otherwise = LocalName (nameOccName name) (nameSrcSpan name)+ (removeBufSpan $ nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
compiler/GHC/Iface/Tidy.hs view
@@ -24,13 +24,12 @@ import GHC.Core import GHC.Core.Unfold-import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq (seqBinds)-import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe )+import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe, typeArity ) import GHC.Core.InstEnv-import GHC.Core.Type ( tidyTopType )+import GHC.Core.Type ( tidyTopType, Type ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class@@ -74,6 +73,7 @@ import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S import GHC.Types.CostCentre+import GHC.Core.Opt.OccurAnal (occurAnalyseExpr) {- Constructing the TypeEnv, Instances, Rules from which the@@ -384,8 +384,7 @@ (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env - let uf_opts = opt_unfolding_opts opts- (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds+ (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of@@ -1146,60 +1145,49 @@ -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyTopBinds :: UnfoldingOpts- -> UnfoldEnv+tidyTopBinds :: UnfoldEnv -> NameSet -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds+tidyTopBinds unfold_env boot_exports init_occ_env binds = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where init_env = (init_occ_env, emptyVarEnv) - tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)+ tidy = mapAccumL (tidyTopBind unfold_env boot_exports) -------------------------tidyTopBind :: UnfoldingOpts- -> UnfoldEnv+tidyTopBind :: UnfoldEnv -> NameSet -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind uf_opts unfold_env boot_exports+tidyTopBind unfold_env boot_exports (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where- Just (name',show_unfold) = lookupVarEnv unfold_env bndr- (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)+ (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)+tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where- prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)- | (id,rhs) <- prs,- let (name',show_unfold) =- expectJust "tidyTopBind" $ lookupVarEnv unfold_env id- ]-- subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')+ prs' = map (tidyTopPair unfold_env boot_exports tidy_env2) prs+ subst2 = extendVarEnvList subst1 (map fst prs `zip` map fst prs') tidy_env2 = (occ_env, subst2)-- bndrs = map fst prs+ -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair ------------------------------------------------------------tidyTopPair :: UnfoldingOpts- -> Bool -- show unfolding+tidyTopPair :: UnfoldEnv -> NameSet -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it!- -> Name -- New name -> (Id, CoreExpr) -- Binder and RHS before tidying -> (Id, CoreExpr) -- This function is the heart of Step 2@@ -1208,18 +1196,19 @@ -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)+tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs) = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $ (bndr1, rhs1) where+ Just (name',show_unfold) = lookupVarEnv unfold_env bndr !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails cbv_bndr -- Preserve the IdDetails ty' = tidyTopType (idType cbv_bndr) rhs1 = tidyExpr rhs_tidy_env rhs- idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)- show_unfold+ idinfo' = tidyTopIdInfo rhs_tidy_env name' ty'+ rhs rhs1 (idInfo cbv_bndr) show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. The delicate piece:@@ -1228,9 +1217,9 @@ -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. ---tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr+tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold+tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough;@@ -1281,13 +1270,17 @@ --------- Unfolding ------------ unf_info = realUnfoldingInfo idinfo- unfold_info- | isCompulsoryUnfolding unf_info || show_unfold- = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs- | otherwise- = minimal_unfold_info- minimal_unfold_info = trimUnfolding unf_info- unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs+ !minimal_unfold_info = trimUnfolding unf_info++ !unfold_info | isCompulsoryUnfolding unf_info || show_unfold+ = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info+ | otherwise+ = minimal_unfold_info++ -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding+ -- else you get a black hole (#22122). Reason: mkFinalUnfolding+ -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)+ -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that@@ -1311,4 +1304,54 @@ -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here.- arity = exprArity orig_rhs+ arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty)+++------------ Unfolding --------------+tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding+tidyTopUnfolding _ _ NoUnfolding = NoUnfolding+tidyTopUnfolding _ _ BootUnfolding = BootUnfolding+tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding++tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+ = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }+ where+ (tidy_env', bndrs') = tidyBndrs tidy_env bndrs++tidyTopUnfolding tidy_env tidy_rhs+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+ = -- See Note [tidyTopUnfolding: avoiding black holes]+ unf { uf_tmpl = tidy_unf_rhs }+ where+ tidy_unf_rhs | isStableSource src+ = tidyExpr tidy_env unf_rhs -- Preserves OccInfo in unf_rhs+ | otherwise+ = occurAnalyseExpr tidy_rhs -- Do occ-anal++{- Note [tidyTopUnfolding: avoiding black holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are exposing all unfoldings we don't want to tidy the unfolding+twice -- we just want to use the tidied RHS. That tidied RHS itself+contains fully-tidied Ids -- it is knot-tied. So the uf_tmpl for the+unfolding contains stuff we can't look at. Now consider (#22112)+ foo = foo+If we freshly compute the uf_is_value field for foo's unfolding,+we'll call `exprIsValue`, which will look at foo's unfolding!+Whether or not the RHS is a value depends on whether foo is a value...+black hole.++In the Simplifier we deal with this by not giving `foo` an unfolding+in its own RHS. And we could do that here. But it's qite nice+to common everything up to a single Id for foo, used everywhere.++And it's not too hard: simply leave the unfolding undisturbed, except+tidy the uf_tmpl field. Hence tidyTopUnfolding does+ unf { uf_tmpl = tidy_unf_rhs }++Don't mess with uf_is_value, or guidance; in particular don't recompute+them from tidy_unf_rhs.++And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,+because that'll cause a black hole (I /think/ because occurAnalyseExpr+looks in IdInfo).+-}
+ compiler/GHC/StgToCmm/InfoTableProv.hs view
@@ -0,0 +1,131 @@+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where++import GHC.Prelude+import GHC.Platform+import GHC.Unit.Module+import GHC.Utils.Outputable++import GHC.Cmm.CLabel+import GHC.Cmm.Expr+import GHC.Cmm.Utils+import GHC.StgToCmm.Config+import GHC.StgToCmm.Lit (newByteStringCLit)+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils++import GHC.Data.ShortText (ShortText)+import qualified GHC.Data.ShortText as ST++import Data.Bifunctor (first)+import qualified Data.Map.Strict as M+import Control.Monad.Trans.State.Strict+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL++emitIpeBufferListNode :: Module+ -> [InfoProvEnt]+ -> FCode ()+emitIpeBufferListNode _ [] = return ()+emitIpeBufferListNode this_mod ents = do+ cfg <- getStgToCmmConfig+ let ctx = stgToCmmContext cfg+ platform = stgToCmmPlatform cfg++ let (cg_ipes, strtab) = flip runState emptyStringTable $ do+ module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)+ mapM (toCgIPE platform ctx module_name) ents++ let -- Emit the fields of an IpeBufferEntry struct.+ toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]+ toIpeBufferEntry cg_ipe =+ [ CmmLabel (ipeInfoTablePtr cg_ipe)+ , strtab_offset (ipeTableName cg_ipe)+ , strtab_offset (ipeClosureDesc cg_ipe)+ , strtab_offset (ipeTypeDesc cg_ipe)+ , strtab_offset (ipeLabel cg_ipe)+ , strtab_offset (ipeModuleName cg_ipe)+ , strtab_offset (ipeSrcLoc cg_ipe)+ ]++ int n = mkIntCLit platform n+ int32 n = CmmInt n W32+ strtab_offset (StrTabOffset n) = int32 (fromIntegral n)++ strings <- newByteStringCLit (getStringTableStrings strtab)+ let lits = [ zeroCLit platform -- 'next' field+ , strings -- 'strings' field+ , int $ length cg_ipes -- 'count' field+ ] ++ concatMap toIpeBufferEntry cg_ipes+ emitDataLits (mkIPELabel this_mod) lits++toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt+toCgIPE platform ctx module_name ipe = do+ table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))+ closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)+ type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe+ let (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe)+ label <- lookupStringTable $ ST.pack label_str+ src_loc <- lookupStringTable $ ST.pack src_loc_str+ return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe+ , ipeTableName = table_name+ , ipeClosureDesc = closure_desc+ , ipeTypeDesc = type_desc+ , ipeLabel = label+ , ipeModuleName = module_name+ , ipeSrcLoc = src_loc+ }++data CgInfoProvEnt = CgInfoProvEnt+ { ipeInfoTablePtr :: !CLabel+ , ipeTableName :: !StrTabOffset+ , ipeClosureDesc :: !StrTabOffset+ , ipeTypeDesc :: !StrTabOffset+ , ipeLabel :: !StrTabOffset+ , ipeModuleName :: !StrTabOffset+ , ipeSrcLoc :: !StrTabOffset+ }++data StringTable = StringTable { stStrings :: DList ShortText+ , stLength :: !Int+ , stLookup :: !(M.Map ShortText StrTabOffset)+ }++newtype StrTabOffset = StrTabOffset Int++emptyStringTable :: StringTable+emptyStringTable =+ StringTable { stStrings = emptyDList+ , stLength = 0+ , stLookup = M.empty+ }++getStringTableStrings :: StringTable -> BS.ByteString+getStringTableStrings st =+ BSL.toStrict $ BSB.toLazyByteString+ $ foldMap f $ dlistToList (stStrings st)+ where+ f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0++lookupStringTable :: ShortText -> State StringTable StrTabOffset+lookupStringTable str = state $ \st ->+ case M.lookup str (stLookup st) of+ Just off -> (off, st)+ Nothing ->+ let !st' = st { stStrings = stStrings st `snoc` str+ , stLength = stLength st + ST.byteLength str + 1+ , stLookup = M.insert str res (stLookup st)+ }+ res = StrTabOffset (stLength st)+ in (res, st')++newtype DList a = DList ([a] -> [a])++emptyDList :: DList a+emptyDList = DList id++snoc :: DList a -> a -> DList a+snoc (DList f) x = DList (f . (x:))++dlistToList :: DList a -> [a]+dlistToList (DList f) = f []
compiler/GHC/StgToCmm/Prof.hs view
@@ -11,7 +11,7 @@ mkCCostCentre, mkCCostCentreStack, -- infoTablePRov- initInfoTableProv, emitInfoTableProv,+ initInfoTableProv, -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,@@ -32,6 +32,7 @@ import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Config+import GHC.StgToCmm.InfoTableProv import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit@@ -55,7 +56,6 @@ import Control.Monad import Data.Char (ord)-import Data.Bifunctor (first) import GHC.Utils.Monad (whenM) -----------------------------------------------------------------------------@@ -274,9 +274,8 @@ where (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -+-- | Emit info-table provenance declarations initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub--- Emit the declarations initInfoTableProv infos itmap = do cfg <- getStgToCmmConfig@@ -284,42 +283,16 @@ info_table = stgToCmmInfoTableMap cfg platform = stgToCmmPlatform cfg this_mod = stgToCmmThisModule cfg- -- Output the actual IPE data- mapM_ emitInfoTableProv ents- -- Create the C stub which initialises the IPE map- return (ipInitCode info_table platform this_mod ents) ---- Info Table Prov stuff-emitInfoTableProv :: InfoProvEnt -> FCode ()-emitInfoTableProv ip = do- { cfg <- getStgToCmmConfig- ; let mod = infoProvModule ip- ctx = stgToCmmContext cfg- platform = stgToCmmPlatform cfg- ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)- mk_string = newByteStringCLit . utf8EncodeString- ; label <- mk_string label- ; modl <- newByteStringCLit (bytesFS $ moduleNameFS- $ moduleName mod)+ case ents of+ [] -> return mempty+ _ -> do+ -- Emit IPE buffer+ emitIpeBufferListNode this_mod ents - ; ty_string <- mk_string (infoTableType ip)- ; loc <- mk_string src- ; table_name <- mk_string (renderWithContext ctx- (pprCLabel platform CStyle (infoTablePtr ip)))- ; closure_type <- mk_string (renderWithContext ctx- (text $ show $ infoProvEntClosureType ip))- ; let- lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer- table_name, -- char *table_name- closure_type, -- char *closure_desc -- Filled in from the InfoTable- ty_string, -- char *ty_string- label, -- char *label,- modl, -- char *module,- loc, -- char *srcloc,- zero platform -- struct _InfoProvEnt *link- ]- ; emitDataLits (mkIPELabel ip) lits- }+ -- Create the C stub which initialises the IPE map+ return (ipInitCode info_table platform this_mod)+ -- --------------------------------------------------------------------------- -- Set the current cost centre stack
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -538,8 +538,36 @@ go _ _ = (caseTrivial,False) --- Return all syntactic subterms of ty that contain var somewhere--- These are the things that should appear in instance constraints+-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'+-- argument. This determines what constraints should be inferred for derived+-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".+-- For instance, if we have:+--+-- @+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))+-- @+--+-- Then the following would hold:+--+-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not+-- contain the type variable @a@ at all.+--+-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@+-- contains the type variable @a@, it is not /applied/ to @a@, which is the+-- criterion that 'deepSubtypesContaining' checks for.+--+-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@+-- is applied to @a@.+--+-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return+-- @[Either Int, Maybe]@. Both of these types are applied to @a@ through+-- composition.+--+-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from+-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from+-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from+-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data+-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.) deepSubtypesContaining :: TyVar -> Type -> [TcType] deepSubtypesContaining tv = functorLikeTraverse tv
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -91,10 +91,25 @@ ************************************************************************ -} +-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of+-- types, each of which must be a 'Functor' in order for the 'Generic1'+-- instance to work. For instance, if we have:+--+-- @+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))+-- @+--+-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,+-- as a derived 'Generic1' instance would need to call 'fmap' at that type.+-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would+-- return @[]@.+--+-- 'get_gen1_constrained_tys' is very similar in spirit to+-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with+-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come+-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'+-- is used.) get_gen1_constrained_tys :: TyVar -> Type -> [Type]--- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of--- types, each of which must be a Functor in order for the Generic1 instance to--- work. get_gen1_constrained_tys argVar = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] , ata_par1 = [], ata_rec1 = const []
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -176,9 +176,10 @@ -- Constraints arising from the arguments of each constructor con_arg_constraints- :: (CtOrigin -> TypeOrKind- -> Type- -> [(ThetaSpec, Maybe TCvSubst)])+ :: ([TyVar] -> CtOrigin+ -> TypeOrKind+ -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]) -> (ThetaSpec, [TyVar], [TcType], DerivInstTys) con_arg_constraints get_arg_constraints = let -- Constraints from the fields of each data constructor.@@ -193,7 +194,8 @@ , not (isUnliftedType arg_ty) , let orig = DerivOriginDC data_con arg_n wildcard , preds_and_mbSubst- <- get_arg_constraints orig arg_t_or_k arg_ty+ <- get_arg_constraints (dataConUnivTyVars data_con)+ orig arg_t_or_k arg_ty ] -- Stupid constraints from DatatypeContexts. Note that we -- must gather these constraints from the data constructors,@@ -235,21 +237,39 @@ is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind || is_generic1 - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type- -> [(ThetaSpec, Maybe TCvSubst)]- get_gen1_constraints functor_cls orig t_or_k ty+ get_gen1_constraints ::+ Class+ -> [TyVar] -- The universally quantified type variables for the+ -- data constructor+ -> CtOrigin -> TypeOrKind -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]+ get_gen1_constraints functor_cls dc_univs orig t_or_k ty = mk_functor_like_constraints orig t_or_k functor_cls $- get_gen1_constrained_tys last_tv ty+ get_gen1_constrained_tys last_dc_univ ty+ where+ -- If we are deriving an instance of 'Generic1' and have made+ -- it this far, then there should be at least one universal type+ -- variable, making this use of 'last' safe.+ last_dc_univ = assert (not (null dc_univs)) $+ last dc_univs - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type- -> [(ThetaSpec, Maybe TCvSubst)]- get_std_constrained_tys orig t_or_k ty+ get_std_constrained_tys ::+ [TyVar] -- The universally quantified type variables for the+ -- data constructor+ -> CtOrigin -> TypeOrKind -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]+ get_std_constrained_tys dc_univs orig t_or_k ty | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $- deepSubtypesContaining last_tv ty+ deepSubtypesContaining last_dc_univ ty | otherwise = [( [mk_cls_pred orig t_or_k main_cls ty] , Nothing )]+ where+ -- If 'is_functor_like' holds, then there should be at least one+ -- universal type variable, making this use of 'last' safe.+ last_dc_univ = assert (not (null dc_univs)) $+ last dc_univs mk_functor_like_constraints :: CtOrigin -> TypeOrKind -> Class -> [Type]@@ -277,9 +297,6 @@ , tcUnifyTy ki typeToTypeKind ) - rep_tc_tvs = tyConTyVars rep_tc- last_tv = last rep_tc_tvs- -- Extra Data constraints -- The Data class (only) requires that for -- instance (...) => Data (T t1 t2)@@ -318,7 +335,7 @@ -- Generic1 needs Functor -- See Note [Getting base classes] | is_generic1- -> assert (rep_tc_tvs `lengthExceeds` 0) $+ -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $ -- Generic1 has a single kind variable assert (cls_tys `lengthIs` 1) $ do { functorClass <- lift $ tcLookupClass functorClassName
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 9.4.2.20220822+version: 9.4.3.20221104 license: BSD3 license-file: LICENSE category: Development@@ -83,7 +83,7 @@ stm, rts, hpc == 0.6.*,- ghc-lib-parser == 9.4.2.20220822+ ghc-lib-parser == 9.4.3.20221104 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns@@ -210,6 +210,7 @@ GHC.Data.FastString.Env, GHC.Data.FiniteMap, GHC.Data.Graph.Directed,+ GHC.Data.Graph.UnVar, GHC.Data.IOEnv, GHC.Data.List.SetOps, GHC.Data.Maybe,@@ -605,7 +606,6 @@ GHC.Data.Graph.Color GHC.Data.Graph.Ops GHC.Data.Graph.Ppr- GHC.Data.Graph.UnVar GHC.Data.UnionFind GHC.Driver.Backpack GHC.Driver.CodeOutput@@ -733,6 +733,7 @@ GHC.StgToCmm.Foreign GHC.StgToCmm.Heap GHC.StgToCmm.Hpc+ GHC.StgToCmm.InfoTableProv GHC.StgToCmm.Layout GHC.StgToCmm.Lit GHC.StgToCmm.Monad