import CoreSyn
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprType, eqExpr )
+import CoreUtils ( exprType, eqExpr, mkPiTypes )
import CoreFVs ( exprsFreeVars )
+import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
-import PprCore ( pprCoreRules, pprCoreRule )
+import PprCore ( pprCoreRules )
import Id ( Id, idName, idType, idSpecialisation,
isDataConId_maybe,
mkUserLocal, mkSysLocal )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..) )
+import BasicTypes ( Activation(..) )
import Outputable
import Maybes ( orElse )
-import Util ( mapAccumL )
+import Util ( mapAccumL, lengthAtLeast )
import List ( nubBy, partition )
import UniqSupply
import Outputable
-import UniqFM ( ufmToList )
\end{code}
-----------------------------------------------------
good_calls :: [[CoreArg]]
good_calls = [ pats
| (con_env, call_args) <- all_calls,
- length call_args >= n_bndrs, -- App is saturated
+ call_args `lengthAtLeast` n_bndrs, -- App is saturated
let call = (bndrs `zip` call_args),
any (good_arg con_env occs) call, -- At least one arg is a constr app
let (_, pats) = argsToPats con_env us call_args
f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
-}
-spec_one env fn rhs (pats, n)
- = getUniqueUs `thenUs` \ spec_uniq ->
+spec_one env fn rhs (pats, rule_number)
+ = getUniqueUs `thenUs` \ spec_uniq ->
let
fn_name = idName fn
fn_loc = nameSrcLoc fn_name
-- variable may mention a type variable
(tvs, ids) = partition isTyVar vars_to_bind
bndrs = tvs ++ ids
+ spec_body = mkApps rhs pats
+ body_ty = exprType spec_body
- rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n))
- spec_rhs = mkLams bndrs (mkApps rhs pats)
- spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
- rule = Rule rule_name bndrs pats (mkVarApps (Var spec_id) bndrs)
+ (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
+ -- Usual w/w hack to avoid generating
+ -- a spec_rhs of unlifted type and no args
+
+ rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int rule_number))
+ spec_rhs = mkLams spec_lam_args spec_body
+ spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
+ rule = Rule rule_name specConstrActivation
+ bndrs pats (mkVarApps (Var spec_id) spec_call_args)
in
returnUs (rule, (spec_id, spec_rhs))
+
+-- 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}
%************************************************************************
= (us, Var v) -- so that we can spot when we pass them twice
argToPat env us arg
- = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
+ = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
where
(us1,us2) = splitUniqSupply us
is_con_app_maybe env expr
= case collectArgs expr of
(Var fun, args) | Just con <- isDataConId_maybe fun,
- length args >= dataConRepArity con
+ args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
-> Just (DataAlt con,args)