\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-module Specialise (
- specProgram,
- idSpecVars
- ) where
+module Specialise ( specProgram ) where
#include "HsVersions.h"
tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
)
import TyCon ( TyCon )
-import TyVar ( TyVar, mkTyVar,
+import TyVar ( TyVar, mkTyVar, mkSysTyVar,
TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
minusTyVarSet,
)
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 )
)
import Unique ( mkAlphaTyVarUnique )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool )
+import Maybes ( MaybeErr(..), maybeToBool, catMaybes )
import Bag
import List ( partition )
import Util ( zipEqual )
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
(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 )
(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
-- 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)
}
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 }
%************************************************************************
\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
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
new_ty
(getSrcLoc old_id)
)
+
+newTyVarSM
+ = getUnique `thenSM` \ uniq ->
+ returnSM (mkSysTyVar uniq mkBoxedTypeKind)
\end{code}
projects / ghc-hetmet.git / blobdiff