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 -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
121 try (SpecInfo template_maybes _ id)
122 | and (zipWith same template_maybes ty_maybes)
123 && length template_maybes == length ty_maybes = Just id
124 | otherwise = Nothing
126 same Nothing Nothing = True
127 same (Just ty1) (Just ty2) = ty1 == ty2
130 lookupSpecEnv :: SpecEnv
136 lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
138 lookupSpecEnv spec_env [] = Nothing -- another common case
140 -- This can happen even if there is a non-empty spec_env, because
141 -- of eta reduction. For example, we might have a defn
143 -- f = /\a -> \d -> g a d
144 -- which gets transformed to
147 -- Now g isn't applied to any arguments
149 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
150 = select_match spec_infos
152 select_match [] -- no matching spec_infos
154 select_match (SpecInfo ty_maybes toss spec_id : rest)
155 = case (match ty_maybes spec_tys) of
156 Nothing -> select_match rest
157 Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
159 -- Ambiguity can only arise as a result of specialisations with
160 -- an explicit spec_id. The best match is deemed to be the match
161 -- with least polymorphism i.e. has the least number of tys left.
162 -- This is a non-critical approximation. The only type arguments
163 -- where there may be some discretion is for non-overloaded boxed
164 -- types. Unboxed types must be matched and we insist that we
165 -- always specialise on overloaded types (and discard all the dicts).
167 select_next best _ toss []
169 [match] -> Just match -- Unique best match
170 ambig -> pprPanic "Ambiguous Specialisation:\n"
171 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
172 ppCat (ppStr "between spec ids:" :
173 map (ppr PprDebug) [id | (id, _, _) <- ambig]),
176 select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
177 = ASSERT(dnum == toss)
178 case (match ty_maybes spec_tys) of
179 Nothing -> select_next best tnum dnum rest
181 let tys_len = length tys_left in
182 case _tagCmp tnum tys_len of
183 _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
184 _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
185 _GT -> select_next best tnum dnum rest -- worse match
188 match [{-out of templates-}] [] = Just []
190 match (Nothing:ty_maybes) (spec_ty:spec_tys)
191 = case (isUnboxedDataType spec_ty) of
192 True -> Nothing -- Can only match boxed type against
193 -- type argument which has not been
195 False -> case match ty_maybes spec_tys of
197 Just tys -> Just (spec_ty:tys)
199 match (Just ty:ty_maybes) (spec_ty:spec_tys)
200 = case (cmpType True{-properly-} ty spec_ty) of
201 EQ_ -> match ty_maybes spec_tys
204 match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
205 -- This is a Real Problem
207 match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
208 -- Partial eta abstraction might make this happen;
209 -- meanwhile let's leave in the check
211 pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
216 instance OptIdInfo SpecEnv where
219 getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
221 addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
222 = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
223 -- We *add* the new specialisation info rather than just replacing it
224 -- so that we don't lose old specialisation details.
226 ppInfo sty better_id_fn spec_env
227 = pp_specs sty True better_id_fn nullIdEnv spec_env
229 pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
230 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
231 = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
232 ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
235 better_spec_id = better_id_fn spec_id
236 spec_id_info = getIdInfo better_spec_id
238 if not print_spec_ids || boringIdInfo spec_id_info then
242 ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
245 | (SpecInfo ty_maybes numds spec_id) <- specs ])
248 pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
250 pp_maybe Nothing = ifPprInterface sty pp_NONE
251 pp_maybe (Just t) = pprParendType sty t