From 12e6a9a58473f8b24e831c2171bf62d256da8a85 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 28 Feb 2001 11:48:35 +0000 Subject: [PATCH] [project @ 2001-02-28 11:48:34 by simonpj] Add most of the code for constructor specialisation. The comment below is reproduced from specialise/SpecConstr.lhs. It doesn't quite work properly yet, because we need to have rules in scope in a recursive function's own RHS, and that entails a bit of fiddling I havn't yet completed. But SpecConstr itself is a nice neat 250 lines of code. ----------------------------------------------------- Game plan ----------------------------------------------------- Consider drop n [] = [] drop 0 xs = [] drop n (x:xs) = drop (n-1) xs After the first time round, we could pass n unboxed. This happens in numerical code too. Here's what it looks like in Core: drop n xs = case xs of [] -> [] (y:ys) -> case n of I# n# -> case n# of 0 -> [] _ -> drop (I# (n# -# 1#)) xs Notice that the recursive call has an explicit constructor as argument. Noticing this, we can make a specialised version of drop RULE: drop (I# n#) xs ==> drop' n# xs drop' n# xs = let n = I# n# in ...orig RHS... Now the simplifier will apply the specialisation in the rhs of drop', giving drop' n# xs = case xs of [] -> [] (y:ys) -> case n# of 0 -> [] _ -> drop (n# -# 1#) xs Much better! We'd also like to catch cases where a parameter is carried along unchanged, but evaluated each time round the loop: f i n = if i>0 || i>n then i else f (i*2) n Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. In Core, by the time we've w/wd (f is strict in i) we get f i# n = case i# ># 0 of False -> I# i# True -> case n of n' { I# n# -> case i# ># n# of False -> I# i# True -> f (i# *# 2#) n' At the call to f, we see that the argument, n is know to be (I# n#), and n is evaluated elsewhere in the body of f, so we can play the same trick as above. However we don't want to do that if the boxed version of n is needed (else we'd avoid the eval but pay more for re-boxing n). So in this case we want that the *only* uses of n are in case statements. So we look for * A self-recursive function. Ignore mutual recursion for now, because it's less common, and the code is simpler for self-recursion. * EITHER a) At a recursive call, one or more parameters is an explicit constructor application AND That same parameter is scrutinised by a case somewhere in the RHS of the function OR b) At a recursive call, one or more parameters has an unfolding that is an explicit constructor application AND That same parameter is scrutinised by a case somewhere in the RHS of the function AND Those are the only uses of the parameter --- ghc/compiler/main/CmdLineOpts.lhs | 1 + ghc/compiler/main/DriverState.hs | 6 +- ghc/compiler/simplCore/SimplCore.lhs | 3 + ghc/compiler/specialise/Rules.lhs | 11 +- ghc/compiler/specialise/SpecConstr.lhs | 454 ++++++++++++++++++++++++++++++++ ghc/compiler/specialise/Specialise.lhs | 21 +- 6 files changed, 479 insertions(+), 17 deletions(-) create mode 100644 ghc/compiler/specialise/SpecConstr.lhs diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 4442443..2aa9453 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -185,6 +185,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoStrictness | CoreDoWorkerWrapper | CoreDoSpecialising + | CoreDoSpecConstr | CoreDoUSPInf | CoreDoCPResult | CoreDoGlomBinds diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index f07872a..3dc7951 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.29 2001/02/21 11:36:01 simonmar Exp $ +-- $Id: DriverState.hs,v 1.30 2001/02/28 11:48:34 simonpj Exp $ -- -- Settings for the driver -- @@ -280,6 +280,10 @@ buildCoreToDo = do CoreLiberateCase else CoreDoNothing, + if opt_level >= 2 then + CoreDoSpecConstr + else + CoreDoNothing, -- Final clean-up simplification: CoreDoSimplify (isAmongSimpl [ diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 498de9f..6c07ba9 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -37,6 +37,7 @@ import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) +import SpecConstr ( specConstrProgram) import UsageSPInf ( doUsageSPInf ) import StrictAnal ( saBinds ) import WorkWrap ( wwTopBinds ) @@ -157,6 +158,8 @@ doCorePass dfs rb us binds CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds) doCorePass dfs rb us binds CoreDoSpecialising = _scc_ "Specialise" noStats dfs (specProgram dfs us binds) +doCorePass dfs rb us binds CoreDoSpecConstr + = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds) doCorePass dfs rb us binds CoreDoCPResult = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) doCorePass dfs rb us binds CoreDoPrintCore diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 9fa7381..8d8819a 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -423,13 +423,12 @@ insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) -addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id -addIdSpecialisations id spec_stuff - = setIdSpecialisation id new_rules +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + = setIdSpecialisation id new_specs where - rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (idSpecialisation id) spec_stuff - add (vars, args, rhs) rules = addRule rules id (Rule rule_name vars args rhs) + new_specs = foldr add (idSpecialisation id) rules + add rule rules = addRule rules id rule \end{code} diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs new file mode 100644 index 0000000..0d75895 --- /dev/null +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -0,0 +1,454 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[SpecConstr]{Specialise over constructors} + +\begin{code} +module SpecConstr( + specConstrProgram + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreLint ( showPass, endPass ) +import CoreUtils ( exprType, exprIsConApp_maybe, eqExpr ) +import CoreFVs ( exprsFreeVars ) +import DataCon ( isExistentialDataCon ) +import PprCore ( pprCoreRules ) +import Id ( Id, idName, idSpecialisation, mkUserLocal, mkSysLocal ) +import Var ( Var ) +import VarEnv +import VarSet +import Name ( nameOccName, nameSrcLoc ) +import Rules ( addIdSpecialisations ) +import OccName ( mkSpecOcc ) +import ErrUtils ( dumpIfSet_dyn ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import Outputable + +import Maybes ( orElse ) +import Util ( mapAccumL ) +import List ( nubBy, partition ) +import UniqSupply +import Outputable +\end{code} + +----------------------------------------------------- + Game plan +----------------------------------------------------- + +Consider + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs + +After the first time round, we could pass n unboxed. This happens in +numerical code too. Here's what it looks like in Core: + + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs + +Notice that the recursive call has an explicit constructor as argument. +Noticing this, we can make a specialised version of drop + + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... + +Now the simplifier will apply the specialisation in the rhs of drop', giving + + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop (n# -# 1#) xs + +Much better! + +We'd also like to catch cases where a parameter is carried along unchanged, +but evaluated each time round the loop: + + f i n = if i>0 || i>n then i else f (i*2) n + +Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. +In Core, by the time we've w/wd (f is strict in i) we get + + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of n' { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n' + +At the call to f, we see that the argument, n is know to be (I# n#), +and n is evaluated elsewhere in the body of f, so we can play the same +trick as above. However we don't want to do that if the boxed version +of n is needed (else we'd avoid the eval but pay more for re-boxing n). +So in this case we want that the *only* uses of n are in case statements. + + +So we look for + +* A self-recursive function. Ignore mutual recursion for now, + because it's less common, and the code is simpler for self-recursion. + +* EITHER + + a) At a recursive call, one or more parameters is an explicit + constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + + OR + + b) At a recursive call, one or more parameters has an unfolding + that is an explicit constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + AND + Those are the only uses of the parameter + + +There's a bit of a complication with type arguments. If the call +site looks like + + f p = ...f ((:) [a] x xs)... + +then our specialised function look like + + f_spec x xs = let p = (:) [a] x xs in ....as before.... + +This only makes sense if either + a) the type variable 'a' is in scope at the top of f, or + b) the type variable 'a' is an argument to f (and hence fs) + +Actually, (a) may hold for value arguments too, in which case +we may not want to pass them. Supose 'x' is in scope at f's +defn, but xs is not. Then we'd like + + f_spec xs = let p = (:) [a] x xs in ....as before.... + +Similarly (b) may hold too. If x is already an argument at the +call, no need to pass it again. + +Finally, if 'a' is not in scope at the call site, we could abstract +it as we do the term variables: + + f_spec a x xs = let p = (:) [a] x xs in ...as before... + +So the grand plan is: + + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + + * Find the free variables of the abstracted pattern + + * Pass these variables, less any that are in scope at + the fn defn. + + +NOTICE that we only abstract over variables that are not in scope, +so we're in no danger of shadowing variables used in "higher up" +in f_spec's RHS. + + +%************************************************************************ +%* * +\subsection{Top level wrapper stuff} +%* * +%************************************************************************ + +\begin{code} +specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] +specConstrProgram dflags us binds + = do + showPass dflags "SpecConstr" + + let (binds', _) = initUs us (go emptyScEnv 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')))) + + return binds' + where + go env [] = returnUs [] + 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} + + +%************************************************************************ +%* * +\subsection{Environments and such} +%* * +%************************************************************************ + +\begin{code} +type ScEnv = VarEnv HowBound + +emptyScEnv = emptyVarEnv + +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns + | RecArg -- These are those functions' arguments; we are + -- interested to see if those arguments are scrutinised + | Other -- We track all others so we know what's in scope + +extendBndrs env bndrs = extendVarEnvList env [(b,Other) | b <- bndrs] +extendBndr env bndr = extendVarEnv env bndr Other + +data ScUsage + = SCU { + calls :: !(IdEnv ([[CoreArg]])), -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv + + occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The variables are a subset of the + -- RecArg in the ScEnv + +nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv } + +combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2), + occs = plusVarEnv_C combineOcc (occs u1) (occs u2) } + +combineUsages [] = nullUsage +combineUsages us = foldr1 combineUsage us + +data ArgOcc = CaseScrut + | OtherOcc + | Both + +instance Outputable ArgOcc where + ppr CaseScrut = ptext SLIT("case-scrut") + ppr OtherOcc = ptext SLIT("other-occ") + ppr Both = ptext SLIT("case-scrut and other") + +combineOcc CaseScrut CaseScrut = CaseScrut +combineOcc OtherOcc OtherOcc = OtherOcc +combineOcc _ _ = Both +\end{code} + + +%************************************************************************ +%* * +\subsection{The main recursive function} +%* * +%************************************************************************ + +\begin{code} +scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args + +scExpr env e@(Type t) = returnUs (nullUsage, e) +scExpr env e@(Lit l) = returnUs (nullUsage, e) +scExpr env e@(Var v) = returnUs (varUsage env v OtherOcc, e) +scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') -> + returnUs (usg, Note n 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) + = 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') + where + sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e) + sc_scrut e = scExpr env e + + sc_alt (con,bs,rhs) = scExpr env rhs `thenUs` \ (usg,rhs') -> + returnUs (usg, (con,bs,rhs')) + where + env1 = extendBndrs env (b:bs) + +scExpr env (Let bind body) + = scBind env bind `thenUs` \ (env', bind_usg, bind') -> + scExpr env' body `thenUs` \ (body_usg, body') -> + returnUs (bind_usg `combineUsage` body_usg, Let bind' body') + +scExpr env e@(App _ _) + = let + (fn, args) = collectArgs e + in + mapAndUnzipUs (scExpr env) args `thenUs` \ (usgs, args') -> + let + arg_usg = combineUsages usgs + fn_usg | Var f <- fn, + Just RecFun <- lookupVarEnv env f + = SCU { calls = unitVarEnv f [args], occs = emptyVarEnv } + | otherwise + = nullUsage + in + returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args') + -- Don't bother to look inside fn; + -- it's almost always a variable + +---------------------- +scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind) +scBind env (Rec [(fn,rhs)]) + | not (null val_bndrs) + = scExpr env' body `thenUs` \ (usg@(SCU { calls = calls, occs = occs }), body') -> + specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) -> + returnUs (extendBndrs env bndrs, + 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' = env `extendVarEnvList` ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) + +scBind env (Rec prs) + = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') -> + returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs') + where + do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') -> + returnUs (usg, (bndr,rhs')) + +scBind env (NonRec bndr rhs) + = scExpr env rhs `thenUs` \ (usg, rhs') -> + returnUs (extendBndr env bndr, usg, NonRec bndr rhs') + +---------------------- +varUsage env v use + | Just RecArg <- lookupVarEnv env v = SCU { calls = emptyVarEnv, occs = unitVarEnv v use } + | otherwise = nullUsage +\end{code} + + +%************************************************************************ +%* * +\subsection{The specialiser} +%* * +%************************************************************************ + +\begin{code} +specialise :: ScEnv + -> Id -- Functionn + -> [CoreBndr] -> CoreExpr -- Its RHS + -> ScUsage -- Info on usage + -> UniqSM ([CoreRule], -- Rules + [(Id,CoreExpr)]) -- Bindings + +specialise env fn bndrs body (SCU {calls=calls, occs=occs}) + = getUs `thenUs` \ us -> + let + all_calls = lookupVarEnv calls fn `orElse` [] + + good_calls :: [[CoreArg]] + good_calls = [ pats + | call_args <- all_calls, + length call_args >= n_bndrs, -- App is saturated + let call = (bndrs `zip` call_args), + any (good_arg occs) call, + let (_, pats) = argsToPats us call_args + ] + in + pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $ + mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) + (nubBy same_call good_calls `zip` [1..]) + where + n_bndrs = length bndrs + same_call as1 as2 = and (zipWith eqExpr as1 as2) + +--------------------- +good_arg :: IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool +good_arg arg_occs (bndr, arg) + = case exprIsConApp_maybe arg of -- exprIsConApp_maybe looks + Just (dc,_) -> not (isExistentialDataCon dc) -- through unfoldings + && bndr_usg_ok arg_occs bndr arg + other -> False + +bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool +bndr_usg_ok arg_occs bndr arg + = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $ + case lookupVarEnv arg_occs bndr of + Just CaseScrut -> True -- Used only by case scrutiny + Just Both -> case arg of -- Used by case and elsewhere + App _ _ -> True -- so the arg should be an explicit con app + other -> False + other -> False -- Not used, or used wonkily + + +--------------------- +argsToPats :: UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr]) +argsToPats us args = mapAccumL argToPat us args + +argToPat :: UniqSupply -> CoreArg -> (UniqSupply, CoreExpr) +-- C a (D (f x) (g y)) ==> C p1 (D p2 p3) +argToPat us (Type ty) + = (us, Type ty) + +argToPat us arg + | Just (dc,args) <- exprIsConApp_maybe arg + = let + (us',args') = argsToPats us args + in + (us', mkConApp dc args') + +argToPat us (Var v) -- Don't uniqify existing vars, + = (us, Var v) -- so that we can spot when we pass them twice + +argToPat us arg + = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg))) + where + (us1,us2) = splitUniqSupply us + +--------------------- +spec_one :: ScEnv + -> Id -- Function + -> CoreExpr -- Rhs of the original function + -> ([CoreArg], Int) + -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding + +{- + Example + + In-scope: a, x::a + f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) v (h v))... + [c is presumably bound by the (...) part] + ==> + f_spec = /\ b c \ v::(a,(b,c)) -> + (...entire RHS of f...) (b,c) ((:) (a,(b,c)) v (h v)) + + RULE: forall b c, + y::[(a,(b,c))], + v::(a,(b,c)), + h::(a,(b,c))->[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) v (h v)) = f_spec b c v +-} + +spec_one env fn rhs (pats, n) + = getUniqueUs `thenUs` \ spec_uniq -> + let + fn_name = idName fn + fn_loc = nameSrcLoc fn_name + spec_occ = mkSpecOcc (nameOccName fn_name) + pat_fvs = varSetElems (exprsFreeVars pats) + vars_to_bind = filter not_avail pat_fvs + not_avail v = not (v `elemVarEnv` env) + -- Put the type variables first just for tidiness + (tvs, ids) = partition isTyVar vars_to_bind + bndrs = tvs ++ ids + + 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 pat_fvs pats (mkVarApps (Var spec_id) bndrs) + in + returnUs (rule, (spec_id, spec_rhs)) +\end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 6fbc5b9..bdef352 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -34,7 +34,7 @@ import PprCore ( pprCoreRules ) import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, - UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, + UniqSM, initUs_, thenUs, thenUs, returnUs, getUniqueUs, withUs, mapUs ) import Name ( nameOccName, mkSpecOcc, getSrcLoc ) @@ -800,9 +800,9 @@ specDefn subst calls (fn, rhs) -- Make a specialised version for each call in calls_for_me mapSM spec_call calls_for_me `thenSM` \ stuff -> let - (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff + (spec_defns, spec_uds, spec_rules) = unzip3 stuff - fn' = addIdSpecialisations zapped_fn spec_env_stuff + fn' = addIdSpecialisations zapped_fn spec_rules in returnSM ((fn',rhs'), spec_defns, @@ -835,10 +835,10 @@ specDefn subst calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance - -> SpecM ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv + spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance + -> SpecM ((Id,CoreExpr), -- Specialised definition + UsageDetails, -- Usage details from specialised body + CoreRule) -- Info for the Id's SpecEnv spec_call (call_ts, (call_ds, call_fvs)) = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) -- Calls are only recorded for properly-saturated applications @@ -880,9 +880,10 @@ specDefn subst calls (fn, rhs) let -- The rule to put in the function's specialisation is: -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d - spec_env_rule = (poly_tyvars ++ rhs_dicts', - inst_args, - mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars)) + spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn))) + (poly_tyvars ++ rhs_dicts') + inst_args + (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars)) -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds) -- 1.7.10.4