diff options
Diffstat (limited to 'compiler/GHC/Core/Opt/SpecConstr.hs')
| -rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 159 |
1 files changed, 56 insertions, 103 deletions
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 8b303f0316..9ef2d3e3e6 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -628,41 +628,12 @@ regardless of size; and then we needed a way to turn that *off*. Now that we have ForceSpecConstr, this NoSpecConstr is probably redundant. (Used only for PArray, TODO: remove?) -Note [SpecConstr and evaluated unfoldings] +Note [SpecConstr and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SpecConstr will attach evaldUnfolding unfoldings to function -arguments representing things that should be fully evaluated -by the time we execute the RHS. - -This primarily concerns strict fields. To give an example in the -containers package we have a merge function with this specialization: - - "SC:$wmerge01" [2] - forall (sc_s5lX :: ghc-prim:GHC.Prim.Int#) - (sc_s5lY :: ghc-prim:GHC.Prim.Int#) - (sc_s5lZ - :: IntMap a_s4UX - Unf=OtherCon []) - (sc_s5m0 - :: IntMap a_s4UX - Unf=OtherCon []) - (sc_s5lW :: ghc-prim:GHC.Prim.Int#) - (sc_s5lU :: ghc-prim:GHC.Prim.Int#) - (sc_s5lV :: a_s4UX). - $wmerge0_s4UK (Data.IntMap.Internal.Tip @a_s4UX sc_s5lU sc_s5lV) - (ghc-prim:GHC.Types.I# sc_s5lW) - (Data.IntMap.Internal.Bin - @a_s4UX sc_s5lX sc_s5lY sc_s5lZ sc_s5m0) - = $s$wmerge0_s5m2 - sc_s5lX sc_s5lY sc_s5lZ sc_s5m0 sc_s5lW sc_s5lU sc_s5lV] - -We give sc_s5lZ and sc_s5m0 a evaluated unfolding since they come out of -strict field fields in the Bin constructor. -This is especially important since tag inference can then use this -information to adjust the calling convention of -`$wmerge0_s4UK` to enforce arguments being passed fully evaluated+tagged. -See Note [Tag Inference], Note [Strict Worker Ids] for more information on -how we can take advantage of this. +We treat strict fields in SpecConstr the same way we do in W/W. +That is we make the specialized function strict in arguments +representing strict fields. See Note [Call-by-value for worker args] +for why we do this. Note [Specialising on dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -797,6 +768,7 @@ specConstrProgram guts us <- getUniqueSupplyM (_, annos) <- getFirstAnnotations deserializeWithData guts this_mod <- getModule + -- pprTraceM "specConstrInput" (ppr $ mg_binds guts) let binds' = reverse $ fst $ initUs us $ do -- Note [Top-level recursive groups] (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos) @@ -1815,7 +1787,7 @@ spec_one :: ScEnv -} spec_one env fn arg_bndrs body (call_pat, rule_number) - | CP { cp_qvars = qvars, cp_args = pats } <- call_pat + | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat = do { spec_uniq <- getUniqueM ; let env1 = extendScSubstList (extendScInScope env qvars) (arg_bndrs `zip` pats) @@ -1858,17 +1830,14 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) , (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. - -- Unlike W/W we don't turn functions into strict workers - -- immediately here instead letting tidy handle this. - -- For this reason we can ignore the cbv marks. - -- See Note [Strict Worker Ids]. See Note [Tag Inference]. , !spec_arity <- spec_arity1 + 1 , !spec_join_arity <- fmap (+ 1) spec_join_arity1 = (spec_lam_args, spec_call_args, spec_arity, spec_join_arity) | otherwise = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) - spec_id = mkLocalId spec_name Many + spec_id = asWorkerLikeId $ + mkLocalId spec_name Many (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] `setIdDmdSig` spec_sig @@ -1876,8 +1845,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) `setIdArity` spec_arity `asJoinId_maybe` spec_join_arity - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args spec_body + -- 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) $ -- This will give us all the arguments we quantify over -- in the rule plus the void argument if present @@ -1889,25 +1858,39 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) 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) + -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (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 "cbv_args" <+> ppr cbv_args -- , 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 "adds_void_worker_arg" <+> ppr add_void_arg -- , text "body" <+> ppr body -- , text "spec_rhs" <+> ppr spec_rhs - -- , text "how_bound" <+> ppr (sc_how_bound env) ]) $ - -- return () + -- , text "how_bound" <+> ppr (sc_how_bound env) ]) ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id , os_rhs = spec_rhs }) } +-- See Note [SpecConstr and strict fields] +mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr +mkSeqs seqees res_ty rhs = + foldr addEval rhs seqees + where + addEval :: Var -> CoreExpr -> CoreExpr + addEval arg_id rhs + -- Argument representing strict field and it's worth passing via cbv + | shouldStrictifyIdForCbv arg_id + = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs]) + | otherwise + = rhs + + {- Note [SpecConst needs to add void args first] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function @@ -2197,13 +2180,15 @@ only in kind-casts, but I'm doing the simple thing for now. -} data CallPat = CP { cp_qvars :: [Var] -- Quantified variables - , cp_args :: [CoreExpr] } -- Arguments + , cp_args :: [CoreExpr] -- Arguments + , cp_strict_args :: [Var] } -- Arguments we want to pass unlifted even if they are boxed -- See Note [SpecConstr call patterns] instance Outputable CallPat where - ppr (CP { cp_qvars = qvars, cp_args = args }) + ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict }) = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma - , text "cp_args =" <+> ppr args ]) + , text "cp_args =" <+> ppr args + , text "cp_strict_args = " <> ppr strict ]) callsToNewPats :: ScEnv -> Id -> SpecInfo @@ -2315,16 +2300,16 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) callToPats env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScope (sc_subst env) - ; pairs <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) + ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) -- This zip trims the args to be no longer than -- the lambdas in the function definition (bndr_occs) -- Drop boring patterns from the end -- See Note [SpecConstr call patterns] - ; let pairs' | isJoinId fn = pairs - | otherwise = dropWhileEnd is_boring pairs - is_boring (interesting, _) = not interesting - (interesting_s, pats) = unzip pairs' + ; let arg_tripples' | isJoinId fn = arg_tripples + | otherwise = dropWhileEnd is_boring arg_tripples + is_boring (interesting, _,_) = not interesting + (interesting_s, pats, cbv_ids) = unzip3 arg_tripples' interesting = or interesting_s ; let pat_fvs = exprsFreeVarsList pats @@ -2374,7 +2359,7 @@ callToPats env bndr_occs call@(Call fn args con_env) -- text "pat_fvs:" <+> ppr pat_fvs -- ) -- ppr (CP { cp_qvars = qvars', cp_args = pats })) >> - return (Just (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 } -- argToPat takes an actual argument, and returns an abstracted @@ -2389,8 +2374,8 @@ argToPat :: ScEnv -> CoreArg -- A call arg (or component thereof) -> ArgOcc -> StrictnessMark -- Tells us if this argument is a strict field of a data constructor - -- See Note [SpecConstr and evaluated unfoldings] - -> UniqSM (Bool, CoreArg) + -- See Note [SpecConstr and strict fields] + -> UniqSM (Bool, CoreArg, [Id]) -- Returns (interesting, pat), -- where pat is the pattern derived from the argument @@ -2415,12 +2400,12 @@ argToPat1 :: ScEnv -> Expr CoreBndr -> ArgOcc -> StrictnessMark - -> UniqSM (Bool, Expr CoreBndr) + -> UniqSM (Bool, Expr CoreBndr, [Id]) argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str - = return (False, arg) + = return (False, arg, []) -argToPat1 env in_scope val_env (Tick _ arg) arg_occ _arg_str - = argToPat env in_scope val_env arg arg_occ _arg_str +argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str + = argToPat env in_scope val_env arg arg_occ arg_str -- Note [Tick annotations in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes @@ -2444,7 +2429,7 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) - = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ arg_str + = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str ; if not interesting then wildCardPat ty2 arg_str else do @@ -2452,7 +2437,7 @@ argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str uniq <- getUniqueM ; let co_name = mkSysTvName uniq (fsLit "sg") co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } } where Pair ty1 ty2 = coercionKind co @@ -2488,17 +2473,12 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -- ppr rest_args $$ -- ppr (map isTypeArg rest_args)) ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str - ; let args' = map snd prs :: [CoreArg] + ; let args' = map sndOf3 prs :: [CoreArg] ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) ( ppr con_str $$ ppr rest_args $$ ppr (length con_str) $$ ppr (length rest_args) ) $ return () - -- ; assert (length con_str == length rest_args) $ - -- pprTraceM "argToPat" - -- ( parens (int $ length con_str) <> ppr con_str $$ - -- ppr rest_args $$ - -- ppr prs) - ; return (True, mkConApp dc (ty_args ++ args')) } + ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) } where mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc @@ -2526,7 +2506,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -- business of absence analysis, not SpecConstr.) -- (b) we know what its value is -- In that case it counts as "interesting" -argToPat1 env in_scope val_env (Var v) arg_occ _arg_str +argToPat1 env in_scope val_env (Var v) arg_occ arg_str | sc_force env || case arg_occ of { ScrutOcc {} -> True ; UnkOcc -> False ; NoOcc -> False } -- (a) @@ -2535,7 +2515,8 @@ argToPat1 env in_scope val_env (Var v) arg_occ _arg_str -- So sc_keen focused just on f (I# x), where we have freshly-allocated -- box that we can eliminate in the caller , not (ignoreType env (varType v)) - = return (True, Var (setStrUnfolding v MarkedStrict)) + -- See Note [SpecConstr and strict fields] + = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty) where is_value | isLocalId v = v `elemInScopeSet` in_scope @@ -2567,41 +2548,12 @@ argToPat1 env in_scope val_env (Var v) arg_occ _arg_str argToPat1 _env _in_scope _val_env arg _arg_occ arg_str = wildCardPat (exprType arg) arg_str --- We want the given id to be passed call-by-value if it's MarkedCbv. --- For some, but not all ids this can be achieved by giving them an OtherCon unfolding. --- Doesn't touch existing value unfoldings. --- See Note [SpecConstr and evaluated unfoldings] -setStrUnfolding :: Id -> StrictnessMark -> Id --- setStrUnfolding id str = id -setStrUnfolding id str - -- pprTrace "setStrUnfolding" - -- (ppr id <+> ppr (isMarkedCbv str) $$ - -- ppr (idType id) $$ - -- text "boxed:" <> ppr (isBoxedType (idType id)) $$ - -- text "unlifted:" <> ppr (isUnliftedType (idType id)) - -- ) - -- False - -- = undefined - | not (isId id) || isEvaldUnfolding (idUnfolding id) - = id - | isMarkedStrict str - , not $ isUnliftedType (idType id) -- Pointless to stick an evald unfolding on unlifted types - = -- trace "setStrUnfolding2" $ - assert (isId id) $ - assert (not $ hasCoreUnfolding $ idUnfolding id) $ - id `setIdUnfolding` evaldUnfolding - | otherwise - = -- trace "setStrUnfolding3" - id - -- | wildCardPats are always boring -wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg) +wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) wildCardPat ty str = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty - ; let id' = id `setStrUnfolding` str - -- See Note [SpecConstr and evaluated unfoldings] -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id')) - ; return (False, varToCoreExpr id') } + ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) } isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit) @@ -2659,6 +2611,7 @@ samePat (CP { cp_qvars = vs1, cp_args = as1 }) (CP { cp_qvars = vs2, cp_args = as2 }) = all2 same as1 as2 where + -- If the args are the same, their strictness marks will be too so we don't compare those. same (Var v1) (Var v2) | v1 `elem` vs1 = v2 `elem` vs2 | v2 `elem` vs2 = False |