import Name
import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_PprStyle_Debug )
-import StaticFlags ( opt_SpecInlineJoinPoints )
-import BasicTypes ( Activation(..) )
import Maybes ( orElse, catMaybes, isJust, isNothing )
import Demand
import DmdAnal ( both )
lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
scSubstId :: ScEnv -> Id -> CoreExpr
-scSubstId env v = lookupIdSubst (sc_subst env) v
+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty
scExpr' env (Let (NonRec bndr rhs) body)
| isTyVar bndr -- Type-lets may be created by doBeta
= scExpr' (extendScSubst env bndr rhs) body
- | otherwise
- = do { let (body_env, bndr') = extendBndr env bndr
- ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
- ; let rhs' = mkLams args' rhs_body'
-
- ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
- do { -- Vanilla case
- let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
- -- Record if the RHS is a value
- ; (body_usg, body') <- scExpr body_env2 body
- ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
- else -- For now, just brutally inline the join point
- do { let body_env2 = extendScSubst env bndr rhs'
- ; scExpr body_env2 body } }
-
-
-{- Old code
- do { -- Join-point case
- let body_env2 = extendHowBound body_env [bndr'] RecFun
- -- If the RHS of this 'let' contains calls
- -- to recursive functions that we're trying
- -- to specialise, then treat this let too
- -- as one to specialise
- ; (body_usg, body') <- scExpr body_env2 body
-
- ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
- ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+ | otherwise -- Note [Local let bindings]
+ = do { let (body_env, bndr') = extendBndr env bndr
+ ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
+ ; let force_spec = False
+ ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+ ; (body_usg, body') <- scExpr body_env2 body
+ ; (spec_usg, specs) <- specialise env force_spec
+ (scu_calls body_usg)
+ rhs_info
+ (SI [] 0 Nothing)
+
+ ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
`combineUsage` rhs_usg `combineUsage` spec_usg,
mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
}
--}
+
-- A *local* recursive group: see Note [Local recursive groups]
scExpr' env (Let (Rec prs) body)
; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
Let bind' body') }
+\end{code}
------------------------------------
+Note [Local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is not uncommon to find this
+
+ let $j = \x. <blah> in ...$j True...$j True...
+
+Here $j is an arbitrary let-bound function, but it often comes up for
+join points. We might like to specialise $j for its call patterns.
+Notice the difference from a letrec, where we look for call patterns
+in the *RHS* of the function. Here we look for call patterns in the
+*body* of the let.
+
+At one point I predicated this on the RHS mentioning the outer
+recursive function, but that's not essential and might even be
+harmful. I'm not sure.
+
+
+\begin{code}
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
scApp env (Var fn, args) -- Function is a variable
, notNull arg_bndrs -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn
= do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
--- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
--- text "calls" <+> ppr all_calls,
--- text "good pats" <+> ppr pats]) $
+-- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
+-- , text "arg_occs" <+> ppr arg_occs,
+-- , text "calls" <+> ppr all_calls,
+-- , text "good pats" <+> ppr pats]) $
-- return ()
-- Bale out if too many specialisations
-- Rather a hacky way to do so, but it'll do for now
- ; let spec_count' = length pats + spec_count
+ ; let n_pats = length pats
+ spec_count' = length pats + spec_count
; case sc_count env of
Just max | not force_spec && spec_count' > max
- -> WARN( True, msg ) return (nullUsage, spec_info)
+ -> pprTrace "SpecConstr" msg $
+ return (nullUsage, spec_info)
where
- msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
- , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
+ msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
+ , nest 2 (ptext (sLit "has") <+> int n_pats <+>
+ ptext (sLit "call patterns, but the limit is") <+> int max) ]
, ptext (sLit "Use -fspec-constr-count=n to set the bound")
, extra ]
extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
-- Usual w/w hack to avoid generating
-- a spec_rhs of unlifted type and no args
- fn_name = idName fn
- fn_loc = nameSrcSpan fn_name
- spec_occ = mkSpecOcc (nameOccName fn_name)
- rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
- spec_rhs = mkLams spec_lam_args spec_body
- spec_str = calcSpecStrictness fn spec_lam_args pats
- spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
- `setIdStrictness` spec_str -- See Note [Transfer strictness]
- `setIdArity` count isId spec_lam_args
- body_ty = exprType spec_body
- rule_rhs = mkVarApps (Var spec_id) spec_call_args
- rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
+ fn_name = idName fn
+ fn_loc = nameSrcSpan fn_name
+ spec_occ = mkSpecOcc (nameOccName fn_name)
+ rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
+ spec_rhs = mkLams spec_lam_args spec_body
+ spec_str = calcSpecStrictness fn spec_lam_args pats
+ spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
+ `setIdStrictness` spec_str -- See Note [Transfer strictness]
+ `setIdArity` count isId spec_lam_args
+ body_ty = exprType spec_body
+ rule_rhs = mkVarApps (Var spec_id) spec_call_args
+ inline_act = idInlineActivation fn
+ rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
calcSpecStrictness :: Id -- The original function
| (Var _, args) <- collectArgs e = go env ds args
go_one env _ _ = env
--- In which phase should the specialise-constructor rules be active?
--- Originally I made them always-active, but Manuel found that
--- this defeated some clever user-written rules. So Plan B
--- is to make them active only in Phase 0; after all, currently,
--- the specConstr transformation is only run after the simplifier
--- has reached Phase 0. In general one would want it to be
--- flag-controllable, but for now I'm leaving it baked in
--- [SLPJ Oct 01]
-specConstrActivation :: Activation
-specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
\end{code}
+Note [Transfer activation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+In which phase should the specialise-constructor rules be active?
+Originally I made them always-active, but Manuel found that this
+defeated some clever user-written rules. Then I made them active only
+in Phase 0; after all, currently, the specConstr transformation is
+only run after the simplifier has reached Phase 0, but that meant
+that specialisations didn't fire inside wrappers; see test
+simplCore/should_compile/spec-inline.
+
+So now I just use the inline-activation of the parent Id, as the
+activation for the specialiation RULE, just like the main specialiser;
+see Note [Auto-specialisation and RULES] in Specialise.
+
+
Note [Transfer strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We must transfer strictness information from the original function to