projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2003-11-13 15:02:25 by simonpj]
[ghc-hetmet.git]
/
ghc
/
compiler
/
specialise
/
Specialise.lhs
diff --git
a/ghc/compiler/specialise/Specialise.lhs
b/ghc/compiler/specialise/Specialise.lhs
index
746814f
..
006e06d
100644
(file)
--- a/
ghc/compiler/specialise/Specialise.lhs
+++ b/
ghc/compiler/specialise/Specialise.lhs
@@
-9,9
+9,9
@@
module Specialise ( specProgram ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..) )
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..) )
-import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import Id ( Id, idName, idType, mkUserLocal )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
- tyVarsOfTypes, tyVarsOfTheta,
+ tyVarsOfTypes, tyVarsOfTheta, isClassPred,
mkForAllTys, tcCmpType
)
import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
mkForAllTys, tcCmpType
)
import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
@@
-25,8
+25,8
@@
import VarEnv
import CoreSyn
import CoreUtils ( applyTypeToArgs )
import CoreFVs ( exprFreeVars, exprsFreeVars )
import CoreSyn
import CoreUtils ( applyTypeToArgs )
import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
import CoreLint ( showPass, endPass )
import CoreLint ( showPass, endPass )
-import PprCore ( pprCoreRules )
import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
@@
-41,9
+41,9
@@
import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
import Bag
import List ( partition )
import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
- equalLength, lengthAtLeast )
+ equalLength, lengthAtLeast, notNull )
import Outputable
import Outputable
-
+import FastString
infixr 9 `thenSM`
\end{code}
infixr 9 `thenSM`
\end{code}
@@
-586,7
+586,7
@@
specProgram dflags us binds
endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
endPass dflags "Specialise" 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
return binds'
where
@@
-601,8
+601,6
@@
specProgram dflags us binds
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-788,9
+786,7
@@
specDefn subst calls (fn, rhs)
-- The first case is the interesting one
| rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
&& rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
-- The first case is the interesting one
| rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
&& rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
- && not (null calls_for_me) -- And there are some calls to specialise
- && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have
- -- stupid overloading that simply discard the dictionary
+ && notNull calls_for_me -- And there are some calls to specialise
-- At one time I tried not specialising small functions
-- but sometimes there are big functions marked INLINE
-- At one time I tried not specialising small functions
-- but sometimes there are big functions marked INLINE
@@
-889,7
+885,7
@@
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
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 = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+ spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
AlwaysActive
(poly_tyvars ++ rhs_dicts')
inst_args
AlwaysActive
(poly_tyvars ++ rhs_dicts')
inst_args
@@
-1005,6
+1001,10
@@
callDetailsToList calls = [ (id,tys,dicts)
mkCallUDs subst f args
| null theta
mkCallUDs subst f args
| null theta
+ || not (all isClassPred theta)
+ -- Only specialise if all overloading is on class params.
+ -- In ptic, with implicit params, the type args
+ -- *don't* say what the value of the implicit param is!
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
|| maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
|| maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
@@
-1027,10
+1027,9
@@
mkCallUDs subst f args
spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
- mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
- = Just ty
- | otherwise
- = Nothing
+ mk_spec_ty tyvar ty
+ | tyvar `elemVarSet` constrained_tyvars = Just ty
+ | otherwise = Nothing
------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails