Commit 6e0f6ede authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor unfoldings

There are two main refactorings here

1.  Move the uf_arity field
       out of CoreUnfolding
       into UnfWhen
    It's a lot tidier there.  If I've got this right, no behaviour
    should change.

2.  Define specUnfolding and use it in DsBinds and Specialise
     a) commons-up some shared code
     b) makes sure that Specialise correctly specialises DFun
        unfoldings (which it didn't before)

The two got put together because both ended up interacting in the
specialiser.

They cause zero difference to nofib.
parent e9cd1d5e
......@@ -1179,8 +1179,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr
-- and that is the business of callSiteInline.
-- In practice, without this test, most of the "hits" were
-- CPR'd workers getting inlined back into their wrappers,
| Just rhs <- expandUnfolding_maybe unfolding
, unfoldingArity unfolding == 0
| idArity fun == 0
, Just rhs <- expandUnfolding_maybe unfolding
, let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
= go (Left in_scope') rhs cont
where
......@@ -1327,10 +1327,9 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
-- Another attempt: See if we find a partial unfolding
exprIsLambda_maybe (in_scope_set, id_unf) e
| (Var f, as) <- collectArgs e
, let unfolding = id_unf f
, Just rhs <- expandUnfolding_maybe unfolding
, idArity f > length (filter isValArg as)
-- Make sure there is hope to get a lambda
, unfoldingArity unfolding > length (filter isValArg as)
, Just rhs <- expandUnfolding_maybe (id_unf f)
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
......
......@@ -55,7 +55,7 @@ module CoreSyn (
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,
maybeUnfoldingTemplate, otherCons, unfoldingArity,
maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isStableCoreUnfolding_maybe,
......@@ -686,7 +686,6 @@ data Unfolding
uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
uf_src :: UnfoldingSource, -- Where the unfolding came from
uf_is_top :: Bool, -- True <=> top level binding
uf_arity :: Arity, -- Number of value arguments expected
uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard
-- a `seq` on this variable
uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function
......@@ -752,6 +751,8 @@ data UnfoldingGuidance
-- Used (a) for small *and* cheap unfoldings
-- (b) for INLINE functions
-- See Note [INLINE for small functions] in CoreUnfold
ug_arity :: Arity, -- Number of value arguments expected
ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring
-- So True,True means "always"
......@@ -846,8 +847,8 @@ seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
uf_is_value = b1, uf_is_work_free = b2,
uf_expandable = b3, uf_is_conlike = b4,
uf_arity = a, uf_guidance = g})
= seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
uf_guidance = g})
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
seqUnfolding _ = ()
......@@ -936,10 +937,6 @@ isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
isStableUnfolding (DFunUnfolding {}) = True
isStableUnfolding _ = False
unfoldingArity :: Unfolding -> Arity
unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
unfoldingArity _ = panic "unfoldingArity"
isClosedUnfolding :: Unfolding -> Bool -- No free variables
isClosedUnfolding (CoreUnfolding {}) = False
isClosedUnfolding (DFunUnfolding {}) = False
......
This diff is collapsed.
......@@ -421,9 +421,10 @@ showAttributes stuff
\begin{code}
instance Outputable UnfoldingGuidance where
ppr UnfNever = ptext (sLit "NEVER")
ppr (UnfWhen unsat_ok boring_ok)
ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
= ptext (sLit "ALWAYS_IF") <>
parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
parens (ptext (sLit "arity=") <> int arity <> comma <>
ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
ptext (sLit "boring_ok=") <> ppr boring_ok)
ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
= hsep [ ptext (sLit "IF_ARGS"),
......@@ -446,13 +447,12 @@ instance Outputable Unfolding where
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_work_free=wf
, uf_expandable=exp, uf_guidance=g, uf_arity=arity})
, uf_expandable=exp, uf_guidance=g })
= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
where
pp_info = fsep $ punctuate comma
[ ptext (sLit "Src=") <> ppr src
, ptext (sLit "TopLvl=") <> ppr top
, ptext (sLit "Arity=") <> int arity
, ptext (sLit "Value=") <> ppr hnf
, ptext (sLit "ConLike=") <> ppr conlike
, ptext (sLit "WorkFree=") <> ppr wf
......
......@@ -463,8 +463,11 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
Right (rule_bndrs, _fn, args) -> do
{ dflags <- getDynFlags
; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id)
spec_id = mkLocalId spec_name spec_ty
; let fn_unf = realIdUnfolding poly_id
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
......@@ -474,11 +477,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
(mkVarApps (Var spec_id) bndrs)
; spec_rhs <- dsHsWrapper spec_co poly_rhs
; let spec_pair = makeCorePair dflags spec_id False (dictArity bndrs) spec_rhs
; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
(warnDs (specOnInline poly_name))
; return (Just (unitOL spec_pair, rule))
; return (Just (unitOL (spec_id, spec_rhs), rule))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-- makeCorePair overwrites the unfolding, which we have
-- just created using specUnfolding
} } }
where
is_local_id = isJust mb_poly_rhs
......@@ -515,16 +521,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise = spec_prag_act -- Specified by user
specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding
specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs )
df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args }
where
subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args)
fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs
specUnfolding _ _ _ = noUnfolding
specOnInline :: Name -> MsgDoc
specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
<+> quotes (ppr f)
......
......@@ -1881,14 +1881,16 @@ toIfaceIdInfo id_info
--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
, uf_src = src, uf_guidance = guidance })
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
, uf_src = src
, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
InlineStable
-> case guidance of
UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
-> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
InlineCompulsory -> IfCompulsory if_rhs
InlineRhs -> IfCoreUnfold False if_rhs
-- Yes, even if guidance is UnfNever, expose the unfolding
......
......@@ -1306,9 +1306,9 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr arity
(UnfWhen unsat_ok boring_ok))
}
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
where
guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
......
......@@ -744,19 +744,19 @@ simplUnfolding env top_lvl id new_rhs unf
; args' <- mapM (simplExpr env') args
; return (mkDFunUnfolding bndrs' con args') }
CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide }
CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
| isStableSource src
-> do { expr' <- simplExpr rule_env expr
; case guide of
UnfWhen sat_ok _ -- Happens for INLINE things
-> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok } -- Happens for INLINE things
-> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
, ug_boring_ok = inlineBoringOk expr' }
-- Refresh the boring-ok flag, in case expr'
-- has got small. This happens, notably in the inlinings
-- for dfuns for single-method classes; see
-- Note [Single-method classes] in TcInstDcls.
-- A test case is Trac #4138
in return (mkCoreUnfolding src is_top_lvl expr' arity guide')
in return (mkCoreUnfolding src is_top_lvl expr' guide')
-- See Note [Top-level flag on inline rules] in CoreUnfold
_other -- Happens for INLINABLE things
......
......@@ -1072,8 +1072,6 @@ specCalls env rules_for_me calls_for_me fn rhs
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule
(rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
rhs_dict_ids = take n_dicts rhs_ids
......@@ -1123,22 +1121,24 @@ specCalls env rules_for_me calls_for_me fn rhs
-- spec_tyvars = [a,c]
-- ty_args = [t1,b,t3]
spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
spec_ty_args = map snd spec_tv_binds
env1 = extendTvSubstList env spec_tv_binds
(rhs_env, poly_tyvars) = substBndrs env1
[tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
; (rhs_env2, inst_dict_ids, dx_binds)
<- bindAuxiliaryDicts rhs_env (zipEqual "bindAux" rhs_dict_ids call_ds)
; let ty_args = mk_ty_args call_ts poly_tyvars
inst_args = ty_args ++ map Var inst_dict_ids
-- Clone rhs_dicts, including instantiating their types
; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids
; let (rhs_env2, dx_binds, spec_dict_args)
= bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids
ty_args = mk_ty_args call_ts poly_tyvars
rule_args = ty_args ++ map Var inst_dict_ids
rule_bndrs = poly_tyvars ++ inst_dict_ids
; dflags <- getDynFlags
; if already_covered dflags inst_args then
; if already_covered dflags rule_args then
return Nothing
else do
{ -- Figure out the type of the specialised function
let body_ty = applyTypeToArgs rhs fn_type inst_args
let body_ty = applyTypeToArgs rhs fn_type rule_args
(lam_args, app_args) -- Add a dummy argument if body_ty is unlifted
| isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs
= (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
......@@ -1150,13 +1150,13 @@ specCalls env rules_for_me calls_for_me fn rhs
; let
-- The rule to put in the function's specialisation is:
-- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b
rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> ppr spec_ty_args))
rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> hsep (map ppr_call_key_ty call_ts)))
spec_env_rule = mkRule True {- Auto generated -} is_local
rule_name
inl_act -- Note [Auto-specialisation and RULES]
(idName fn)
(poly_tyvars ++ inst_dict_ids)
inst_args
rule_bndrs
rule_args
(mkVarApps (Var spec_f) app_args)
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
......@@ -1165,20 +1165,18 @@ specCalls env rules_for_me calls_for_me fn rhs
--------------------------------------
-- Add a suitable unfolding if the spec_inl_prag says so
-- See Note [Inline specialisations]
spec_inl_prag
(spec_inl_prag, spec_unf)
| not is_local && isStrongLoopBreaker (idOccInfo fn)
= neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal
| otherwise
= case inl_prag of
InlinePragma { inl_inline = Inlinable }
-> inl_prag { inl_inline = EmptyInlineSpec }
_ -> inl_prag
= (neverInlinePragma, noUnfolding)
-- See Note [Specialising imported functions] in OccurAnal
spec_unf
= case inlinePragmaSpec spec_inl_prag of
Inline -> mkInlineUnfolding (Just spec_arity) spec_rhs
Inlinable -> mkInlinableUnfolding dflags spec_rhs
_ -> NoUnfolding
| InlinePragma { inl_inline = Inlinable } <- inl_prag
= (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)
| otherwise
= (inl_prag, specUnfolding dflags (se_subst env)
poly_tyvars (ty_args ++ spec_dict_args)
fn_unf)
--------------------------------------
-- Adding arity information just propagates it a bit faster
......@@ -1193,34 +1191,35 @@ specCalls env rules_for_me calls_for_me fn rhs
bindAuxiliaryDicts
:: SpecEnv
-> [(DictId,CoreExpr)] -- (orig_dict, dx)
-> SpecM (SpecEnv, -- Substitute for all orig_dicts
[DictId], -- Cloned dict Ids
[CoreBind]) -- Auxiliary bindings
-> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions
-> [DictId] -- A cloned dict-id for each dict arg
-> (SpecEnv, -- Substitute for all orig_dicts
[CoreBind], -- Auxiliary dict bindings
[CoreExpr]) -- Witnessing expressions (all trivial)
-- Bind any dictionary arguments to fresh names, to preserve sharing
bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
dict_binds
= do { inst_dict_ids <- mapM (newDictBndr env . fst) dict_binds
-- Clone rhs_dicts, including instantiating their types
; let triples = inst_dict_ids `zip` dict_binds
(subst', binds) = go subst [] triples
interesting_dicts = mkVarSet [ dx_id | (dx_id, (_, dx)) <- triples
, interestingDict env dx ]
bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
orig_dict_ids call_ds inst_dict_ids
= (env', dx_binds, spec_dict_args)
where
(dx_binds, spec_dict_args) = go call_ds inst_dict_ids
env' = env { se_subst = CoreSubst.extendIdSubstList subst (orig_dict_ids `zip` spec_dict_args)
, se_interesting = interesting `unionVarSet` interesting_dicts }
interesting_dicts = mkVarSet [ dx_id | NonRec dx_id dx <- dx_binds
, interestingDict env dx ]
-- See Note [Make the new dictionaries interesting]
env' = env { se_subst = subst'
, se_interesting = interesting `unionVarSet` interesting_dicts }
; return (env', inst_dict_ids, binds) }
where
go subst binds [] = (subst, binds)
go subst binds ((dx_id, (d, dx)) : triples)
| exprIsTrivial dx = go (CoreSubst.extendIdSubst subst d dx) binds triples
| otherwise = go (CoreSubst.extendIdSubst subst d (Var dx_id))
(NonRec dx_id dx : binds) triples
go [] _ = ([], [])
go (dx:dxs) (dx_id:dx_ids)
| exprIsTrivial dx = (dx_binds, dx:args)
| otherwise = (NonRec dx_id dx : dx_binds, Var dx_id : args)
where
(dx_binds, args) = go dxs dx_ids
-- In the first case extend the substitution but not bindings;
-- in the latter extend the bindings but not the substitution.
-- For the former, note that we bind the *original* dict in the substitution,
-- overriding any d->dx_id binding put there by substBndrs
go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)
\end{code}
Note [Make the new dictionaries interesting]
......@@ -1550,6 +1549,16 @@ instance Outputable CallInfoSet where
ppr (CIS fn map) = hang (ptext (sLit "CIS") <+> ppr fn)
2 (ppr map)
{-
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo fn (CallKey mb_tys, (dxs, _))
= hang (ppr fn) 2 (sep (map ppr_call_key_ty mb_tys ++ map pprParendExpr dxs))
-}
ppr_call_key_ty :: Maybe Type -> SDoc
ppr_call_key_ty Nothing = char '_'
ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
instance Outputable CallKey where
ppr (CallKey ts) = ppr ts
......
......@@ -6,9 +6,9 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a T2431.:~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
Str=DmdType,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=0, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=False)
Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N}]
T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N
......
......@@ -7,9 +7,9 @@ T7116.dl :: GHC.Types.Double -> GHC.Types.Double
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: GHC.Types.Double) ->
case x of _ [Occ=Dead] { GHC.Types.D# y ->
GHC.Types.D# (GHC.Prim.+## y y)
......@@ -25,9 +25,9 @@ T7116.dr :: GHC.Types.Double -> GHC.Types.Double
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: GHC.Types.Double) ->
case x of _ [Occ=Dead] { GHC.Types.D# x1 ->
GHC.Types.D# (GHC.Prim.+## x1 x1)
......@@ -39,9 +39,9 @@ T7116.fl :: GHC.Types.Float -> GHC.Types.Float
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: GHC.Types.Float) ->
case x of _ [Occ=Dead] { GHC.Types.F# y ->
GHC.Types.F# (GHC.Prim.plusFloat# y y)
......@@ -57,9 +57,9 @@ T7116.fr :: GHC.Types.Float -> GHC.Types.Float
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once!] :: GHC.Types.Float) ->
case x of _ [Occ=Dead] { GHC.Types.F# x1 ->
GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
......
......@@ -18,9 +18,9 @@ T3717.foo [InlPrag=INLINE[0]] :: GHC.Types.Int -> GHC.Types.Int
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S(S),1*U(1*U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: GHC.Types.Int) ->
case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] ->
case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
......
......@@ -28,9 +28,8 @@ T4908.$wf
Arity=2,
Caf=NoCafRefs,
Str=DmdType <S,1*U><L,1*U(A,U(U))>,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [30 20] 101 20}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}]
T4908.$wf =
\ (ww :: GHC.Prim.Int#) (w :: (GHC.Types.Int, GHC.Types.Int)) ->
case ww of ds {
......@@ -53,9 +52,9 @@ T4908.f [InlPrag=INLINE[0]]
Arity=2,
Caf=NoCafRefs,
Str=DmdType <S(S),1*U(1*U)><L,1*U(A,U(U))>,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=2, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once!] :: GHC.Types.Int)
(w1 [Occ=Once] :: (GHC.Types.Int, GHC.Types.Int)) ->
case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] ->
......
......@@ -14,9 +14,9 @@ T4930.foo :: GHC.Types.Int -> GHC.Types.Int
[GblId,
Arity=1,
Str=DmdType <S,1*U(U)>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once!] :: GHC.Types.Int) ->
case n of _ [Occ=Dead] { GHC.Types.I# x ->
case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# x 5)
......
......@@ -7,9 +7,9 @@ T7360.$WFoo3 [InlPrag=INLINE] :: GHC.Types.Int -> T7360.Foo
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,U>m3,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)
Tmpl= \ (dt [Occ=Once!] :: GHC.Types.Int) ->
case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] ->
T7360.Foo3 dt
......@@ -29,27 +29,25 @@ T7360.fun1 =
T7360.fun4 :: ()
[GblId,
Str=DmdType,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, WorkFree=False, Expandable=False,
Guidance=IF_ARGS [] 20 0}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
T7360.fun4 = T7360.fun1 T7360.Foo1
T7360.fun3 :: GHC.Types.Int
[GblId,
Caf=NoCafRefs,
Str=DmdType m,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [] 10 20}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
T7360.fun3 = GHC.Types.I# 0
T7360.fun2 :: forall a. [a] -> ((), GHC.Types.Int)
[GblId,
Arity=1,
Str=DmdType <L,1*U>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
(T7360.fun4,
case x of wild {
......
==================== Tidy Core rules ====================
"SPEC Foo.shared [[]]" [ALWAYS]
"SPEC Foo.shared @ []" [ALWAYS]
forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int).
shared @ [] $dMyFunctor irred
= bar_$sshared
......
......@@ -14,4 +14,6 @@ Rule fired: Class op <*>
Rule fired: Class op $p1Applicative
Rule fired: Class op fmap
Rule fired: Class op <*>
Rule fired: SPEC T8848.$fFunctorShape ['T8848.Z]
Rule fired: SPEC $cfmap @ 'T8848.Z
Rule fired: SPEC $c<$ @ 'T8848.Z
Rule fired: SPEC T8848.$fFunctorShape @ 'T8848.Z
......@@ -202,6 +202,6 @@ test('T8832',
run_command,
['$MAKE -s --no-print-directory T8832 T8832_WORDSIZE_OPTS=' +
('-DT8832_WORDSIZE_64' if wordsize(64) else '')])
test('T8848', only_ways(['optasm']), compile, ['-ddump-rule-firings'])
test('T8848', only_ways(['optasm']), compile, ['-ddump-rule-firings -dsuppress-uniques'])
test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules'])
test('T8331', only_ways(['optasm']), compile, ['-ddump-rules'])
......@@ -48,9 +48,8 @@ Roman.$wgo
[GblId,
Arity=2,
Str=DmdType <S,1*U><S,1*U>,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [60 30] 256 0}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 256 0}]
Roman.$wgo =
\ (w :: Data.Maybe.Maybe GHC.Types.Int)
(w1 :: Data.Maybe.Maybe GHC.Types.Int) ->
......@@ -99,9 +98,9 @@ Roman.foo_go [InlPrag=INLINE[0]]
[GblId,
Arity=2,
Str=DmdType <S,1*U><S,1*U>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=2, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (w [Occ=Once] :: Data.Maybe.Maybe GHC.Types.Int)
(w1 [Occ=Once] :: Data.Maybe.Maybe GHC.Types.Int) ->
case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}]
......@@ -114,18 +113,16 @@ Roman.foo2 :: GHC.Types.Int
[GblId,
Caf=NoCafRefs,
Str=DmdType m,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [] 10 20}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
Roman.foo2 = GHC.Types.I# 6
Roman.foo1 :: Data.Maybe.Maybe GHC.Types.Int
[GblId,
Caf=NoCafRefs,
Str=DmdType m2,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [] 10 20}]
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
Roman.foo1 = Data.Maybe.Just @ GHC.Types.Int Roman.foo2
Roman.foo :: GHC.Types.Int -> GHC.Types.Int
......@@ -133,9 +130,9 @@ Roman.foo :: GHC.Types.Int -> GHC.Types.Int
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U>m,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once!] :: GHC.Types.Int) ->
case n of n1 { GHC.Types.I# _ [Occ=Dead] ->
Roman.foo_go (Data.Maybe.Just @ GHC.Types.Int n1) Roman.foo1
......
==================== Tidy Core rules ====================