2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
11 isUnboxedSpecialisation,
16 argTysMatchSpecTys_error,
21 #include "HsVersions.h"
23 import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
26 import Bag ( isEmptyBag, bagToList, Bag )
27 import Class ( Class )
28 import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
32 import Maybes ( maybeToBool, catMaybes, firstJust )
33 import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) )
35 import PprType ( pprParendType, pprMaybeTy, TyCon )
36 import TyCon ( tyConTyVars )
37 import Type ( mkSigmaTy, instantiateTauTy, instantiateThetaTy,
38 splitSigmaTy, mkTyVarTy, mkForAllTys,
41 import TyVar ( TyVar, mkTyVarEnv )
42 import Util ( equivClasses, zipWithEqual,
43 assertPanic, panic{-ToDo:rm-}
47 cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
48 getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
49 mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
54 specialiseTy :: Type -- The type of the Id of which the SpecId
55 -- is a specialised version
56 -> [Maybe Type] -- The types at which it is specialised
57 -> Int -- Number of leading dictionary args to ignore
60 specialiseTy main_ty maybe_tys dicts_to_ignore
61 = mkSigmaTy remaining_tyvars
62 (instantiateThetaTy inst_env remaining_theta)
63 (instantiateTauTy inst_env tau)
65 (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all,
66 -- the theta is discarded!
67 remaining_theta = drop dicts_to_ignore theta
68 tyvars_and_maybe_tys = tyvars `zip` maybe_tys
69 remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys]
70 inst_env = mkTyVarEnv [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys]
74 @specialiseCallTys@ works out which type args don't need to be specialised on,
75 based on flags, the overloading constraint vector, and the types.
78 specialiseCallTys :: ConstraintVector -- Tells which type args are overloaded
79 -> [Type] -- Type args
80 -> [Maybe Type] -- Nothings replace non-specialised type args
82 specialiseCallTys cvec tys
83 | opt_SpecialiseAll = map Just tys
84 | otherwise = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys
86 spec_ty_other c ty | (opt_SpecialiseUnboxed && isUnboxedType ty) ||
87 (opt_SpecialiseOverloaded && c)
93 @getIdOverloading@ grabs the type of an Id, and returns a
94 list of its polymorphic variables, and the initial segment of
95 its ThetaType, in which the classes constrain only type variables.
96 For example, if the Id's type is
98 forall a,b,c. Eq a -> Ord [a] -> tau
104 This seems curious at first. For a start, the type above looks odd,
105 because we usually only have dictionary args whose types are of
106 the form (C a) where a is a type variable. But this doesn't hold for
107 the functions arising from instance decls, which sometimes get
108 arguements with types of form (C (T a)) for some type constructor T.
110 Should we specialise wrt this compound-type dictionary? This is
111 a heuristic judgement, as indeed is the fact that we specialise wrt
112 only dictionaries. We choose *not* to specialise wrt compound dictionaries
113 because at the moment the only place they show up is in instance decls,
114 where they are simply plugged into a returned dictionary. So nothing is
115 gained by specialising wrt them.
118 getIdOverloading :: Id
119 -> ([TyVar], [(Class,TyVar)])
120 getIdOverloading = panic "getIdOverloading"
122 -- Looks suspicious to me; and I'm not sure what corresponds to
123 -- (Class,TyVar) pairs in the multi-param type class world.
126 = (tyvars, tyvar_part_of theta)
128 (tyvars, theta, _) = splitSigmaTy (idType id)
130 tyvar_part_of [] = []
131 tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
133 Just tv -> (c, tv) : tyvar_part_of theta
138 type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
142 isUnboxedSpecialisation :: [Maybe Type] -> Bool
143 isUnboxedSpecialisation tys
146 is_unboxed (Just ty) = isUnboxedType ty
147 is_unboxed Nothing = False
150 @specialiseConstrTys@ works out which type args don't need to be
151 specialised on. We only speciailise on unboxed types.
154 specialiseConstrTys :: [Type]
157 specialiseConstrTys tys
158 = map maybe_unboxed_ty tys
160 maybe_unboxed_ty ty = case isUnboxedType ty of
166 mkSpecialisedCon :: Id -> [Type] -> Id
167 mkSpecialisedCon con tys
169 then mkSameSpecCon spec_tys con
172 spec_tys = specialiseConstrTys tys
173 spec_reqd = maybeToBool (firstJust spec_tys)
176 @argTysMatchSpecTys@ checks if a list of argument types is consistent
177 with a list of specialising types. An error message is returned if not.
179 argTysMatchSpecTys_error :: [Maybe Type]
182 argTysMatchSpecTys_error spec_tys arg_tys
183 = if match spec_tys arg_tys
185 else Just (sep [ptext SLIT("Spec and Arg Types Inconsistent:"),
186 ptext SLIT("spectys="), sep [pprMaybeTy ty | ty <- spec_tys],
187 ptext SLIT("argtys="), sep [pprParendType ty | ty <- arg_tys]])
189 match (Nothing:spec_tys) (arg:arg_tys)
190 = not (isUnboxedType arg) &&
191 match spec_tys arg_tys
192 match (Just spec:spec_tys) (arg:arg_tys)
193 = case (cmpType True{-properly-} spec arg) of
194 EQ -> match spec_tys arg_tys
200 @pprSpecErrs@ prints error and warning information
201 about imported specialisations which do not exist.
204 pprSpecErrs :: FAST_STRING -- module name
205 -> (Bag (Id,[Maybe Type])) -- errors
206 -> (Bag (Id,[Maybe Type])) -- warnings
207 -> (Bag (TyCon,[Maybe Type])) -- errors
210 pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
211 | not any_errs && not any_warn
216 ptext SLIT("SPECIALISATION MESSAGES:"),
217 vcat (map pp_module_specs use_modules)
220 any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
221 any_warn = not (isEmptyBag spec_warn)
223 mk_module_fm get_mod_data errs_bag
224 = addListToFM_C (++) emptyFM errs_list
226 errs_list = map get_mod_data (bagToList errs_bag)
228 tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
230 iderrs_fm = mk_module_fm (get_id_data True) spec_errs
231 idwarn_fm = mk_module_fm (get_id_data False) spec_warn
232 idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
234 get_id_data is_err (id, tys)
235 = (mod_name, [(id_name, id, tys, is_err)])
237 (mod_name, id_name) = get_id_name id
242 {- Don't understand this -- and looks TURGID. SLPJ 4 Nov 96
243 | maybeToBool (isDefaultMethodId_maybe id)
246 | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
247 = let get_mod = getInstIdModule id
255 get_ty_data (ty, tys)
256 = (mod_name, [(ty_name, ty, tys)])
258 (mod_name, ty_name) = modAndOcc ty
260 module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
261 mods = map head (equivClasses compare module_names)
263 (unks, known) = if null mods
265 else case head mods `compare` _NIL_ of
266 EQ -> ([_NIL_], tail mods)
269 use_modules = unks ++ known
271 pp_module_specs :: FAST_STRING -> SDoc
274 = ASSERT (null mod_tyspecs)
275 vcat (map (pp_idspec (ptext SLIT("UNKNOWN:"))) mod_idspecs)
279 vcat (map (pp_tyspec (pp_module mod)) mod_tyspecs),
280 vcat (map (pp_idspec (pp_module mod)) mod_idspecs)
287 mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
288 mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
289 have_specs = not (null mod_tyspecs && null mod_idspecs)
292 = hcat [ptext mod, char ':']
294 pp_tyspec :: SDoc -> (OccName, TyCon, [Maybe Type]) -> SDoc
296 pp_tyspec pp_mod (_, tycon, tys)
298 text "{-# SPECIALIZE data",
299 ppr tycon, hsep (map pprParendType spec_tys),
300 text "-} {- Essential -}"
303 tvs = tyConTyVars tycon
304 (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
305 spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
307 choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
308 choose_ty (tv, Just ty) = (ty, Nothing)
310 pp_idspec :: SDoc -> (OccName, Id, [Maybe Type], Bool) -> SDoc
311 pp_idspec = error "pp_idspec"
315 pp_idspec pp_mod (_, id, tys, is_err)
318 text "{-# SPECIALIZE instance",
320 text "#-}", pp_essential ]
324 Just (cls, clsty, clsop) = const_method_maybe
327 text "{-# SPECIALIZE",
328 ppr clsop, text "::",
330 text "#-} {- IN instance",
331 pprOccName (getOccName cls), pprParendType clsty,
332 text "-}", pp_essential ]
334 | is_default_method_id
336 Just (cls, clsop, _) = default_method_maybe
340 pprOccName (getOccName cls),
341 ptext SLIT("EXPLICIT METHOD REQUIRED"),
342 ppr clsop, text "::",
344 text "-}", pp_essential ]
348 text "{-# SPECIALIZE",
349 ppr id, ptext SLIT("::"),
351 text "#-}", pp_essential ]
353 spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
354 pp_essential = if is_err then text "{- Essential -}" else empty
356 const_method_maybe = isConstMethodId_maybe id
357 is_const_method_id = maybeToBool const_method_maybe
359 default_method_maybe = isDefaultMethodId_maybe id
360 is_default_method_id = maybeToBool default_method_maybe