ghc/compiler/typecheck/TcPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcPragmas (
  10         tcClassOpPragmas,
  11         tcDataPragmas,
  12         tcDictFunPragmas,
  13         tcGenPragmas
  14     ) where
  15
  16 import TcMonad          -- typechecking monadic machinery
  17 import HsSyn            -- the stuff being typechecked
  18
  19 import PrelInfo         ( PrimOp(..)    -- to see CCallOp
  20                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  21                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  22                         )
  23 import Type
  24 import CmdLineOpts
  25 import CostCentre
  26 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  27 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  28 import Id
  29 import IdInfo
  30 --import WwLib          ( mkWwBodies )
  31 import Maybes           ( assocMaybe, catMaybes, Maybe(..) )
  32 --import CoreLint               ( lintUnfolding )
  33 import TcMonoType       ( tcMonoType, tcPolyType )
  34 import Util
  35 import SrcLoc
  36 \end{code}
  37
  38 The basic idea is: Given an @Id@ that only lacks its @IdInfo@
  39 (represented as a function \tr{IdInfo -> Id}, use the pragmas given to
  40 figure out the @IdInfo@, then give back the now-complete @Id@.
  41
  42 Of course, the pragmas also need to be checked.
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 \begin{code}
  51 tcClassOpPragmas :: E                   -- Class/TyCon lookup tables
  52              -> Type                    -- global type of the class method
  53              -> Id                      -- *final* ClassOpId
  54              -> Id                      -- *final* DefaultMethodId
  55              -> SpecEnv                 -- Instance info for this class op
  56              -> RenamedClassOpPragmas   -- info w/ which to complete, giving...
  57              -> Baby_TcM (IdInfo, IdInfo)       -- ... final info for ClassOp and DefaultMethod
  58
  59 tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
  60   = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
  61
  62 tcClassOpPragmas e global_ty
  63                  rec_classop_id rec_defm_id
  64                  spec_infos
  65                  (ClassOpPragmas classop_pragmas defm_pragmas)
  66   = tcGenPragmas e
  67                  Nothing{-ty unknown-} rec_classop_id
  68                  classop_pragmas        `thenB_Tc` \ classop_idinfo ->
  69
  70     tcGenPragmas e
  71                  Nothing{-ty unknown-} rec_defm_id
  72                  defm_pragmas           `thenB_Tc` \ defm_idinfo ->
  73
  74     returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 {\em Every} instance declaration produces a ``dictionary function''
  84 (dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
  85 convey information about a DictFunId.
  86
  87 \begin{code}
  88 tcDictFunPragmas
  89         :: E                        -- Class/TyCon lookup tables
  90         -> Type             -- DictFunId type
  91         -> Id                       -- final DictFunId (don't touch)
  92         -> RenamedInstancePragmas   -- info w/ which to complete, giving...
  93         -> Baby_TcM IdInfo          -- ... final DictFun IdInfo
  94
  95 tcDictFunPragmas _ _ final_dfun NoInstancePragmas
  96   = returnB_Tc noIdInfo
  97
  98 tcDictFunPragmas e dfun_ty final_dfun pragmas
  99   = let
 100         dfun_pragmas
 101           = case pragmas of
 102               SimpleInstancePragma      x   -> x
 103               ConstantInstancePragma    x _ -> x
 104               SpecialisedInstancePragma x _ -> x
 105     in
 106     tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection[tcGenPragmas]{Basic pragmas about a value}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
 116 a problem, it just returns @noIdInfo@.
 117
 118 \begin{code}
 119 tcGenPragmas
 120         :: E                    -- lookup table
 121         -> Maybe Type   -- of Id, if we have it (for convenience)
 122         -> Id                   -- *incomplete* Id (do not *touch*!)
 123         -> RenamedGenPragmas    -- info w/ which to complete, giving...
 124         -> Baby_TcM IdInfo      -- IdInfo for this Id
 125
 126 tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
 127   = returnB_Tc noIdInfo
 128
 129 tcGenPragmas e ty_maybe rec_final_id
 130              (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
 131   =     -- Guarantee success!
 132     recoverIgnoreErrorsB_Tc noIdInfo (
 133
 134         -- OK, now we do the business
 135     let
 136         arity_info  = get_arity  arity_maybe
 137         upd_info    = get_upd    upd_maybe
 138     in
 139     tc_strictness e ty_maybe rec_final_id strictness
 140                                 `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
 141
 142         -- If the unfolding fails to look consistent, we don't
 143         -- want to junk *all* the IdInfo
 144     recoverIgnoreErrorsB_Tc noInfo_UF (
 145         tc_unfolding e unfold
 146     )                           `thenB_Tc` \ unfold_info ->
 147
 148         -- Same as unfolding; if we fail, don't junk all IdInfo
 149     recoverIgnoreErrorsB_Tc nullSpecEnv (
 150         tc_specs e rec_final_id ty_maybe specs
 151     )                           `thenB_Tc` \ spec_env ->
 152
 153     returnB_Tc (
 154         noIdInfo
 155         `addInfo` arity_info
 156         `addInfo` upd_info
 157         `addInfo` def
 158
 159             -- The strictness info *may* imply an unfolding
 160             -- (the "wrapper_unfold"); that info is added; if
 161             -- there is also an explicit unfolding, it will
 162             -- take precedence, because it is "added" later.
 163         `addInfo` strict_info
 164         `addInfo_UF` wrapper_unfold_info
 165
 166         `addInfo_UF` unfold_info
 167         `addInfo` spec_env
 168     ))
 169   where
 170     get_arity Nothing  = noInfo
 171     get_arity (Just a) = mkArityInfo a
 172
 173     get_upd Nothing  = noInfo
 174     get_upd (Just u) = (u :: UpdateInfo)
 175 \end{code}
 176
 177 Don't use the strictness info if a flag set.
 178 \begin{code}
 179 tc_strictness
 180         :: E
 181         -> Maybe Type
 182         -> Id           -- final Id (do not *touch*)
 183         -> ImpStrictness Name
 184         -> Baby_TcM (StrictnessInfo, UnfoldingDetails)
 185
 186 tc_strictness e ty_maybe rec_final_id info
 187   = getSwitchCheckerB_Tc    `thenB_Tc` \ sw_chkr ->
 188     if sw_chkr IgnoreStrictnessPragmas then
 189         returnB_Tc (noInfo, noInfo_UF)
 190     else
 191         do_strictness e ty_maybe rec_final_id info
 192 \end{code}
 193
 194 An easy one first:
 195 \begin{code}
 196 do_strictness e ty_maybe rec_final_id NoImpStrictness
 197   = returnB_Tc (noInfo, noInfo_UF)
 198 \end{code}
 199
 200 We come to a nasty one now.  We have strictness info---possibly
 201 implying a worker---but (for whatever reason) no {\em type}
 202 information for the wrapper.  We therefore want (a)~{\em not} to
 203 create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
 204 never asked for (!); and (b)~we want to keep the strictness/absence
 205 info, because there's too much good stuff there to ignore completely.
 206 We are not bothered about any pragmatic info for any alleged worker.
 207 NB: this code applies only to {\em imported} info.  So here we go:
 208
 209 \begin{code}
 210 do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
 211   = let
 212         strictness_info
 213           = if is_bot
 214             then mkBottomStrictnessInfo
 215             else mkStrictnessInfo arg_info Nothing
 216     in
 217     returnB_Tc (strictness_info, noInfo_UF)
 218       -- no unfolding: the key --^^^^^^
 219 \end{code}
 220
 221 And, finally, the have-everthing, know-everything, do-everything
 222 ``normal case''.
 223 \begin{code}
 224 do_strictness e (Just wrapper_ty) rec_final_id
 225               (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
 226
 227   | is_bot -- it's a "bottoming Id"
 228   = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
 229
 230   | not (indicatesWorker wrap_arg_info)
 231   = -- No worker
 232     returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 233
 234   | otherwise
 235   = -- Strictness info suggests a worker.  Things could still
 236     -- go wrong if there's an abstract type involved, mind you.
 237     let
 238         (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
 239         n_wrapper_args              = length wrap_arg_info
 240                 -- Don't have more args than this, else you risk
 241                 -- losing laziness!!
 242     in
 243     getUniquesB_Tc (length tv_tmpls)    `thenB_Tc` \ tyvar_uniqs ->
 244     getUniquesB_Tc n_wrapper_args       `thenB_Tc` \ arg_uniqs ->
 245
 246     let
 247         (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
 248
 249         inst_arg_tys = map (instantiateTy inst_env) arg_tys
 250         (undropped_inst_arg_tys, dropped_inst_arg_tys)
 251           = splitAt n_wrapper_args inst_arg_tys
 252
 253         inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 254                                   (instantiateTy inst_env ret_ty)
 255
 256         args         = zipWithEqual mk_arg arg_uniqs    undropped_inst_arg_tys
 257         mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
 258         -- ASSERT: length args = n_wrapper_args
 259     in
 260
 261     uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
 262                                                         `thenB_Tc` \ result ->
 263     case result of
 264
 265         Nothing ->      -- Alas, we met an abstract type
 266             returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
 267
 268         Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 269
 270             let
 271                 worker_ty   = worker_ty_w_hole inst_ret_ty
 272             in
 273             getUniqueB_Tc `thenB_Tc` \ uniq ->
 274             fixB_Tc ( \ rec_wrkr_id ->
 275
 276                 tcGenPragmas e
 277                          (Just worker_ty)
 278                          rec_wrkr_id
 279                          wrkr_pragmas   `thenB_Tc` \ wrkr_id_info ->
 280
 281                 returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
 282                                 (wrkr_id_info `addInfo` worker_strictness))
 283                         -- Note: the above will *clobber* any strictness
 284                         -- info for the worker which was read in from the
 285                         -- interface (but there usually isn't any).
 286
 287             ) `thenB_Tc` \ worker_id ->
 288
 289             let
 290                 wrapper_rhs = wrapper_w_hole worker_id
 291                 n_tyvars    = length tyvars
 292                 arity       = length args
 293
 294             in
 295             returnB_Tc (
 296                 mkStrictnessInfo wrap_arg_info (Just worker_id),
 297                 mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
 298                     -- We only do this for imported things, which this is.
 299             )
 300 \end{code}
 301
 302 \begin{code}
 303 tc_specs :: E
 304          -> Id -- final Id for which these are specialisations (do not *touch*)
 305          -> Maybe Type
 306          -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
 307          -> Baby_TcM SpecEnv
 308
 309 tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
 310   = returnB_Tc nullSpecEnv  -- ToDo: msg????????
 311
 312 tc_specs e rec_main_id (Just main_ty) spec_pragmas
 313   = mapB_Tc do_one_pragma spec_pragmas  `thenB_Tc` \ spec_infos ->
 314     returnB_Tc (mkSpecEnv spec_infos)
 315   where
 316     (main_tyvars, _) = splitForalls main_ty
 317
 318     rec_ce  = getE_CE  e
 319     rec_tce = getE_TCE e
 320
 321     do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
 322       = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
 323                                 `thenB_Tc` \ maybe_tys ->
 324         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 325         getUniqueB_Tc           `thenB_Tc` \ uniq ->
 326
 327         checkB_Tc (length main_tyvars /= length maybe_tys)
 328                 (badSpecialisationErr "value" "wrong number of specialising types"
 329                                       (length main_tyvars) maybe_tys locn)
 330                                 `thenB_Tc_`
 331         let
 332             spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
 333         in
 334         fixB_Tc ( \ rec_spec_id ->
 335
 336             tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
 337                 `thenB_Tc` \ spec_id_info ->
 338
 339             returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
 340
 341         ) `thenB_Tc` \ spec_id ->
 342
 343         returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
 344
 345 tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
 346 tc_ty_maybe rec_ce rec_tce (Just ty)
 347   = tcMonoType rec_ce rec_tce nullTVE ty        `thenB_Tc` \ new_ty ->
 348     returnB_Tc (Just new_ty)
 349 \end{code}
 350
 351 \begin{code}
 352 tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
 353 tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
 354
 355 tc_unfolding e (ImpUnfolding guidance uf_core)
 356   = tc_uf_core nullLVE nullTVE uf_core  `thenB_Tc` \ core_expr ->
 357     getSrcLocB_Tc                       `thenB_Tc` \ locn ->
 358     let
 359         -- Bad unfoldings are so painful that we always lint-check them,
 360         -- marking them with BadUnfolding if lintUnfolding fails
 361         -- NB: We cant check the lint result and return noInfo_UF if
 362         --     lintUnfolding failed as this is too strict
 363         --     Instead getInfo_UF tests for BadUnfolding and converts
 364         --     to NoUnfoldingDetails when the unfolding is accessed
 365
 366         maybe_lint_expr = lintUnfolding locn core_expr
 367
 368         (lint_guidance, lint_expr) = case maybe_lint_expr of
 369           Just lint_expr -> (guidance, lint_expr)
 370           Nothing        -> (BadUnfolding, panic_expr)
 371     in
 372     returnB_Tc (mkUnfolding lint_guidance lint_expr)
 373   where
 374     rec_ce  = getE_CE  e
 375     rec_tce = getE_TCE e
 376
 377     panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
 378
 379     tc_uf_core :: LVE       -- lookup table for local binders
 380                             -- (others: we hope we can figure them out)
 381                -> TVE       -- lookup table for tyvars
 382                -> UnfoldingCoreExpr Name
 383                -> Baby_TcM CoreExpr
 384
 385     tc_uf_core lve tve (UfVar v)
 386       = tc_uf_Id lve v          `thenB_Tc` \ id ->
 387         returnB_Tc (Var id)
 388
 389     tc_uf_core lve tve (UfLit l)
 390       = returnB_Tc (Lit l)
 391
 392     tc_uf_core lve tve (UfCon con tys as)
 393       = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 394         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ core_tys ->
 395         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 396         returnB_Tc (Con con_id core_tys core_atoms)
 397
 398     --  If a ccall, we have to patch in the types read from the pragma.
 399
 400     tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
 401       = ASSERT(null app_tys)
 402         mapB_Tc (tc_uf_type tve) arg_tys        `thenB_Tc` \ core_arg_tys ->
 403         tc_uf_type tve res_ty           `thenB_Tc` \ core_res_ty ->
 404         mapB_Tc (tc_uf_type tve) app_tys        `thenB_Tc` \ core_app_tys ->
 405         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 406         returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
 407                          core_app_tys core_atoms)
 408
 409     tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
 410       = mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ core_tys ->
 411         mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
 412         returnB_Tc (Prim op core_tys core_atoms)
 413
 414     tc_uf_core lve tve (UfLam binder body)
 415       = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
 416         let
 417             [new_binder] = map snd lve2
 418             new_lve     = lve2 `plusLVE` lve
 419         in
 420         tc_uf_core new_lve tve body      `thenB_Tc` \ new_body ->
 421         returnB_Tc (Lam new_binder new_body)
 422
 423     tc_uf_core lve tve (UfApp fun arg)
 424       = tc_uf_core lve tve fun  `thenB_Tc` \ new_fun ->
 425         tc_uf_atom lve tve arg  `thenB_Tc` \ new_arg ->
 426         returnB_Tc (App new_fun new_arg)
 427
 428     tc_uf_core lve tve (UfCase scrut alts)
 429       = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
 430         tc_alts alts             `thenB_Tc` \ new_alts ->
 431         returnB_Tc (Case new_scrut new_alts)
 432       where
 433         tc_alts (UfCoAlgAlts alts deflt)
 434           = mapB_Tc tc_alg_alt alts   `thenB_Tc` \ new_alts ->
 435             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 436             returnB_Tc (AlgAlts new_alts new_deflt)
 437           where
 438             tc_alg_alt (con, params, rhs)
 439               = tc_uf_Id lve (BoringUfId con)   `thenB_Tc` \ con_id ->
 440                 tc_uf_binders tve params        `thenB_Tc` \ lve2 ->
 441                 let
 442                     new_params = map snd lve2
 443                     new_lve    = lve2 `plusLVE` lve
 444                 in
 445                 tc_uf_core new_lve tve rhs      `thenB_Tc` \ new_rhs ->
 446                 returnB_Tc (con_id, new_params, new_rhs)
 447
 448         tc_alts (UfCoPrimAlts alts deflt)
 449           = mapB_Tc tc_prim_alt alts  `thenB_Tc` \ new_alts ->
 450             tc_deflt deflt          `thenB_Tc` \ new_deflt ->
 451             returnB_Tc (PrimAlts new_alts new_deflt)
 452           where
 453             tc_prim_alt (lit, rhs)
 454               = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 455                 returnB_Tc (lit, new_rhs)
 456
 457         tc_deflt UfCoNoDefault = returnB_Tc NoDefault
 458         tc_deflt (UfCoBindDefault b rhs)
 459           = tc_uf_binders tve [b]       `thenB_Tc` \ lve2 ->
 460             let
 461                 [new_b] = map snd lve2
 462                 new_lve = lve2 `plusLVE` lve
 463             in
 464             tc_uf_core new_lve tve rhs  `thenB_Tc` \ new_rhs ->
 465             returnB_Tc (BindDefault new_b new_rhs)
 466
 467     tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
 468       = tc_uf_core lve tve rhs  `thenB_Tc` \ new_rhs ->
 469         tc_uf_binders tve [b]   `thenB_Tc` \ lve2 ->
 470         let
 471             [new_b] = map snd lve2
 472             new_lve = lve2 `plusLVE` lve
 473         in
 474         tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
 475         returnB_Tc (Let (NonRec new_b new_rhs) new_body)
 476
 477     tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
 478       = let
 479             (binders, rhss) = unzip pairs
 480         in
 481         tc_uf_binders tve binders   `thenB_Tc` \ lve2 ->
 482         let
 483             new_binders = map snd lve2
 484             new_lve     = lve2 `plusLVE` lve
 485         in
 486         mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
 487         tc_uf_core new_lve tve         body `thenB_Tc` \ new_body ->
 488         returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
 489
 490     tc_uf_core lve tve (UfSCC uf_cc body)
 491       = tc_uf_cc   uf_cc            `thenB_Tc` \ new_cc ->
 492         tc_uf_core lve tve body     `thenB_Tc` \ new_body ->
 493         returnB_Tc (SCC new_cc new_body)
 494       where
 495         tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
 496           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 497             returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
 498
 499         tc_uf_cc (UfDictCC id m g is_dupd is_caf)
 500           = tc_uf_Id lve id     `thenB_Tc` \ new_id ->
 501             returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
 502
 503         tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
 504
 505         tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
 506         tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
 507
 508         --------
 509         adjust is_caf is_dupd cc
 510           = let
 511                 maybe_cafify = if is_caf  then cafifyCC else (\x->x)
 512                 maybe_dupify = if is_dupd then dupifyCC else (\x->x)
 513             in
 514             maybe_dupify (maybe_cafify cc)
 515
 516     ---------------
 517     tc_uf_atom lve tve (UfCoLitAtom l)
 518       = returnB_Tc (LitArg l)
 519
 520     tc_uf_atom lve tve (UfCoVarAtom v)
 521       = tc_uf_Id lve v                  `thenB_Tc` \ new_v ->
 522         returnB_Tc (VarArg new_v)
 523
 524     ---------------
 525     tc_uf_binders tve ids_and_tys
 526       = let
 527             (ids, tys) = unzip ids_and_tys
 528         in
 529         mapB_Tc (tc_uf_type tve) tys    `thenB_Tc` \ new_tys ->
 530
 531         returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
 532
 533     ---------------
 534     -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
 535
 536     tc_uf_tyvar (Short u short_name)
 537       = let
 538             tyvar = mkUserTyVar u short_name
 539         in
 540         (tyvar, u, mkTyVarTy tyvar)
 541
 542     ---------------
 543     tc_uf_Id lve (BoringUfId v)
 544       = case (assocMaybe lve v) of
 545           Just xx -> returnB_Tc xx
 546           Nothing -> case (lookupE_ValueQuietly e v) of
 547                        Just xx -> returnB_Tc xx
 548                        Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 549                                   --       (ppCat [ppStr "Failed lookup for BoringUfId:",
 550                                   --               ppr PprDebug v])
 551                                   (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
 552                                   -- will be recover'd from
 553                                   -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
 554
 555     tc_uf_Id lve (SuperDictSelUfId c sc)
 556       = let
 557             clas       = lookupCE rec_ce c
 558             super_clas = lookupCE rec_ce sc
 559         in
 560         returnB_Tc (getSuperDictSelId clas super_clas)
 561
 562     tc_uf_Id lve (ClassOpUfId c op_name)
 563       = let
 564             clas = lookupCE rec_ce c
 565             op   = lookup_class_op clas op_name
 566         in
 567         returnB_Tc (getClassOpId clas op)
 568
 569     tc_uf_Id lve (DefaultMethodUfId c op_name)
 570       = let
 571             clas = lookupCE rec_ce c
 572             op   = lookup_class_op clas op_name
 573         in
 574         returnB_Tc (getDefaultMethodId clas op)
 575
 576     tc_uf_Id lve uf_id@(DictFunUfId c ty)
 577       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 578         let
 579             clas = lookupCE rec_ce c
 580             dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
 581                           Just id -> id
 582                           Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
 583                                         (ppr PprDebug (UfVar uf_id))
 584                                         -- The class and type are both
 585                                         -- visible, so the instance should
 586                                         -- jolly well be too!
 587         in
 588         returnB_Tc dfun_id
 589
 590     tc_uf_Id lve (ConstMethodUfId c op_name ty)
 591       = tc_uf_type nullTVE ty   `thenB_Tc` \ new_ty ->
 592         let
 593             clas = lookupCE rec_ce c
 594             op   = lookup_class_op clas op_name
 595         in
 596         returnB_Tc (getConstMethodId clas op new_ty)
 597
 598     tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
 599       = tc_uf_Id lve unspec         `thenB_Tc` \ unspec_id ->
 600         mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
 601                                     `thenB_Tc` \ maybe_tys ->
 602         let
 603            spec_id = lookupSpecId unspec_id maybe_tys
 604         in
 605         returnB_Tc spec_id
 606
 607     tc_uf_Id lve (WorkerUfId unwrkr)
 608       = tc_uf_Id lve unwrkr     `thenB_Tc` \ unwrkr_id ->
 609         let
 610             strictness_info = getIdStrictness unwrkr_id
 611         in
 612         if isLocallyDefined unwrkr_id
 613         then
 614             -- A locally defined value will not have any strictness info (yet),
 615             -- so we can't extract the locally defined worker Id from it :-(
 616
 617             pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 618                      (ppCat [ppStr "Worker Id in unfolding is defined locally:",
 619                              ppr PprDebug unwrkr_id])
 620             (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
 621             -- will be recover'd from
 622         else
 623             returnB_Tc (getWorkerId strictness_info)
 624
 625     ---------------
 626     lookup_class_op clas (ClassOpName _ _ _ tag)
 627       = getClassOps clas !! (tag - 1)
 628
 629     ---------------------------------------------------------------------
 630     tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
 631
 632     tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
 633 \end{code}
 634
 635 %************************************************************************
 636 %*                                                                      *
 637 \subsection[tcDataPragmas]{@data@ type pragmas}
 638 %*                                                                      *
 639 %************************************************************************
 640
 641 The purpose of a @data@ pragma is to convey data-constructor
 642 information that would otherwise be unknown.
 643
 644 It also records specialisation information which is added to each data
 645 constructor. This info just contains the type info for the
 646 specialisations which exist. No specialised Ids are actually created.
 647
 648 \begin{code}
 649 tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
 650               -> RenamedDataPragmas
 651               -> Baby_TcM ([RenamedConDecl],    -- any pragma condecls
 652                            [SpecInfo])          -- specialisation info from pragmas
 653
 654 tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
 655   = mapB_Tc do_one_spec specs           `thenB_Tc` \ spec_infos ->
 656     returnB_Tc (con_decls, spec_infos)
 657   where
 658     do_one_spec maybe_monotys
 659       = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
 660                                 `thenB_Tc` \ maybe_tys ->
 661         getSrcLocB_Tc           `thenB_Tc` \ locn ->
 662
 663         checkB_Tc (length new_tyvars /= length maybe_tys)
 664                 (badSpecialisationErr "data" "wrong number of specialising types"
 665                                       (length new_tyvars) maybe_tys locn)
 666                                 `thenB_Tc_`
 667
 668         checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
 669                 (badSpecialisationErr "data" "not all unboxed types"
 670                                       (length new_tyvars) maybe_tys locn)
 671                                 `thenB_Tc_`
 672
 673         returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
 674 \end{code}