X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=a1c602daf33ffaab7eeaa822f8fecfc9ba7aa740;hb=9dfbc2dadf268996963feeb8667eb2d0b0f30634;hp=e550294fbb719f4523ed97701c292868e001c5dd;hpb=c4f3290f3d4c2a5c2e81a97717f7fd06ee180f6d;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index e550294..a1c602d 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -4,10 +4,7 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -module Specialise ( - specProgram, - idSpecVars - ) where +module Specialise ( specProgram ) where #include "HsVersions.h" @@ -26,7 +23,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy, tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys ) import TyCon ( TyCon ) -import TyVar ( TyVar, mkTyVar, +import TyVar ( TyVar, mkTyVar, mkSysTyVar, TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets, elementOfTyVarSet, unionTyVarSets, emptyTyVarSet, minusTyVarSet, @@ -34,8 +31,9 @@ import TyVar ( TyVar, mkTyVar, ) import Kind ( mkBoxedTypeKind ) import CoreSyn +import FreeVars ( exprFreeVars ) import PprCore () -- Instances -import Name ( NamedThing(..), getSrcLoc, mkSysLocalName ) +import Name ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined ) import SrcLoc ( noSrcLoc ) import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues ) @@ -44,7 +42,7 @@ import UniqSupply ( UniqSupply, ) import Unique ( mkAlphaTyVarUnique ) import FiniteMap -import Maybes ( MaybeErr(..), maybeToBool ) +import Maybes ( MaybeErr(..), maybeToBool, catMaybes ) import Bag import List ( partition ) import Util ( zipEqual ) @@ -721,7 +719,13 @@ specBind (NonRec bndr rhs) body_uds specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> let (all_uds, (dict_binds, dump_calls)) - = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds) + = splitUDs [ValBinder bndr] + (body_uds `plusUDs` spec_uds) + -- It's important that the `plusUDs` is this way round, + -- because body_uds may bind dictionaries that are + -- used in the calls passed to specDefn. So the + -- dictionary bindings in spec_uds may mention + -- dictionaries bound in body_uds. -- If we make specialisations then we Rec the whole lot together -- If not, leave it as a NonRec @@ -736,8 +740,12 @@ specBind (Rec pairs) body_uds (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff spec_defns = concat spec_defns_s spec_uds = plusUDList spec_uds_s + (all_uds, (dict_binds, dump_calls)) - = splitUDs (map (ValBinder . fst) pairs) (spec_uds `plusUDs` body_uds) + = splitUDs (map (ValBinder . fst) pairs) + (body_uds `plusUDs` spec_uds) + -- See notes for non-rec case + new_bind = Rec (spec_defns ++ pairs') in returnSM ( new_bind : mkDictBinds dict_binds, all_uds ) @@ -782,10 +790,6 @@ specDefn calls (fn, rhs) (tyvars, theta, tau) = splitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta - mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyVarTemplates - where - mk_spec_ty (Just ty) _ = ty - mk_spec_ty Nothing tyvar = mkTyVarTy tyvar (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs rhs_dicts = take n_dicts rhs_ids @@ -815,8 +819,14 @@ specDefn calls (fn, rhs) -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2 -- and the type of this binder let - spec_tyvars = [tyvar | (tyvar, Nothing) <- tyVarTemplates `zip` call_ts] - spec_tys = mk_spec_tys call_ts + mk_spec_ty Nothing = newTyVarSM `thenSM` \ tyvar -> + returnSM (Just tyvar, mkTyVarTy tyvar) + mk_spec_ty (Just ty) = returnSM (Nothing, ty) + in + mapSM mk_spec_ty call_ts `thenSM` \ stuff -> + let + (maybe_spec_tyvars, spec_tys) = unzip stuff + spec_tyvars = catMaybes maybe_spec_tyvars spec_rhs = mkTyLam spec_tyvars $ mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds) spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau) @@ -881,6 +891,9 @@ data UsageDetails } type DictBind = (DictVar, CoreExpr, TyVarSet, FreeDicts) + -- The FreeDicts are the free dictionaries (only) + -- of the RHS of the dictionary bindings + -- Similarly the TyVarSet emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } @@ -1067,40 +1080,13 @@ specUDs tv_env_list dict_env_list (dbs, calls) %************************************************************************ \begin{code} -tyVarTemplates :: [TyVar] -tyVarTemplates = map mk [1..] - where - mk i = mkTyVar (mkSysLocalName uniq occ noSrcLoc) mkBoxedTypeKind - where - uniq = mkAlphaTyVarUnique i - occ = _PK_ ("$t" ++ show i) -\end{code} - -\begin{code} lookupId:: IdEnv Id -> Id -> Id lookupId env id = case lookupIdEnv env id of Nothing -> id Just id' -> id' dictRhsFVs :: CoreExpr -> IdSet - -- Cheapo function for simple RHSs -dictRhsFVs e - = go e - where - go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a - go (App e1 (LitArg l)) = go e1 - go (App e1 (TyArg t)) = go e1 - go (Var v) = unitIdSet v - go (Lit l) = emptyIdSet - go (Con _ args) = mkIdSet [id | VarArg id <- args] - go (Note _ e) = go e - - go (Case e _) = go e -- Claim: no free dictionaries in the alternatives - -- These case expressions are of the form - -- case d of { D a b c -> b } - - go other = pprPanic "dictRhsFVs" (ppr e) - +dictRhsFVs e = exprFreeVars isLocallyDefined e addIdSpecialisations id spec_stuff = (if not (null errs) then @@ -1116,22 +1102,6 @@ addIdSpecialisations id spec_stuff Succeeded spec_env' -> (spec_env', errs) Failed err -> (spec_env, err:errs) --- Given an Id, isSpecVars returns all its specialisations. --- We extract these from its SpecEnv. --- This is used by the occurrence analyser and free-var finder; --- we regard an Id's specialisations as free in the Id's definition. - -idSpecVars :: Id -> [Id] -idSpecVars id - = map get_spec (specEnvValues (getIdSpecialisation id)) - where - -- get_spec is another cheapo function like dictRhsFVs - -- It knows what these specialisation temlates look like, - -- and just goes for the jugular - get_spec (App f _) = get_spec f - get_spec (Lam _ b) = get_spec b - get_spec (Var v) = v - ---------------------------------------- type SpecM a = UniqSM a @@ -1153,6 +1123,10 @@ newIdSM old_id new_ty new_ty (getSrcLoc old_id) ) + +newTyVarSM + = getUnique `thenSM` \ uniq -> + returnSM (mkSysTyVar uniq mkBoxedTypeKind) \end{code}