2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
11 SYN_IE(ConstraintVector),
14 isUnboxedSpecialisation,
19 argTysMatchSpecTys_error,
26 import Bag ( isEmptyBag, bagToList )
27 import Class ( classOpString, 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 ( origName, isLexVarSym, isLexSpecialSym, pprNonSym )
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 "specialiseCallTys" 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
241 = case (origName "get_id_name" id) of { OrigName m n -> (m, n) }
243 get_ty_data (ty, tys)
244 = (mod_name, [(ty_name, ty, tys)])
246 (OrigName mod_name ty_name) = origName "get_ty_data" ty
248 module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
249 mods = map head (equivClasses _CMP_STRING_ module_names)
251 (unks, known) = if null mods
253 else case _CMP_STRING_ (head mods) _NIL_ of
254 EQ_ -> ([_NIL_], tail mods)
257 use_modules = unks ++ known
259 pp_module_specs :: FAST_STRING -> Pretty
262 = ASSERT (null mod_tyspecs)
263 ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
267 ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
268 ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
275 mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
276 mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
277 have_specs = not (null mod_tyspecs && null mod_idspecs)
278 ty_sty = PprInterface
281 = ppBesides [ppPStr mod, ppStr ":"]
283 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
285 pp_tyspec sty pp_mod (_, tycon, tys)
287 ppStr "{-# SPECIALIZE", ppStr "data",
288 pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys),
289 ppStr "#-}", ppStr "{- Essential -}"
292 tvs = tyConTyVars tycon
293 (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
294 spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
296 choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
297 choose_ty (tv, Just ty) = (ty, Nothing)
299 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
301 pp_idspec sty pp_mod (_, id, tys, is_err)
304 ppStr "{-# SPECIALIZE",
306 pprGenType sty spec_ty,
307 ppStr "#-}", pp_essential ]
311 Just (cls, clsty, clsop) = const_method_maybe
312 (OrigName _ cls_str) = origName "pp_idspec" cls
313 clsop_str = classOpString clsop
316 ppStr "{-# SPECIALIZE",
317 pp_clsop clsop_str, ppStr "::",
318 pprGenType sty spec_ty,
319 ppStr "#-} {- IN instance",
320 ppPStr cls_str, pprParendGenType sty clsty,
321 ppStr "-}", pp_essential ]
323 | is_default_method_id
325 Just (cls, clsop, _) = default_method_maybe
326 (OrigName _ cls_str) = origName "pp_idspec2" cls
327 clsop_str = classOpString clsop
332 ppStr "EXPLICIT METHOD REQUIRED",
333 pp_clsop clsop_str, ppStr "::",
334 pprGenType sty spec_ty,
335 ppStr "-}", pp_essential ]
339 ppStr "{-# SPECIALIZE",
340 pprNonSym PprForUser id, ppStr "::",
341 pprGenType sty spec_ty,
342 ppStr "#-}", pp_essential ]
344 spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
345 pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
347 const_method_maybe = isConstMethodId_maybe id
348 is_const_method_id = maybeToBool const_method_maybe
350 default_method_maybe = isDefaultMethodId_maybe id
351 is_default_method_id = maybeToBool default_method_maybe
353 pp_clsop str | isLexVarSym str && not (isLexSpecialSym str)
354 = ppParens (ppPStr str)