2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[SpecEnv]{Specialisation info about an @Id@}
7 #include "HsVersions.h"
10 SYN_IE(SpecEnv), MatchEnv,
11 nullSpecEnv, isNullSpecEnv,
12 addOneToSpecEnv, lookupSpecEnv,
19 import Type ( matchTys, isTyVarTy )
20 import Usage ( SYN_IE(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
39 All the stuff about how many dictionaries to discard, and what types
40 to apply the specialised function to, are handled by the fact that the
41 SpecEnv contains a template for the result of the specialisation.
43 There is one more exciting case, which is dealt with in exactly the same
44 way. If the specialised value is unboxed then it is lifted at its
45 definition site and unlifted at its uses. For example:
47 pi :: forall a. Num a => a
49 might have a specialisation
51 [Int#] ===> (case pi' of Lift pi# -> pi#)
53 where pi' :: Lift Int# is the specialised version of pi.
57 nullSpecEnv :: SpecEnv
58 nullSpecEnv = nullMEnv
60 isNullSpecEnv :: SpecEnv -> Bool
61 isNullSpecEnv env = null (mEnvToList env)
63 specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
64 specEnvToList env = mEnvToList env
66 addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
67 addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
69 lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
71 | all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
72 | otherwise = lookupMEnv matchTys env tys
77 =================================================================
78 BELOW HERE SCHEDULED FOR DELETION!
81 The details of one specialisation, held in an @Id@'s
82 @SpecEnv@ are as follows:
85 = SpecInfo [Maybe Type] -- Instance types; no free type variables in here
86 Int -- No. of dictionaries to eat
87 Id -- Specialised version
90 For example, if \tr{f} has this @SpecInfo@:
92 SpecInfo [Just t1, Nothing, Just t3] 2 f'
96 f t1 t2 t3 d1 d2 ===> f t2
98 The \tr{Nothings} identify type arguments in which the specialised
99 version is polymorphic.
102 data SpecEnv = SpecEnv [SpecInfo]
105 nullSpecEnv = SpecEnv []
106 addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
109 lookupConstMethodId :: Id -> Type -> Maybe Id
110 -- slight variant on "lookupSpecEnv" below
112 lookupConstMethodId sel_id spec_ty
113 = case (getInfo (getIdInfo sel_id)) of
114 SpecEnv spec_infos -> firstJust (map try spec_infos)
116 try (SpecInfo (Just ty:nothings) _ const_meth_id)
117 = ASSERT(all nothing_is_nothing nothings)
118 case (cmpType True{-properly-} ty spec_ty) of
119 EQ_ -> Just const_meth_id
122 nothing_is_nothing Nothing = True -- debugging only
123 nothing_is_nothing _ = panic "nothing_is_nothing!"
125 lookupSpecId :: Id -- *un*specialised Id
126 -> [Maybe Type] -- types to which it is to be specialised
127 -> Id -- specialised Id
129 lookupSpecId unspec_id ty_maybes
130 = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
132 case (firstJust (map try spec_infos)) of
134 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"
135 (ppr PprDebug unspec_id)
138 try (SpecInfo template_maybes _ id)
139 | and (zipWith same template_maybes ty_maybes)
140 && length template_maybes == length ty_maybes = Just id
141 | otherwise = Nothing
143 same Nothing Nothing = True
144 same (Just ty1) (Just ty2) = ty1 == ty2
147 lookupSpecEnv :: SpecEnv
153 lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
155 lookupSpecEnv spec_env [] = Nothing -- another common case
157 -- This can happen even if there is a non-empty spec_env, because
158 -- of eta reduction. For example, we might have a defn
160 -- f = /\a -> \d -> g a d
161 -- which gets transformed to
164 -- Now g isn't applied to any arguments
166 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
167 = select_match spec_infos
169 select_match [] -- no matching spec_infos
171 select_match (SpecInfo ty_maybes toss spec_id : rest)
172 = case (match ty_maybes spec_tys) of
173 Nothing -> select_match rest
174 Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
176 -- Ambiguity can only arise as a result of specialisations with
177 -- an explicit spec_id. The best match is deemed to be the match
178 -- with least polymorphism i.e. has the least number of tys left.
179 -- This is a non-critical approximation. The only type arguments
180 -- where there may be some discretion is for non-overloaded boxed
181 -- types. Unboxed types must be matched and we insist that we
182 -- always specialise on overloaded types (and discard all the dicts).
184 select_next best _ toss []
186 [match] -> Just match -- Unique best match
187 ambig -> pprPanic "Ambiguous Specialisation:\n"
188 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
189 ppCat (ppStr "between spec ids:" :
190 map (ppr PprDebug) [id | (id, _, _) <- ambig]),
193 select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
194 = ASSERT(dnum == toss)
195 case (match ty_maybes spec_tys) of
196 Nothing -> select_next best tnum dnum rest
198 let tys_len = length tys_left in
199 case _tagCmp tnum tys_len of
200 _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
201 _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
202 _GT -> select_next best tnum dnum rest -- worse match
205 match [{-out of templates-}] [] = Just []
207 match (Nothing:ty_maybes) (spec_ty:spec_tys)
208 = case (isUnboxedType spec_ty) of
209 True -> Nothing -- Can only match boxed type against
210 -- type argument which has not been
212 False -> case match ty_maybes spec_tys of
214 Just tys -> Just (spec_ty:tys)
216 match (Just ty:ty_maybes) (spec_ty:spec_tys)
217 = case (cmpType True{-properly-} ty spec_ty) of
218 EQ_ -> match ty_maybes spec_tys
221 match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
222 -- This is a Real Problem
224 match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
225 -- Partial eta abstraction might make this happen;
226 -- meanwhile let's leave in the check
228 pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
233 instance OptIdInfo SpecEnv where
236 getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
238 addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
239 = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
240 -- We *add* the new specialisation info rather than just replacing it
241 -- so that we don't lose old specialisation details.
243 ppInfo sty better_id_fn spec_env
244 = pp_specs sty True better_id_fn nullIdEnv spec_env
246 pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
247 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
248 = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
249 ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
252 better_spec_id = better_id_fn spec_id
253 spec_id_info = getIdInfo better_spec_id
255 if not print_spec_ids || boringIdInfo spec_id_info then
259 ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
262 | (SpecInfo ty_maybes numds spec_id) <- specs ])
265 pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
267 pp_maybe Nothing = ifPprInterface sty pp_NONE
268 pp_maybe (Just t) = pprParendGenType sty t