2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[SpecEnv]{Specialisation info about an @Id@}
7 #include "HsVersions.h"
10 SpecEnv(..), MatchEnv,
11 nullSpecEnv, isNullSpecEnv,
12 addOneToSpecEnv, lookupSpecEnv,
19 import Type ( matchTys, isTyVarTy )
20 import Usage ( UVar(..) )
24 A @SpecEnv@ holds details of an @Id@'s specialisations:
27 type CoreExpr = GenCoreExpr Id Id TyVar Unique
28 type SpecEnv = MatchEnv [Type] CoreExpr
31 For example, if \tr{f}'s @SpecEnv@ contains the mapping:
33 [List a, b] ===> (\d -> f' a b)
37 f (List Int) Bool d ===> f' Int Bool
41 nullSpecEnv :: SpecEnv
42 nullSpecEnv = nullMEnv
44 isNullSpecEnv :: SpecEnv -> Bool
45 isNullSpecEnv env = null (mEnvToList env)
47 specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
48 specEnvToList env = mEnvToList env
50 addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
51 addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
53 lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
55 | all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
56 | otherwise = lookupMEnv matchTys env tys
61 =================================================================
62 BELOW HERE SCHEDULED FOR DELETION!
65 The details of one specialisation, held in an @Id@'s
66 @SpecEnv@ are as follows:
69 = SpecInfo [Maybe Type] -- Instance types; no free type variables in here
70 Int -- No. of dictionaries to eat
71 Id -- Specialised version
74 For example, if \tr{f} has this @SpecInfo@:
76 SpecInfo [Just t1, Nothing, Just t3] 2 f'
80 f t1 t2 t3 d1 d2 ===> f t2
82 The \tr{Nothings} identify type arguments in which the specialised
83 version is polymorphic.
86 data SpecEnv = SpecEnv [SpecInfo]
89 nullSpecEnv = SpecEnv []
90 addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
93 lookupConstMethodId :: Id -> Type -> Maybe Id
94 -- slight variant on "lookupSpecEnv" below
96 lookupConstMethodId sel_id spec_ty
97 = case (getInfo (getIdInfo sel_id)) of
98 SpecEnv spec_infos -> firstJust (map try spec_infos)
100 try (SpecInfo (Just ty:nothings) _ const_meth_id)
101 = ASSERT(all nothing_is_nothing nothings)
102 case (cmpType True{-properly-} ty spec_ty) of
103 EQ_ -> Just const_meth_id
106 nothing_is_nothing Nothing = True -- debugging only
107 nothing_is_nothing _ = panic "nothing_is_nothing!"
109 lookupSpecId :: Id -- *un*specialised Id
110 -> [Maybe Type] -- types to which it is to be specialised
111 -> Id -- specialised Id
113 lookupSpecId unspec_id ty_maybes
114 = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
116 case (firstJust (map try spec_infos)) of
118 Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"
119 (ppr PprDebug unspec_id)
122 try (SpecInfo template_maybes _ id)
123 | and (zipWith same template_maybes ty_maybes)
124 && length template_maybes == length ty_maybes = Just id
125 | otherwise = Nothing
127 same Nothing Nothing = True
128 same (Just ty1) (Just ty2) = ty1 == ty2
131 lookupSpecEnv :: SpecEnv
137 lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
139 lookupSpecEnv spec_env [] = Nothing -- another common case
141 -- This can happen even if there is a non-empty spec_env, because
142 -- of eta reduction. For example, we might have a defn
144 -- f = /\a -> \d -> g a d
145 -- which gets transformed to
148 -- Now g isn't applied to any arguments
150 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
151 = select_match spec_infos
153 select_match [] -- no matching spec_infos
155 select_match (SpecInfo ty_maybes toss spec_id : rest)
156 = case (match ty_maybes spec_tys) of
157 Nothing -> select_match rest
158 Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
160 -- Ambiguity can only arise as a result of specialisations with
161 -- an explicit spec_id. The best match is deemed to be the match
162 -- with least polymorphism i.e. has the least number of tys left.
163 -- This is a non-critical approximation. The only type arguments
164 -- where there may be some discretion is for non-overloaded boxed
165 -- types. Unboxed types must be matched and we insist that we
166 -- always specialise on overloaded types (and discard all the dicts).
168 select_next best _ toss []
170 [match] -> Just match -- Unique best match
171 ambig -> pprPanic "Ambiguous Specialisation:\n"
172 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
173 ppCat (ppStr "between spec ids:" :
174 map (ppr PprDebug) [id | (id, _, _) <- ambig]),
177 select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
178 = ASSERT(dnum == toss)
179 case (match ty_maybes spec_tys) of
180 Nothing -> select_next best tnum dnum rest
182 let tys_len = length tys_left in
183 case _tagCmp tnum tys_len of
184 _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
185 _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
186 _GT -> select_next best tnum dnum rest -- worse match
189 match [{-out of templates-}] [] = Just []
191 match (Nothing:ty_maybes) (spec_ty:spec_tys)
192 = case (isUnboxedType spec_ty) of
193 True -> Nothing -- Can only match boxed type against
194 -- type argument which has not been
196 False -> case match ty_maybes spec_tys of
198 Just tys -> Just (spec_ty:tys)
200 match (Just ty:ty_maybes) (spec_ty:spec_tys)
201 = case (cmpType True{-properly-} ty spec_ty) of
202 EQ_ -> match ty_maybes spec_tys
205 match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
206 -- This is a Real Problem
208 match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
209 -- Partial eta abstraction might make this happen;
210 -- meanwhile let's leave in the check
212 pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
217 instance OptIdInfo SpecEnv where
220 getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
222 addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
223 = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
224 -- We *add* the new specialisation info rather than just replacing it
225 -- so that we don't lose old specialisation details.
227 ppInfo sty better_id_fn spec_env
228 = pp_specs sty True better_id_fn nullIdEnv spec_env
230 pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
231 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
232 = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
233 ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
236 better_spec_id = better_id_fn spec_id
237 spec_id_info = getIdInfo better_spec_id
239 if not print_spec_ids || boringIdInfo spec_id_info then
243 ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
246 | (SpecInfo ty_maybes numds spec_id) <- specs ])
249 pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
251 pp_maybe Nothing = ifPprInterface sty pp_NONE
252 pp_maybe (Just t) = pprParendGenType sty t