X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecConstr.lhs;h=eb516869b0378790c1ddd981e03e998b17174705;hb=d7c402a3cedbe49345a34f2e58a3f3050638dcb4;hp=88d32f52f3e1367dbb77627f04f7208626170f65;hpb=dda636ede142f7f2c82090479cc1b44bb8a6871f;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 88d32f5..eb51686 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -12,13 +12,14 @@ module SpecConstr( import CoreSyn import CoreLint ( showPass, endPass ) -import CoreUtils ( exprType, eqExpr ) +import CoreUtils ( exprType, tcEqExpr, mkPiTypes ) import CoreFVs ( exprsFreeVars ) +import CoreTidy ( pprTidyIdRules ) +import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) -import PprCore ( pprCoreRules, pprCoreRule ) -import Id ( Id, idName, idType, idSpecialisation, - isDataConId_maybe, +import Id ( Id, idName, idType, + isDataConWorkId_maybe, mkUserLocal, mkSysLocal ) import Var ( Var ) import VarEnv @@ -28,13 +29,15 @@ import Rules ( addIdSpecialisations ) 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, notNull ) import List ( nubBy, partition ) import UniqSupply import Outputable +import FastString \end{code} ----------------------------------------------------- @@ -179,7 +182,7 @@ specConstrProgram dflags us binds endPass dflags "SpecConstr" Opt_D_dump_spec binds' dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" - (vcat (map dump_specs (concat (map bindersOf binds')))) + (vcat (map pprTidyIdRules (concat (map bindersOf binds')))) return binds' where @@ -187,8 +190,6 @@ specConstrProgram dflags us binds go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') -> go env' binds `thenUs` \ binds' -> returnUs (bind' : binds') - -dump_specs var = pprCoreRules var (idSpecialisation var) \end{code} @@ -222,6 +223,11 @@ data HowBound = RecFun -- These are the recursive functions for which -- passed as a parameter and what is in scope at the -- function definition site +instance Outputable HowBound where + ppr RecFun = text "RecFun" + ppr RecArg = text "RecArg" + ppr Other = text "Other" + lookupScopeEnv env v = lookupVarEnv (scope env) v extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] } @@ -329,11 +335,11 @@ scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') -> 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 @@ -369,19 +375,21 @@ scExpr env e@(App _ _) ---------------------- scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind) scBind env (Rec [(fn,rhs)]) - | not (null val_bndrs) - = scExpr env' body `thenUs` \ (usg, body') -> + | notNull val_bndrs + = scExpr env_fn_body body `thenUs` \ (usg, body') -> let SCU { calls = calls, occs = occs } = usg in specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) -> - returnUs (extendBndrs env bndrs, + returnUs (extendBndr env fn, -- For the body of the letrec, just + -- extend the env with Other to record + -- that it's in scope; no funny RecFun business SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs}, Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs)) where (bndrs,body) = collectBinders rhs val_bndrs = filter isId bndrs - env' = extendRecBndr env fn bndrs + env_fn_body = extendRecBndr env fn bndrs scBind env (Rec prs) = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') -> @@ -424,7 +432,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs}) 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 @@ -434,7 +442,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs}) (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 @@ -481,8 +489,8 @@ spec_one :: ScEnv 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 @@ -494,13 +502,31 @@ spec_one env fn rhs (pats, n) -- 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 = 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) 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} %************************************************************************ @@ -534,7 +560,7 @@ argToPat env us (Var v) -- Don't uniqify existing vars, = (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 @@ -556,8 +582,8 @@ is_con_app_maybe env (Lit lit) is_con_app_maybe env expr = case collectArgs expr of - (Var fun, args) | Just con <- isDataConId_maybe fun, - length args >= dataConRepArity con + (Var fun, args) | Just con <- isDataConWorkId_maybe fun, + args `lengthAtLeast` dataConRepArity con -- Might be > because the arity excludes type args -> Just (DataAlt con,args)