diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-05-08 11:21:16 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-08-28 11:14:05 +0100 |
| commit | 6e0f6ededff6018a88dd390590a09f79842ccfa5 (patch) | |
| tree | c2d4f46cfdcf8b236d9ac751c48f0b0ccced7503 /compiler/deSugar | |
| parent | e9cd1d5e9d6f0e019d6433a3c7dd9585b3f7ae6b (diff) | |
| download | haskell-6e0f6ededff6018a88dd390590a09f79842ccfa5.tar.gz | |
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.
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/DsBinds.lhs | 24 |
1 files changed, 10 insertions, 14 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 172d19b9ac..18b6856ec1 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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) |