2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[SpecMisc]{Miscellaneous stuff for the Specialiser}
7 #include "HsVersions.h"
16 import Outputable -- ToDo: these may be removable...
21 import CmdLineOpts ( GlobalSwitch(..) )
22 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
26 import InstEnv ( lookupClassInstAtSimpleType )
27 import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) )
28 import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) )
36 %************************************************************************
38 \subsubsection[CallInstances]{@CallInstances@ data type}
40 %************************************************************************
43 type FreeVarsSet = UniqSet Id
44 type FreeTyVarsSet = UniqSet TyVar
48 Id -- This Id; *new* ie *cloned* id
49 [Maybe UniType] -- Specialised at these types (*new*, cloned)
50 -- Nothing => no specialisation on this type arg
51 -- is required (flag dependent).
52 [PlainCoreArg] -- And these dictionaries; all ValArgs
53 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
54 (Maybe SpecInfo) -- For specialisation with explicit SpecId
58 pprCI :: CallInstance -> Pretty
59 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
60 = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
61 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
62 case maybe_specinfo of
63 Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
64 Just (SpecInfo _ _ spec_id)
65 -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
68 isUnboxedCI :: CallInstance -> Bool
69 isUnboxedCI (CallInstance _ spec_tys _ _ _)
70 = any isUnboxedDataType (catMaybes spec_tys)
72 isExplicitCI :: CallInstance -> Bool
73 isExplicitCI (CallInstance _ _ _ _ (Just _))
75 isExplicitCI (CallInstance _ _ _ _ Nothing)
79 Comparisons are based on the {\em types}, ignoring the dictionary args:
83 cmpCI :: CallInstance -> CallInstance -> TAG_
84 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
85 = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
87 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
88 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
89 = cmpUniTypeMaybeList tys1 tys2
91 eqCI_tys :: CallInstance -> CallInstance -> Bool
93 = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
95 isCIofTheseIds :: [Id] -> CallInstance -> Bool
96 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
97 = any (eqId ci_id) ids
99 singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
100 singleCI id tys dicts
101 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
102 emptyBag [] emptyUniqSet 0 0
104 fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
106 explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
107 explicitCI id tys specinfo
108 = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
110 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
111 dicts = panic "Specialise:explicitCI:dicts"
112 fv_set = singletonUniqSet id
114 -- We do not process the CIs for top-level dfuns or defms
115 -- Instead we require an explicit SPEC inst pragma for dfuns
116 -- and an explict method within any instances for the defms
118 getCIids :: Bool -> [Id] -> [Id]
119 getCIids True ids = filter not_dict_or_defm ids
123 = not (isDictTy (getIdUniType id) || maybeToBool (isDefaultMethodId_maybe id))
125 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
126 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
128 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
129 cis_here_list = bagToList cis_here
131 -- pprTrace "getCIs:"
132 -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
133 -- 4 (ppAboves (map pprCI cis_here_list)))
134 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
136 dumpCIs :: Bag CallInstance -- The call instances
137 -> Bool -- True <=> top level bound Ids
138 -> Bool -- True <=> dict bindings to be floated (specBind only)
139 -> [CallInstance] -- Call insts for bound ids (instBind only)
140 -> [Id] -- Bound ids *new*
141 -> [Id] -- Full bound ids: includes dumped dicts
142 -> Bag CallInstance -- Kept call instances
144 -- CIs are dumped if:
145 -- 1) they are a CI for one of the bound ids, or
146 -- 2) they mention any of the dicts in a local unfloated binding
148 -- For top-level bindings we allow the call instances to
149 -- float past a dict bind and place all the top-level binds
150 -- in a *global* CoRec.
151 -- We leave it to the simplifier will sort it all out ...
153 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
154 = (if not (isEmptyBag cis_of_bound_id) &&
155 not (isEmptyBag cis_of_bound_id_without_inst_cis)
157 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
158 " (may be a non-HM recursive call)\n")
159 (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
160 4 (ppAboves [ppStr "Dumping CIs:",
161 ppAboves (map pprCI (bagToList cis_of_bound_id)),
162 ppStr "Instantiating CIs:",
163 ppAboves (map pprCI inst_cis)]))
165 if top_lev || floating then
168 (if not (isEmptyBag cis_dump_unboxed)
169 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
170 (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
171 4 (ppAboves (map pprCI (bagToList cis_dump))))
173 cis_keep_not_bound_id
176 (cis_of_bound_id, cis_not_bound_id)
177 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
179 (cis_dump, cis_keep_not_bound_id)
180 = partitionBag ok_to_dump_ci cis_not_bound_id
182 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
183 = or [i `elementOfUniqSet` fv_set | i <- full_ids]
185 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
186 have_inst_ci ci = any (eqCI_tys ci) inst_cis
188 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
192 Any call instances of a bound_id can be safely dumped, because any
193 recursive calls should be at the same instance as the parent instance.
195 letrec f = /\a -> \x::a -> ...(f t x')...
197 Here, the type, t, at which f is used in its own RHS should be
198 just "a"; that is, the recursive call is at the same type as
199 the original call. That means that when specialising f at some
200 type, say Int#, we shouldn't find any *new* instances of f
201 arising from specialising f's RHS. The only instance we'll find
202 is another call of (f Int#).
204 We check this in dumpCIs by passing in all the instantiated call
205 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
206 for which there is no such instance.
208 We also report CIs dumped due to a bound dictionary arg if they
209 contain unboxed types.
211 %************************************************************************
213 \subsubsection[TyConInstances]{@TyConInstances@ data type}
215 %************************************************************************
219 = TyConInstance TyCon -- Type Constructor
220 [Maybe UniType] -- Applied to these specialising types
222 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
223 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
224 = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
226 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
227 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
228 = cmpUniTypeMaybeList tys1 tys2
230 singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
231 singleTyConI ty_con spec_tys
232 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
234 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
235 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
237 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
238 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
240 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
241 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
243 (tycon_cis_local, tycon_cis_global)
244 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
245 tycon_cis_local_list = bagToList tycon_cis_local
247 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
251 %************************************************************************
253 \subsubsection[UsageDetails]{@UsageDetails@ data type}
255 %************************************************************************
260 (Bag CallInstance) -- The collection of call-instances
261 (Bag TyConInstance) -- Constructor call-instances
262 [DictBindDetails] -- Dictionary bindings in data-dependence order!
263 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
264 Int -- no. of spec calls
265 Int -- no. of spec insts
268 The DictBindDetails are fully processed; their call-instance information is
269 incorporated in the call-instances of the
270 UsageDetails which includes the DictBindDetails. The free vars in a usage details
271 will *include* the binders of the DictBind details.
273 A @DictBindDetails@ contains bindings for dictionaries *only*.
278 [Id] -- Main binders, originally visible in scope of binding (cloned)
279 PlainCoreBinding -- Fully processed
280 FreeVarsSet -- Free in binding group (cloned)
281 FreeTyVarsSet -- Free in binding group
285 emptyUDs :: UsageDetails
286 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
287 unionUDList :: [UsageDetails] -> UsageDetails
289 tickSpecCall :: Bool -> UsageDetails -> UsageDetails
290 tickSpecInsts :: UsageDetails -> UsageDetails
292 tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
293 = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
295 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
296 = UsageDetails cis ty_cis dbs fvs c (i+1)
298 emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
300 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
301 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
302 (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
303 -- The append here is really redundant, since the bindings don't
304 -- scope over each other. ToDo.
306 unionUDList = foldr unionUDs emptyUDs
308 singleFvUDs (CoVarAtom v) | not (isImportedId v)
309 = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
313 singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
315 dumpDBs :: [DictBindDetails]
316 -> Bool -- True <=> top level bound Ids
317 -> [TyVar] -- TyVars being bound (cloned)
318 -> [Id] -- Ids being bound (cloned)
319 -> FreeVarsSet -- Fvs of body
320 -> ([PlainCoreBinding], -- These ones have to go here
321 [DictBindDetails], -- These can float further
322 [Id], -- Incoming list + names of dicts bound here
323 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
326 -- It is just to complex to try to float top-level
327 -- dict bindings with constant methods, inst methods,
328 -- auxillary derived instance defns and user instance
329 -- defns all getting in the way.
330 -- So we dump all dbinds as soon as we get to the top
331 -- level and place them in a *global* CoRec.
332 -- We leave it to the simplifier will sort it all out ...
334 dumpDBs [] top_lev bound_tyvars bound_ids fvs
335 = ([], [], bound_ids, fvs)
337 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
338 top_lev bound_tyvars bound_ids fvs
340 || or [i `elementOfUniqSet` db_fvs | i <- bound_ids]
341 || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
342 = let -- Ha! Dump it!
343 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
344 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
346 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
348 | otherwise -- This one can float out further
350 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
351 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
353 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
357 dumpUDs :: UsageDetails
358 -> Bool -- True <=> top level bound Ids
359 -> Bool -- True <=> dict bindings to be floated (specBind only)
360 -> [CallInstance] -- Call insts for bound Ids (instBind only)
361 -> [Id] -- Ids which are just being bound; *new*
362 -> [TyVar] -- TyVars which are just being bound
363 -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
364 UsageDetails) -- The above bindings removed, and
365 -- any call-instances which mention the ids dumped too
367 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
369 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
370 = dumpDBs dbs top_lev tvs bound_ids fvs
371 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
372 fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
374 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
378 addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage
379 -> UsageDetails -- The usage to augment
381 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
382 (UsageDetails cis tycon_cis dbs fvs c i)
383 = UsageDetails (db_cis `unionBags` cis)
384 (db_tycon_cis `unionBags` tycon_cis)
385 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
387 -- NB: We ignore counts from dictbinds since it is not user code
389 -- The free tyvars of the dictionary bindings should really be
390 -- gotten from the RHSs, but I'm pretty sure it's good enough just
391 -- to look at the type of the dictionary itself.
392 -- Doing the proper job would entail keeping track of free tyvars as
393 -- well as free vars, which would be a bore.
394 db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
397 %************************************************************************
399 \subsection[Misc]{Miscellaneous junk}
401 %************************************************************************
406 -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
407 -> SpecM UsageDetails
409 mkCallInstance id new_id []
412 mkCallInstance id new_id args
414 -- No specialised versions for "error" and friends are req'd.
415 -- This is a special case in core lint etc.
420 -- No call instances for SuperDictSelIds
421 -- These are a special case in mkCall
423 | maybeToBool (isSuperDictSelId_maybe id)
426 -- There are also no call instances for ClassOpIds
427 -- However, we need to process it to get any second-level call
428 -- instances for a ConstMethodId extracted from its SpecEnv
431 = getSwitchCheckerSM `thenSM` \ sw_chkr ->
433 spec_overloading = sw_chkr SpecialiseOverloaded
434 spec_unboxed = sw_chkr SpecialiseUnboxed
435 spec_all = sw_chkr SpecialiseAll
437 (tyvars, class_tyvar_pairs) = getIdOverloading id
439 arg_res = take_type_args tyvars class_tyvar_pairs args
440 enough_args = maybeToBool arg_res
442 (Just (tys, dicts, rest_args)) = arg_res
445 = (record, lookup, spec_tys)
447 spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
448 (mkConstraintVector id) tys
450 record = any (not . isTyVarTy) (catMaybes spec_tys)
452 lookup = lookupSpecEnv (getIdSpecialisation id) tys
454 if (not enough_args) then
455 pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
456 (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
458 case record_spec id tys of
460 -> -- pprTrace "CallInst:NotReqd\n"
461 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
464 (True, Nothing, spec_tys)
465 -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
468 -- pprTrace "CallInst:Reqd\n"
469 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
470 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
471 -- ppCat (map (ppr PprDebug) dicts)]])
472 (returnSM (singleCI new_id spec_tys dicts))
474 (True, Just (spec_id, tys_left, toss), _)
475 -> if maybeToBool (isConstMethodId_maybe spec_id) then
476 -- If we got a const method spec_id see if further spec required
477 -- NB: const method is top-level so spec_id will not be cloned
478 case record_spec spec_id tys_left of
480 -> -- pprTrace "CallInst:Exists\n"
481 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
482 -- ppCat [ppStr "->", ppr PprDebug spec_id,
483 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
486 (True, Nothing, spec_tys)
487 -> -- pprTrace "CallInst:Exists:Reqd\n"
488 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
489 -- ppCat [ppStr "->", ppr PprDebug spec_id,
490 -- ppr PprDebug (tys_left ++ drop toss dicts)],
491 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
492 -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
493 (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
495 (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
496 -> -- pprTrace "CallInst:Exists:Exists\n"
497 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
498 -- ppCat [ppStr "->", ppr PprDebug spec_id,
499 -- ppr PprDebug (tys_left ++ drop toss dicts)],
500 -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
501 -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
505 -- pprTrace "CallInst:Exists\n"
506 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
507 -- ppCat [ppStr "->", ppr PprDebug spec_id,
508 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
512 take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
513 = case take_type_args tyvars class_tyvar_pairs args of
515 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
516 take_type_args (_:tyvars) class_tyvar_pairs []
518 take_type_args [] class_tyvar_pairs args
519 = case take_dict_args class_tyvar_pairs args of
521 Just (dicts, others) -> Just ([], dicts, others)
523 take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
524 = case take_dict_args class_tyvar_pairs args of
526 Just (dicts, others) -> Just (dict:dicts, others)
527 take_dict_args (_:class_tyvar_pairs) []
529 take_dict_args [] args
535 -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
536 -> SpecM (Bool, PlainCoreExpr)
539 | maybeToBool (isSuperDictSelId_maybe new_id)
540 && any isUnboxedDataType ty_args
541 -- No specialisations for super-dict selectors
542 -- Specialise unboxed calls to SuperDictSelIds by extracting
543 -- the super class dictionary directly form the super class
544 -- NB: This should be dead code since all uses of this dictionary should
545 -- have been specialised. We only do this to keep core-lint happy.
547 Just (_, super_class) = isSuperDictSelId_maybe new_id
548 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
549 Nothing -> panic "Specialise:mkCall:SuperDictId"
552 returnSM (False, CoVar super_dict_id)
555 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
556 Nothing -> checkUnspecOK new_id ty_args (
557 returnSM (False, unspec_call)
560 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
562 -- It may be necessary to specialsie a constant method spec_id again
563 (spec_id, tys_left, dicts_to_toss) =
564 case (maybeToBool (isConstMethodId_maybe spec_id_1),
565 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
566 (False, _ ) -> spec_1_details
567 (True, Nothing) -> spec_1_details
568 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
569 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
571 args_left = toss_dicts dicts_to_toss val_args
573 checkSpecOK new_id ty_args spec_id tys_left (
575 -- The resulting spec_id may be a top-level unboxed value
576 -- This can arise for:
577 -- 1) constant method values
578 -- eq: class Num a where pi :: a
579 -- instance Num Double# where pi = 3.141#
580 -- 2) specilised overloaded values
581 -- eq: i1 :: Num a => a
582 -- i1 Int# d.Num.Int# ==> i1.Int#
583 -- These top level defns should have been lifted.
584 -- We must add code to unlift such a spec_id.
586 if isUnboxedDataType (getIdUniType spec_id) then
587 ASSERT (null tys_left && null args_left)
588 if toplevelishId spec_id then
589 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
590 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
591 (CoVar unlift_spec_id))
593 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
594 (ppCat [ppr PprDebug new_id,
595 ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
597 ppr PprDebug spec_id])
600 (vals_left, _, unlifts_left) = unzip3 args_left
601 applied_tys = mkCoTyApps (CoVar spec_id) tys_left
602 applied_vals = applyToArgs applied_tys vals_left
604 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
607 (tys_and_vals, _, unlifts) = unzip3 args
608 unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar new_id) tys_and_vals)
611 -- ty_args is the types at the front of the arg list
612 -- val_args is the rest of the arg-list
614 (ty_args, val_args) = get args
616 get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
617 get args = ([], args)
620 -- toss_dicts chucks away dict args, checking that they ain't types!
621 toss_dicts 0 args = args
622 toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
627 checkUnspecOK :: Id -> [UniType] -> a -> a
628 checkUnspecOK check_id tys
629 = if isLocallyDefined check_id && any isUnboxedDataType tys
630 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
631 (ppCat [ppr PprDebug check_id,
632 ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
635 checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
636 checkSpecOK check_id tys spec_id tys_left
637 = if any isUnboxedDataType tys_left
638 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
639 (ppAboves [ppCat [ppr PprDebug check_id,
640 ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
641 ppCat [ppr PprDebug spec_id,
642 ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
647 mkTyConInstance :: Id
649 -> SpecM UsageDetails
650 mkTyConInstance con tys
651 = recordTyConInst con tys `thenSM` \ record_inst ->
653 Nothing -- No TyCon instance
654 -> -- pprTrace "NoTyConInst:"
655 -- (ppCat [ppr PprDebug tycon, ppStr "at",
656 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
657 (returnSM (singleConUDs con))
659 Just spec_tys -- Record TyCon instance
660 -> -- pprTrace "TyConInst:"
661 -- (ppCat [ppr PprDebug tycon, ppStr "at",
662 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
663 -- ppBesides [ppStr "(",
664 -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
666 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
668 tycon = getDataConTyCon con
672 recordTyConInst :: Id
674 -> SpecM (Maybe [Maybe UniType])
676 recordTyConInst con tys
678 spec_tys = specialiseConstrTys tys
680 do_tycon_spec = maybeToBool (firstJust spec_tys)
682 spec_exists = maybeToBool (lookupSpecEnv
683 (getIdSpecialisation con)
686 -- pprTrace "ConSpecExists?: "
687 -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
688 -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
689 (if (not spec_exists && do_tycon_spec)
690 then returnSM (Just spec_tys)
691 else returnSM Nothing)