2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
7 #include "HsVersions.h"
17 IMPORT_Trace -- ToDo: rm (debugging)
21 import TcMonad -- typechecking monadic machinery
22 import TcMonadFns ( mkIdsWithGivenTys )
23 import AbsSyn -- the stuff being typechecked
25 import AbsPrel ( PrimOp(..) -- to see CCallOp
26 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
27 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
30 import CE ( lookupCE, nullCE, CE(..) )
35 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
36 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
39 import WwLib ( mkWwBodies )
40 import InstEnv ( lookupClassInstAtSimpleType )
41 import Maybes ( assocMaybe, catMaybes, Maybe(..) )
42 import CoreLint ( lintUnfolding )
44 import TCE ( TCE(..), UniqFM )
46 import TcMonoType ( tcMonoType )
47 import TcPolyType ( tcPolyType )
52 The basic idea is: Given an @Id@ that only lacks its @IdInfo@
53 (represented as a function \tr{IdInfo -> Id}, use the pragmas given to
54 figure out the @IdInfo@, then give back the now-complete @Id@.
56 Of course, the pragmas also need to be checked.
58 %************************************************************************
60 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
62 %************************************************************************
65 tcClassOpPragmas :: E -- Class/TyCon lookup tables
66 -> UniType -- global type of the class method
67 -> Id -- *final* ClassOpId
68 -> Id -- *final* DefaultMethodId
69 -> SpecEnv -- Instance info for this class op
70 -> RenamedClassOpPragmas -- info w/ which to complete, giving...
71 -> Baby_TcM (IdInfo, IdInfo) -- ... final info for ClassOp and DefaultMethod
73 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
74 = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
76 tcClassOpPragmas e global_ty
77 rec_classop_id rec_defm_id
79 (ClassOpPragmas classop_pragmas defm_pragmas)
81 Nothing{-ty unknown-} rec_classop_id
82 classop_pragmas `thenB_Tc` \ classop_idinfo ->
85 Nothing{-ty unknown-} rec_defm_id
86 defm_pragmas `thenB_Tc` \ defm_idinfo ->
88 returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
91 %************************************************************************
93 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
95 %************************************************************************
97 {\em Every} instance declaration produces a ``dictionary function''
98 (dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
99 convey information about a DictFunId.
103 :: E -- Class/TyCon lookup tables
104 -> UniType -- DictFunId type
105 -> Id -- final DictFunId (don't touch)
106 -> RenamedInstancePragmas -- info w/ which to complete, giving...
107 -> Baby_TcM IdInfo -- ... final DictFun IdInfo
109 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
110 = returnB_Tc noIdInfo
112 tcDictFunPragmas e dfun_ty final_dfun pragmas
116 SimpleInstancePragma x -> x
117 ConstantInstancePragma x _ -> x
118 SpecialisedInstancePragma x _ -> x
120 tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
123 %************************************************************************
125 \subsection[tcGenPragmas]{Basic pragmas about a value}
127 %************************************************************************
129 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
130 a problem, it just returns @noIdInfo@.
135 -> Maybe UniType -- of Id, if we have it (for convenience)
136 -> Id -- *incomplete* Id (do not *touch*!)
137 -> RenamedGenPragmas -- info w/ which to complete, giving...
138 -> Baby_TcM IdInfo -- IdInfo for this Id
140 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
141 = returnB_Tc noIdInfo
143 tcGenPragmas e ty_maybe rec_final_id
144 (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
145 = -- Guarantee success!
146 recoverIgnoreErrorsB_Tc noIdInfo (
148 -- OK, now we do the business
150 arity_info = get_arity arity_maybe
151 upd_info = get_upd upd_maybe
153 tc_strictness e ty_maybe rec_final_id strictness
154 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
156 -- If the unfolding fails to look consistent, we don't
157 -- want to junk *all* the IdInfo
158 recoverIgnoreErrorsB_Tc noInfo_UF (
159 tc_unfolding e unfold
160 ) `thenB_Tc` \ unfold_info ->
162 -- Same as unfolding; if we fail, don't junk all IdInfo
163 recoverIgnoreErrorsB_Tc nullSpecEnv (
164 tc_specs e rec_final_id ty_maybe specs
165 ) `thenB_Tc` \ spec_env ->
173 -- The strictness info *may* imply an unfolding
174 -- (the "wrapper_unfold"); that info is added; if
175 -- there is also an explicit unfolding, it will
176 -- take precedence, because it is "added" later.
177 `addInfo` strict_info
178 `addInfo_UF` wrapper_unfold_info
180 `addInfo_UF` unfold_info
184 get_arity Nothing = noInfo
185 get_arity (Just a) = mkArityInfo a
187 get_upd Nothing = noInfo
188 get_upd (Just u) = (u :: UpdateInfo)
191 Don't use the strictness info if a flag set.
196 -> Id -- final Id (do not *touch*)
197 -> ImpStrictness Name
198 -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
200 tc_strictness e ty_maybe rec_final_id info
201 = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
202 if sw_chkr IgnoreStrictnessPragmas then
203 returnB_Tc (noInfo, noInfo_UF)
205 do_strictness e ty_maybe rec_final_id info
210 do_strictness e ty_maybe rec_final_id NoImpStrictness
211 = returnB_Tc (noInfo, noInfo_UF)
214 We come to a nasty one now. We have strictness info---possibly
215 implying a worker---but (for whatever reason) no {\em type}
216 information for the wrapper. We therefore want (a)~{\em not} to
217 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
218 never asked for (!); and (b)~we want to keep the strictness/absence
219 info, because there's too much good stuff there to ignore completely.
220 We are not bothered about any pragmatic info for any alleged worker.
221 NB: this code applies only to {\em imported} info. So here we go:
224 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
228 then mkBottomStrictnessInfo
229 else mkStrictnessInfo arg_info Nothing
231 returnB_Tc (strictness_info, noInfo_UF)
232 -- no unfolding: the key --^^^^^^
235 And, finally, the have-everthing, know-everything, do-everything
238 do_strictness e (Just wrapper_ty) rec_final_id
239 (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
241 | is_bot -- it's a "bottoming Id"
242 = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
244 | not (indicatesWorker wrap_arg_info)
246 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
249 = -- Strictness info suggests a worker. Things could still
250 -- go wrong if there's an abstract type involved, mind you.
252 (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
253 n_wrapper_args = length wrap_arg_info
254 -- Don't have more args than this, else you risk
257 getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
258 getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
261 (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
263 inst_arg_tys = map (instantiateTy inst_env) arg_tys
264 (undropped_inst_arg_tys, dropped_inst_arg_tys)
265 = splitAt n_wrapper_args inst_arg_tys
267 inst_ret_ty = glueTyArgs dropped_inst_arg_tys
268 (instantiateTy inst_env ret_ty)
270 args = zipWith mk_arg arg_uniqs undropped_inst_arg_tys
271 mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
272 -- ASSERT: length args = n_wrapper_args
275 uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
276 `thenB_Tc` \ result ->
279 Nothing -> -- Alas, we met an abstract type
280 returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
282 Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
285 worker_ty = worker_ty_w_hole inst_ret_ty
287 getUniqueB_Tc `thenB_Tc` \ uniq ->
288 fixB_Tc ( \ rec_wrkr_id ->
293 wrkr_pragmas `thenB_Tc` \ wrkr_id_info ->
295 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
296 (wrkr_id_info `addInfo` worker_strictness))
297 -- Note: the above will *clobber* any strictness
298 -- info for the worker which was read in from the
299 -- interface (but there usually isn't any).
301 ) `thenB_Tc` \ worker_id ->
304 wrapper_rhs = wrapper_w_hole worker_id
305 n_tyvars = length tyvars
310 mkStrictnessInfo wrap_arg_info (Just worker_id),
311 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
312 -- We only do this for imported things, which this is.
318 -> Id -- final Id for which these are specialisations (do not *touch*)
320 -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
323 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
324 = returnB_Tc nullSpecEnv -- ToDo: msg????????
326 tc_specs e rec_main_id (Just main_ty) spec_pragmas
327 = mapB_Tc do_one_pragma spec_pragmas `thenB_Tc` \ spec_infos ->
328 returnB_Tc (mkSpecEnv spec_infos)
330 (main_tyvars, _) = splitForalls main_ty
335 do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
336 = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
337 `thenB_Tc` \ maybe_tys ->
338 getSrcLocB_Tc `thenB_Tc` \ locn ->
339 getUniqueB_Tc `thenB_Tc` \ uniq ->
341 checkB_Tc (length main_tyvars /= length maybe_tys)
342 (badSpecialisationErr "value" "wrong number of specialising types"
343 (length main_tyvars) maybe_tys locn)
346 spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
348 fixB_Tc ( \ rec_spec_id ->
350 tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
351 `thenB_Tc` \ spec_id_info ->
353 returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
355 ) `thenB_Tc` \ spec_id ->
357 returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
359 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
360 tc_ty_maybe rec_ce rec_tce (Just ty)
361 = tcMonoType rec_ce rec_tce nullTVE ty `thenB_Tc` \ new_ty ->
362 returnB_Tc (Just new_ty)
366 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
367 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
369 tc_unfolding e (ImpUnfolding guidance uf_core)
370 = tc_uf_core nullLVE nullTVE uf_core `thenB_Tc` \ core_expr ->
371 getSrcLocB_Tc `thenB_Tc` \ locn ->
373 -- Bad unfoldings are so painful that we always lint-check them,
374 -- marking them with BadUnfolding if lintUnfolding fails
375 -- NB: We cant check the lint result and return noInfo_UF if
376 -- lintUnfolding failed as this is too strict
377 -- Instead getInfo_UF tests for BadUnfolding and converts
378 -- to NoUnfoldingDetails when the unfolding is accessed
380 maybe_lint_expr = lintUnfolding locn core_expr
382 (lint_guidance, lint_expr) = case maybe_lint_expr of
383 Just lint_expr -> (guidance, lint_expr)
384 Nothing -> (BadUnfolding, panic_expr)
386 returnB_Tc (mkUnfolding lint_guidance lint_expr)
391 panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
393 tc_uf_core :: LVE -- lookup table for local binders
394 -- (others: we hope we can figure them out)
395 -> TVE -- lookup table for tyvars
396 -> UnfoldingCoreExpr Name
397 -> Baby_TcM PlainCoreExpr
399 tc_uf_core lve tve (UfCoVar v)
400 = tc_uf_Id lve v `thenB_Tc` \ id ->
401 returnB_Tc (CoVar id)
403 tc_uf_core lve tve (UfCoLit l)
404 = returnB_Tc (CoLit l)
406 tc_uf_core lve tve (UfCoCon con tys as)
407 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
408 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
409 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
410 returnB_Tc (CoCon con_id core_tys core_atoms)
412 -- If a ccall, we have to patch in the types read from the pragma.
414 tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
415 = ASSERT(null app_tys)
416 mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
417 tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
418 mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
419 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
420 returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
421 core_app_tys core_atoms)
423 tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
424 = mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
425 mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
426 returnB_Tc (CoPrim op core_tys core_atoms)
428 tc_uf_core lve tve (UfCoLam binders body)
429 = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
431 new_binders = map snd lve2
432 new_lve = lve2 `plusLVE` lve
434 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
435 returnB_Tc (CoLam new_binders new_body)
437 tc_uf_core lve tve (UfCoTyLam tv body)
439 (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
440 new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
442 tc_uf_core lve new_tve body `thenB_Tc` \ new_body ->
443 returnB_Tc (CoTyLam new_tv new_body)
445 tc_uf_core lve tve (UfCoApp fun arg)
446 = tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
447 tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
448 returnB_Tc (CoApp new_fun new_arg)
450 tc_uf_core lve tve (UfCoTyApp expr ty)
451 = tc_uf_core lve tve expr `thenB_Tc` \ new_expr ->
452 tc_uf_type tve ty `thenB_Tc` \ new_ty ->
453 returnB_Tc (mkCoTyApp new_expr new_ty)
455 tc_uf_core lve tve (UfCoCase scrut alts)
456 = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
457 tc_alts alts `thenB_Tc` \ new_alts ->
458 returnB_Tc (CoCase new_scrut new_alts)
460 tc_alts (UfCoAlgAlts alts deflt)
461 = mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
462 tc_deflt deflt `thenB_Tc` \ new_deflt ->
463 returnB_Tc (CoAlgAlts new_alts new_deflt)
465 tc_alg_alt (con, params, rhs)
466 = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
467 tc_uf_binders tve params `thenB_Tc` \ lve2 ->
469 new_params = map snd lve2
470 new_lve = lve2 `plusLVE` lve
472 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
473 returnB_Tc (con_id, new_params, new_rhs)
475 tc_alts (UfCoPrimAlts alts deflt)
476 = mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
477 tc_deflt deflt `thenB_Tc` \ new_deflt ->
478 returnB_Tc (CoPrimAlts new_alts new_deflt)
480 tc_prim_alt (lit, rhs)
481 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
482 returnB_Tc (lit, new_rhs)
484 tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
485 tc_deflt (UfCoBindDefault b rhs)
486 = tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
488 [new_b] = map snd lve2
489 new_lve = lve2 `plusLVE` lve
491 tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
492 returnB_Tc (CoBindDefault new_b new_rhs)
494 tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
495 = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
496 tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
498 [new_b] = map snd lve2
499 new_lve = lve2 `plusLVE` lve
501 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
502 returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
504 tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
506 (binders, rhss) = unzip pairs
508 tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
510 new_binders = map snd lve2
511 new_lve = lve2 `plusLVE` lve
513 mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
514 tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
515 returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
517 tc_uf_core lve tve (UfCoSCC uf_cc body)
518 = tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
519 tc_uf_core lve tve body `thenB_Tc` \ new_body ->
520 returnB_Tc (CoSCC new_cc new_body)
522 tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
523 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
524 returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
526 tc_uf_cc (UfDictCC id m g is_dupd is_caf)
527 = tc_uf_Id lve id `thenB_Tc` \ new_id ->
528 returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
530 tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
532 tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
533 tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
536 adjust is_caf is_dupd cc
538 maybe_cafify = if is_caf then cafifyCC else (\x->x)
539 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
541 maybe_dupify (maybe_cafify cc)
544 tc_uf_atom lve tve (UfCoLitAtom l)
545 = returnB_Tc (CoLitAtom l)
547 tc_uf_atom lve tve (UfCoVarAtom v)
548 = tc_uf_Id lve v `thenB_Tc` \ new_v ->
549 returnB_Tc (CoVarAtom new_v)
552 tc_uf_binders tve ids_and_tys
554 (ids, tys) = unzip ids_and_tys
556 mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ new_tys ->
558 returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
561 -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
563 tc_uf_tyvar (Short u short_name)
565 tyvar = mkUserTyVar u short_name
567 (tyvar, u, mkTyVarTy tyvar)
570 tc_uf_Id lve (BoringUfId v)
571 = case (assocMaybe lve v) of
572 Just xx -> returnB_Tc xx
573 Nothing -> case (lookupE_ValueQuietly e v) of
574 Just xx -> returnB_Tc xx
575 Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
576 -- (ppCat [ppStr "Failed lookup for BoringUfId:",
578 (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
579 -- will be recover'd from
580 -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
582 tc_uf_Id lve (SuperDictSelUfId c sc)
584 clas = lookupCE rec_ce c
585 super_clas = lookupCE rec_ce sc
587 returnB_Tc (getSuperDictSelId clas super_clas)
589 tc_uf_Id lve (ClassOpUfId c op_name)
591 clas = lookupCE rec_ce c
592 op = lookup_class_op clas op_name
594 returnB_Tc (getClassOpId clas op)
596 tc_uf_Id lve (DefaultMethodUfId c op_name)
598 clas = lookupCE rec_ce c
599 op = lookup_class_op clas op_name
601 returnB_Tc (getDefaultMethodId clas op)
603 tc_uf_Id lve uf_id@(DictFunUfId c ty)
604 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
606 clas = lookupCE rec_ce c
607 dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
609 Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
610 (ppr PprDebug (UfCoVar uf_id))
611 -- The class and type are both
612 -- visible, so the instance should
613 -- jolly well be too!
617 tc_uf_Id lve (ConstMethodUfId c op_name ty)
618 = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
620 clas = lookupCE rec_ce c
621 op = lookup_class_op clas op_name
623 returnB_Tc (getConstMethodId clas op new_ty)
625 tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
626 = tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
627 mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
628 `thenB_Tc` \ maybe_tys ->
630 spec_id = lookupSpecId unspec_id maybe_tys
634 tc_uf_Id lve (WorkerUfId unwrkr)
635 = tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
637 strictness_info = getIdStrictness unwrkr_id
639 if isLocallyDefined unwrkr_id
641 -- A locally defined value will not have any strictness info (yet),
642 -- so we can't extract the locally defined worker Id from it :-(
644 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
645 (ppCat [ppStr "Worker Id in unfolding is defined locally:",
646 ppr PprDebug unwrkr_id])
647 (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
648 -- will be recover'd from
650 returnB_Tc (getWorkerId strictness_info)
653 lookup_class_op clas (ClassOpName _ _ _ tag)
654 = getClassOps clas !! (tag - 1)
656 ---------------------------------------------------------------------
657 tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
659 tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
662 %************************************************************************
664 \subsection[tcDataPragmas]{@data@ type pragmas}
666 %************************************************************************
668 The purpose of a @data@ pragma is to convey data-constructor
669 information that would otherwise be unknown.
671 It also records specialisation information which is added to each data
672 constructor. This info just contains the type info for the
673 specialisations which exist. No specialised Ids are actually created.
676 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
677 -> RenamedDataPragmas
678 -> Baby_TcM ([RenamedConDecl], -- any pragma condecls
679 [SpecInfo]) -- specialisation info from pragmas
681 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
682 = mapB_Tc do_one_spec specs `thenB_Tc` \ spec_infos ->
683 returnB_Tc (con_decls, spec_infos)
685 do_one_spec maybe_monotys
686 = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
687 `thenB_Tc` \ maybe_tys ->
688 getSrcLocB_Tc `thenB_Tc` \ locn ->
690 checkB_Tc (length new_tyvars /= length maybe_tys)
691 (badSpecialisationErr "data" "wrong number of specialising types"
692 (length new_tyvars) maybe_tys locn)
695 checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys)))
696 (badSpecialisationErr "data" "not all unboxed types"
697 (length new_tyvars) maybe_tys locn)
700 returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
703 %************************************************************************
705 \subsection[tcTypePragmas]{@type@ synonym pragmas}
707 %************************************************************************
709 The purpose of a @type@ pragma is to say that the synonym's
710 representation should not be used by the user.
713 tcTypePragmas :: TypePragmas
714 -> Bool -- True <=> abstract synonym, please
716 tcTypePragmas NoTypePragmas = False
717 tcTypePragmas AbstractTySynonym = True