2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
14 isUnboxedSpecialisation,
19 argTysMatchSpecTys_error,
25 import Bag ( Bag, isEmptyBag, bagToList )
26 import FiniteMap ( FiniteMap, emptyFM, addListToFM_C,
27 plusFM_C, keysFM, lookupWithDefaultFM
29 import Id ( mkSameSpecCon, idType,
30 isDictFunId, isConstMethodId_maybe,
31 isDefaultMethodId_maybe,
39 @specialiseCallTys@ works out which type args don't need to be specialised on,
40 based on flags, the overloading constraint vector, and the types.
43 specialiseCallTys :: Bool -- Specialise on all type args
44 -> Bool -- Specialise on unboxed type args
45 -> Bool -- Specialise on overloaded type args
46 -> ConstraintVector -- Tells which type args are overloaded
47 -> [Type] -- Type args
48 -> [Maybe Type] -- Nothings replace non-specialised type args
50 specialiseCallTys True _ _ cvec tys
52 specialiseCallTys False spec_unboxed spec_overloading cvec tys
53 = zipWithEqual spec_ty_other cvec tys
55 spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
56 || (spec_overloading && c)
62 @getIdOverloading@ grabs the type of an Id, and returns a
63 list of its polymorphic variables, and the initial segment of
64 its ThetaType, in which the classes constrain only type variables.
65 For example, if the Id's type is
67 forall a,b,c. Eq a -> Ord [a] -> tau
73 This seems curious at first. For a start, the type above looks odd,
74 because we usually only have dictionary args whose types are of
75 the form (C a) where a is a type variable. But this doesn't hold for
76 the functions arising from instance decls, which sometimes get
77 arguements with types of form (C (T a)) for some type constructor T.
79 Should we specialise wrt this compound-type dictionary? This is
80 a heuristic judgement, as indeed is the fact that we specialise wrt
81 only dictionaries. We choose *not* to specialise wrt compound dictionaries
82 because at the moment the only place they show up is in instance decls,
83 where they are simply plugged into a returned dictionary. So nothing is
84 gained by specialising wrt them.
87 getIdOverloading :: Id
88 -> ([TyVarTemplate], [(Class,TyVarTemplate)])
90 = (tyvars, tyvar_part_of theta)
92 (tyvars, theta, _) = splitSigmaTy (idType id)
95 tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
97 Just tyvar -> (clas, tyvar) : tyvar_part_of theta
101 type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
103 mkConstraintVector :: Id
106 mkConstraintVector id
107 = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
109 (tyvars, class_tyvar_pairs) = getIdOverloading id
110 constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
114 isUnboxedSpecialisation :: [Maybe Type] -> Bool
115 isUnboxedSpecialisation tys
118 is_unboxed (Just ty) = isUnboxedDataType ty
119 is_unboxed Nothing = False
122 @specialiseConstrTys@ works out which type args don't need to be
123 specialised on. We only speciailise on unboxed types.
126 specialiseConstrTys :: [Type]
129 specialiseConstrTys tys
130 = map maybe_unboxed_ty tys
132 maybe_unboxed_ty ty = case isUnboxedDataType ty of
138 mkSpecialisedCon :: Id -> [Type] -> Id
139 mkSpecialisedCon con tys
141 then mkSameSpecCon spec_tys con
144 spec_tys = specialiseConstrTys tys
145 spec_reqd = maybeToBool (firstJust spec_tys)
148 @argTysMatchSpecTys@ checks if a list of argument types is consistent
149 with a list of specialising types. An error message is returned if not.
151 argTysMatchSpecTys_error :: [Maybe Type]
154 argTysMatchSpecTys_error spec_tys arg_tys
155 = if match spec_tys arg_tys
157 else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
158 ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
159 ppStr "argtys=", ppSep [pprParendType PprDebug ty | ty <- arg_tys]])
161 match (Nothing:spec_tys) (arg:arg_tys)
162 = not (isUnboxedDataType arg) &&
163 match spec_tys arg_tys
164 match (Just spec:spec_tys) (arg:arg_tys)
165 = case (cmpUniType True{-properly-} spec arg) of
166 EQ_ -> match spec_tys arg_tys
172 @pprSpecErrs@ prints error and warning information
173 about imported specialisations which do not exist.
176 pprSpecErrs :: FAST_STRING -- module name
177 -> (Bag (Id,[Maybe Type])) -- errors
178 -> (Bag (Id,[Maybe Type])) -- warnings
179 -> (Bag (TyCon,[Maybe Type])) -- errors
182 pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
183 | not any_errs && not any_warn
188 ppStr "SPECIALISATION MESSAGES:",
189 ppAboves (map pp_module_specs use_modules)
192 any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
193 any_warn = not (isEmptyBag spec_warn)
195 mk_module_fm get_mod_data errs_bag
196 = addListToFM_C (++) emptyFM errs_list
198 errs_list = map get_mod_data (bagToList errs_bag)
200 tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
202 iderrs_fm = mk_module_fm (get_id_data True) spec_errs
203 idwarn_fm = mk_module_fm (get_id_data False) spec_warn
204 idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
206 get_id_data is_err (id, tys)
207 = (mod_name, [(id_name, id, tys, is_err)])
209 (mod_name, id_name) = get_id_name id
212 | maybeToBool (isDefaultMethodId_maybe id)
215 | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
216 = let get_mod = getInstIdModule id
217 use_mod = if from_prelude get_mod
225 get_ty_data (ty, tys)
226 = (mod_name, [(ty_name, ty, tys)])
228 (mod_name,ty_name) = getOrigName ty
231 = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
233 module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
234 mods = map head (equivClasses _CMP_STRING_ module_names)
236 (unks, known) = if null mods
238 else case _CMP_STRING_ (head mods) _NIL_ of
239 EQ_ -> ([_NIL_], tail mods)
242 (prels, others) = partition from_prelude known
243 use_modules = unks ++ prels ++ others
245 pp_module_specs :: FAST_STRING -> Pretty
248 = ASSERT (null mod_tyspecs)
249 ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
253 ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
254 ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
261 mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
262 mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
263 have_specs = not (null mod_tyspecs && null mod_idspecs)
264 ty_sty = PprInterface (error "SpecUtils:PprInterface:sw_chkr")
267 = ppBesides [ppPStr mod, ppStr ":"]
269 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
271 pp_tyspec sty pp_mod (_, tycon, tys)
273 ppStr "{-# SPECIALIZE", ppStr "data",
274 pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
275 ppStr "#-}", ppStr "{- Essential -}"
278 tvs = getTyConTyVarTemplates tycon
279 (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
280 spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
282 choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
283 choose_ty (tv, Just ty) = (ty, Nothing)
285 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
287 pp_idspec sty pp_mod (_, id, tys, is_err)
290 ppStr "{-# SPECIALIZE",
293 ppStr "#-}", pp_essential ]
297 Just (cls, clsty, clsop) = const_method_maybe
298 (_, cls_str) = getOrigName cls
299 clsop_str = getClassOpString clsop
302 ppStr "{-# SPECIALIZE",
303 pp_clsop clsop_str, ppStr "::",
305 ppStr "#-} {- IN instance",
306 ppPStr cls_str, pprParendType sty clsty,
307 ppStr "-}", pp_essential ]
309 | is_default_method_id
311 Just (cls, clsop, _) = default_method_maybe
312 (_, cls_str) = getOrigName cls
313 clsop_str = getClassOpString clsop
318 ppStr "EXPLICIT METHOD REQUIRED",
319 pp_clsop clsop_str, ppStr "::",
321 ppStr "-}", pp_essential ]
325 ppStr "{-# SPECIALIZE",
326 pprNonOp PprForUser id, ppStr "::",
328 ppStr "#-}", pp_essential ]
330 spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
331 pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
333 const_method_maybe = isConstMethodId_maybe id
334 is_const_method_id = maybeToBool const_method_maybe
336 default_method_maybe = isDefaultMethodId_maybe id
337 is_default_method_id = maybeToBool default_method_maybe
339 pp_clsop str | isAvarop str
340 = ppBesides [ppLparen, ppPStr str, ppRparen]