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 ( isAvarop, pprNonOp, getOrigName )
37 import PprStyle ( PprStyle(..) )
38 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
39 TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
41 import Pretty -- plenty of it
42 import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
43 import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys,
44 getTyVar_maybe, isUnboxedType
46 import TyVar ( GenTyVar{-instance Eq-} )
47 import Unique ( Unique{-instance Eq-} )
48 import Util ( equivClasses, zipWithEqual, cmpPString,
49 assertPanic, panic{-ToDo:rm-}
52 cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
53 mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
54 getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
55 specialiseTy :: Type -> [Maybe Type] -> Int -> Type
56 specialiseTy = panic "SpecUtils.specialiseTy (ToDo)"
59 @specialiseCallTys@ works out which type args don't need to be specialised on,
60 based on flags, the overloading constraint vector, and the types.
63 specialiseCallTys :: Bool -- Specialise on all type args
64 -> Bool -- Specialise on unboxed type args
65 -> Bool -- Specialise on overloaded type args
66 -> ConstraintVector -- Tells which type args are overloaded
67 -> [Type] -- Type args
68 -> [Maybe Type] -- Nothings replace non-specialised type args
70 specialiseCallTys True _ _ cvec tys
72 specialiseCallTys False spec_unboxed spec_overloading cvec tys
73 = zipWithEqual spec_ty_other cvec tys
75 spec_ty_other c ty | (spec_unboxed && isUnboxedType ty)
76 || (spec_overloading && c)
82 @getIdOverloading@ grabs the type of an Id, and returns a
83 list of its polymorphic variables, and the initial segment of
84 its ThetaType, in which the classes constrain only type variables.
85 For example, if the Id's type is
87 forall a,b,c. Eq a -> Ord [a] -> tau
93 This seems curious at first. For a start, the type above looks odd,
94 because we usually only have dictionary args whose types are of
95 the form (C a) where a is a type variable. But this doesn't hold for
96 the functions arising from instance decls, which sometimes get
97 arguements with types of form (C (T a)) for some type constructor T.
99 Should we specialise wrt this compound-type dictionary? This is
100 a heuristic judgement, as indeed is the fact that we specialise wrt
101 only dictionaries. We choose *not* to specialise wrt compound dictionaries
102 because at the moment the only place they show up is in instance decls,
103 where they are simply plugged into a returned dictionary. So nothing is
104 gained by specialising wrt them.
107 getIdOverloading :: Id
108 -> ([TyVar], [(Class,TyVar)])
110 = (tyvars, tyvar_part_of theta)
112 (tyvars, theta, _) = splitSigmaTy (idType id)
114 tyvar_part_of [] = []
115 tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
117 Just tv -> (c, tv) : tyvar_part_of theta
121 type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
123 mkConstraintVector :: Id
126 mkConstraintVector id
127 = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
129 (tyvars, class_tyvar_pairs) = getIdOverloading id
130 constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
134 isUnboxedSpecialisation :: [Maybe Type] -> Bool
135 isUnboxedSpecialisation tys
138 is_unboxed (Just ty) = isUnboxedType ty
139 is_unboxed Nothing = False
142 @specialiseConstrTys@ works out which type args don't need to be
143 specialised on. We only speciailise on unboxed types.
146 specialiseConstrTys :: [Type]
149 specialiseConstrTys tys
150 = map maybe_unboxed_ty tys
152 maybe_unboxed_ty ty = case isUnboxedType ty of
158 mkSpecialisedCon :: Id -> [Type] -> Id
159 mkSpecialisedCon con tys
161 then mkSameSpecCon spec_tys con
164 spec_tys = specialiseConstrTys tys
165 spec_reqd = maybeToBool (firstJust spec_tys)
168 @argTysMatchSpecTys@ checks if a list of argument types is consistent
169 with a list of specialising types. An error message is returned if not.
171 argTysMatchSpecTys_error :: [Maybe Type]
174 argTysMatchSpecTys_error spec_tys arg_tys
175 = if match spec_tys arg_tys
177 else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
178 ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
179 ppStr "argtys=", ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]])
181 match (Nothing:spec_tys) (arg:arg_tys)
182 = not (isUnboxedType arg) &&
183 match spec_tys arg_tys
184 match (Just spec:spec_tys) (arg:arg_tys)
185 = case (cmpType True{-properly-} spec arg) of
186 EQ_ -> match spec_tys arg_tys
192 @pprSpecErrs@ prints error and warning information
193 about imported specialisations which do not exist.
196 pprSpecErrs :: FAST_STRING -- module name
197 -> (Bag (Id,[Maybe Type])) -- errors
198 -> (Bag (Id,[Maybe Type])) -- warnings
199 -> (Bag (TyCon,[Maybe Type])) -- errors
202 pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
203 | not any_errs && not any_warn
208 ppStr "SPECIALISATION MESSAGES:",
209 ppAboves (map pp_module_specs use_modules)
212 any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
213 any_warn = not (isEmptyBag spec_warn)
215 mk_module_fm get_mod_data errs_bag
216 = addListToFM_C (++) emptyFM errs_list
218 errs_list = map get_mod_data (bagToList errs_bag)
220 tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
222 iderrs_fm = mk_module_fm (get_id_data True) spec_errs
223 idwarn_fm = mk_module_fm (get_id_data False) spec_warn
224 idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
226 get_id_data is_err (id, tys)
227 = (mod_name, [(id_name, id, tys, is_err)])
229 (mod_name, id_name) = get_id_name id
232 | maybeToBool (isDefaultMethodId_maybe id)
235 | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
236 = let get_mod = getInstIdModule id
237 use_mod = if from_prelude get_mod
245 get_ty_data (ty, tys)
246 = (mod_name, [(ty_name, ty, tys)])
248 (mod_name,ty_name) = getOrigName ty
251 = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
253 module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
254 mods = map head (equivClasses _CMP_STRING_ module_names)
256 (unks, known) = if null mods
258 else case _CMP_STRING_ (head mods) _NIL_ of
259 EQ_ -> ([_NIL_], tail mods)
262 (prels, others) = partition from_prelude known
263 use_modules = unks ++ prels ++ others
265 pp_module_specs :: FAST_STRING -> Pretty
268 = ASSERT (null mod_tyspecs)
269 ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
273 ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
274 ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
281 mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
282 mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
283 have_specs = not (null mod_tyspecs && null mod_idspecs)
284 ty_sty = PprInterface
287 = ppBesides [ppPStr mod, ppStr ":"]
289 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
291 pp_tyspec sty pp_mod (_, tycon, tys)
293 ppStr "{-# SPECIALIZE", ppStr "data",
294 pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys),
295 ppStr "#-}", ppStr "{- Essential -}"
298 tvs = tyConTyVars tycon
299 (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
300 spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
302 choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
303 choose_ty (tv, Just ty) = (ty, Nothing)
305 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
307 pp_idspec sty pp_mod (_, id, tys, is_err)
310 ppStr "{-# SPECIALIZE",
312 pprGenType sty spec_ty,
313 ppStr "#-}", pp_essential ]
317 Just (cls, clsty, clsop) = const_method_maybe
318 (_, cls_str) = getOrigName cls
319 clsop_str = getClassOpString clsop
322 ppStr "{-# SPECIALIZE",
323 pp_clsop clsop_str, ppStr "::",
324 pprGenType sty spec_ty,
325 ppStr "#-} {- IN instance",
326 ppPStr cls_str, pprParendGenType sty clsty,
327 ppStr "-}", pp_essential ]
329 | is_default_method_id
331 Just (cls, clsop, _) = default_method_maybe
332 (_, cls_str) = getOrigName cls
333 clsop_str = getClassOpString clsop
338 ppStr "EXPLICIT METHOD REQUIRED",
339 pp_clsop clsop_str, ppStr "::",
340 pprGenType sty spec_ty,
341 ppStr "-}", pp_essential ]
345 ppStr "{-# SPECIALIZE",
346 pprNonOp PprForUser id, ppStr "::",
347 pprGenType sty spec_ty,
348 ppStr "#-}", pp_essential ]
350 spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
351 pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
353 const_method_maybe = isConstMethodId_maybe id
354 is_const_method_id = maybeToBool const_method_maybe
356 default_method_maybe = isDefaultMethodId_maybe id
357 is_default_method_id = maybeToBool default_method_maybe
359 pp_clsop str | isAvarop str
360 = ppBesides [ppLparen, ppPStr str, ppRparen]