\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 Unique ( mkAlphaTyVarUnique )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool )
+import Maybes ( MaybeErr(..), maybeToBool, catMaybes )
import Bag
import List ( partition )
import Util ( zipEqual )
(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)
%************************************************************************
\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
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}