2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
14 isUnboxedSpecialisation,
19 argTysMatchSpecTys_error,
26 import Bag ( isEmptyBag, bagToList )
27 import Class ( getClassOpString, GenClass{-instance NamedThing-} )
28 import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
31 import Id ( idType, isDictFunId, isConstMethodId_maybe,
32 isDefaultMethodId_maybe,
33 GenId {-instance NamedThing -}
35 import Maybes ( maybeToBool, catMaybes, firstJust )
36 import Name ( isLexVarSym, pprNonSym, moduleNamePair )
37 import PprStyle ( PprStyle(..) )
38 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
39 TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
41 import PrelMods ( fromPrelude, pRELUDE )
42 import Pretty -- plenty of it
43 import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
44 import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys,
45 getTyVar_maybe, isUnboxedType
47 import TyVar ( GenTyVar{-instance Eq-} )
48 import Unique ( Unique{-instance Eq-} )
49 import Util ( equivClasses, zipWithEqual, cmpPString,
50 assertPanic, panic{-ToDo:rm-}
53 cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
54 mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
55 getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
56 specialiseTy :: Type -> [Maybe Type] -> Int -> Type
57 specialiseTy = panic "SpecUtils.specialiseTy (ToDo)"
60 @specialiseCallTys@ works out which type args don't need to be specialised on,
61 based on flags, the overloading constraint vector, and the types.
64 specialiseCallTys :: Bool -- Specialise on all type args
65 -> Bool -- Specialise on unboxed type args
66 -> Bool -- Specialise on overloaded type args
67 -> ConstraintVector -- Tells which type args are overloaded
68 -> [Type] -- Type args
69 -> [Maybe Type] -- Nothings replace non-specialised type args
71 specialiseCallTys True _ _ cvec tys
73 specialiseCallTys False spec_unboxed spec_overloading cvec tys
74 = zipWithEqual spec_ty_other cvec tys
76 spec_ty_other c ty | (spec_unboxed && isUnboxedType ty)
77 || (spec_overloading && c)
83 @getIdOverloading@ grabs the type of an Id, and returns a
84 list of its polymorphic variables, and the initial segment of
85 its ThetaType, in which the classes constrain only type variables.
86 For example, if the Id's type is
88 forall a,b,c. Eq a -> Ord [a] -> tau
94 This seems curious at first. For a start, the type above looks odd,
95 because we usually only have dictionary args whose types are of
96 the form (C a) where a is a type variable. But this doesn't hold for
97 the functions arising from instance decls, which sometimes get
98 arguements with types of form (C (T a)) for some type constructor T.
100 Should we specialise wrt this compound-type dictionary? This is
101 a heuristic judgement, as indeed is the fact that we specialise wrt
102 only dictionaries. We choose *not* to specialise wrt compound dictionaries
103 because at the moment the only place they show up is in instance decls,
104 where they are simply plugged into a returned dictionary. So nothing is
105 gained by specialising wrt them.
108 getIdOverloading :: Id
109 -> ([TyVar], [(Class,TyVar)])
111 = (tyvars, tyvar_part_of theta)
113 (tyvars, theta, _) = splitSigmaTy (idType id)
115 tyvar_part_of [] = []
116 tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
118 Just tv -> (c, tv) : tyvar_part_of theta
122 type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
124 mkConstraintVector :: Id
127 mkConstraintVector id
128 = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
130 (tyvars, class_tyvar_pairs) = getIdOverloading id
131 constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
135 isUnboxedSpecialisation :: [Maybe Type] -> Bool
136 isUnboxedSpecialisation tys
139 is_unboxed (Just ty) = isUnboxedType ty
140 is_unboxed Nothing = False
143 @specialiseConstrTys@ works out which type args don't need to be
144 specialised on. We only speciailise on unboxed types.
147 specialiseConstrTys :: [Type]
150 specialiseConstrTys tys
151 = map maybe_unboxed_ty tys
153 maybe_unboxed_ty ty = case isUnboxedType ty of
159 mkSpecialisedCon :: Id -> [Type] -> Id
160 mkSpecialisedCon con tys
162 then mkSameSpecCon spec_tys con
165 spec_tys = specialiseConstrTys tys
166 spec_reqd = maybeToBool (firstJust spec_tys)
169 @argTysMatchSpecTys@ checks if a list of argument types is consistent
170 with a list of specialising types. An error message is returned if not.
172 argTysMatchSpecTys_error :: [Maybe Type]
175 argTysMatchSpecTys_error spec_tys arg_tys
176 = if match spec_tys arg_tys
178 else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
179 ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
180 ppStr "argtys=", ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]])
182 match (Nothing:spec_tys) (arg:arg_tys)
183 = not (isUnboxedType arg) &&
184 match spec_tys arg_tys
185 match (Just spec:spec_tys) (arg:arg_tys)
186 = case (cmpType True{-properly-} spec arg) of
187 EQ_ -> match spec_tys arg_tys
193 @pprSpecErrs@ prints error and warning information
194 about imported specialisations which do not exist.
197 pprSpecErrs :: FAST_STRING -- module name
198 -> (Bag (Id,[Maybe Type])) -- errors
199 -> (Bag (Id,[Maybe Type])) -- warnings
200 -> (Bag (TyCon,[Maybe Type])) -- errors
203 pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
204 | not any_errs && not any_warn
209 ppStr "SPECIALISATION MESSAGES:",
210 ppAboves (map pp_module_specs use_modules)
213 any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
214 any_warn = not (isEmptyBag spec_warn)
216 mk_module_fm get_mod_data errs_bag
217 = addListToFM_C (++) emptyFM errs_list
219 errs_list = map get_mod_data (bagToList errs_bag)
221 tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
223 iderrs_fm = mk_module_fm (get_id_data True) spec_errs
224 idwarn_fm = mk_module_fm (get_id_data False) spec_warn
225 idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
227 get_id_data is_err (id, tys)
228 = (mod_name, [(id_name, id, tys, is_err)])
230 (mod_name, id_name) = get_id_name id
233 | maybeToBool (isDefaultMethodId_maybe id)
236 | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
237 = let get_mod = getInstIdModule id
238 use_mod = if fromPrelude get_mod
246 get_ty_data (ty, tys)
247 = (mod_name, [(ty_name, ty, tys)])
249 (mod_name,ty_name) = moduleNamePair ty
251 module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
252 mods = map head (equivClasses _CMP_STRING_ module_names)
254 (unks, known) = if null mods
256 else case _CMP_STRING_ (head mods) _NIL_ of
257 EQ_ -> ([_NIL_], tail mods)
260 (prels, others) = partition fromPrelude known
261 use_modules = unks ++ prels ++ others
263 pp_module_specs :: FAST_STRING -> Pretty
266 = ASSERT (null mod_tyspecs)
267 ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
271 ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
272 ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
279 mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
280 mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
281 have_specs = not (null mod_tyspecs && null mod_idspecs)
282 ty_sty = PprInterface
285 = ppBesides [ppPStr mod, ppStr ":"]
287 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
289 pp_tyspec sty pp_mod (_, tycon, tys)
291 ppStr "{-# SPECIALIZE", ppStr "data",
292 pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys),
293 ppStr "#-}", ppStr "{- Essential -}"
296 tvs = tyConTyVars tycon
297 (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
298 spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
300 choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
301 choose_ty (tv, Just ty) = (ty, Nothing)
303 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
305 pp_idspec sty pp_mod (_, id, tys, is_err)
308 ppStr "{-# SPECIALIZE",
310 pprGenType sty spec_ty,
311 ppStr "#-}", pp_essential ]
315 Just (cls, clsty, clsop) = const_method_maybe
316 (_, cls_str) = moduleNamePair cls
317 clsop_str = getClassOpString clsop
320 ppStr "{-# SPECIALIZE",
321 pp_clsop clsop_str, ppStr "::",
322 pprGenType sty spec_ty,
323 ppStr "#-} {- IN instance",
324 ppPStr cls_str, pprParendGenType sty clsty,
325 ppStr "-}", pp_essential ]
327 | is_default_method_id
329 Just (cls, clsop, _) = default_method_maybe
330 (_, cls_str) = moduleNamePair cls
331 clsop_str = getClassOpString clsop
336 ppStr "EXPLICIT METHOD REQUIRED",
337 pp_clsop clsop_str, ppStr "::",
338 pprGenType sty spec_ty,
339 ppStr "-}", pp_essential ]
343 ppStr "{-# SPECIALIZE",
344 pprNonSym PprForUser id, ppStr "::",
345 pprGenType sty spec_ty,
346 ppStr "#-}", pp_essential ]
348 spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
349 pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
351 const_method_maybe = isConstMethodId_maybe id
352 is_const_method_id = maybeToBool const_method_maybe
354 default_method_maybe = isDefaultMethodId_maybe id
355 is_default_method_id = maybeToBool default_method_maybe
357 pp_clsop str | isLexVarSym str
358 = ppBesides [ppLparen, ppPStr str, ppRparen]