import CoreSyn
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprType, eqExpr, mkPiTypes )
+import CoreUtils ( exprType, tcEqExpr, mkPiTypes )
import CoreFVs ( exprsFreeVars )
-import CoreTidy ( pprTidyIdRules )
+import CoreTidy ( tidyRules )
+import PprCore ( pprRules )
import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
-import Id ( Id, idName, idType, idSpecialisation,
- isDataConId_maybe,
+import Id ( Id, idName, idType, isDataConWorkId_maybe,
mkUserLocal, mkSysLocal )
import Var ( Var )
import VarEnv
import VarSet
import Name ( nameOccName, nameSrcLoc )
-import Rules ( addIdSpecialisations )
+import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import BasicTypes ( Activation(..) )
import Outputable
import List ( nubBy, partition )
import UniqSupply
import Outputable
+import FastString
\end{code}
-----------------------------------------------------
endPass dflags "SpecConstr" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
+ (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
return binds'
where
scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
returnUs (usg, Lam b e')
-scExpr env (Case scrut b alts)
+scExpr env (Case scrut b ty alts)
= sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
- Case scrut' b alts')
+ Case scrut' b ty alts')
where
sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
sc_scrut e = scExpr env e
(nubBy same_call good_calls `zip` [1..])
where
n_bndrs = length bndrs
- same_call as1 as2 = and (zipWith eqExpr as1 as2)
+ same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
---------------------
good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
-- 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))
+ rule_name = mkFastString ("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)
+ rule_rhs = mkVarApps (Var spec_id) spec_call_args
+ rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
in
returnUs (rule, (spec_id, spec_rhs))
is_con_app_maybe env expr
= case collectArgs expr of
- (Var fun, args) | Just con <- isDataConId_maybe fun,
+ (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
-> Just (DataAlt con,args)