ghc/compiler/reader/ReadPragmas2.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[ReadPragmas2]{Read pragmatic interface info, including Core}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ReadPragmas2 (
  10         ProtoUfBinder(..),
  11
  12         wlkClassPragma,
  13         wlkDataPragma,
  14         wlkInstPragma,
  15         wlkTySigPragmas,
  16         wlkTypePragma
  17     ) where
  18
  19 IMPORT_Trace            -- ToDo: rm (debugging)
  20 import Pretty
  21
  22 import UgenAll
  23
  24 import AbsPrel          ( nilDataCon, readUnfoldingPrimOp, PrimOp(..)
  25                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  26                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  27                         )
  28 import PrimKind         ( guessPrimKind, PrimKind )
  29 import AbsSyn
  30 import BasicLit         ( mkMachInt, BasicLit(..) )
  31 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  32 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  33 import Id               ( mkTupleCon )
  34 import IdInfo           -- ( UnfoldingGuidance(..) )
  35 import Maybes           ( Maybe(..) )
  36 import PrefixToHs
  37 import PrefixSyn
  38 import ProtoName
  39 import Outputable
  40 import ReadPrefix2      ( wlkList, rdConDecl, wlkMonoType )
  41 import Util
  42 \end{code}
  43
  44 \begin{code}
  45 wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
  46
  47 wlkDataPragma pragma
  48   = case pragma of
  49       U_no_pragma    -> returnUgn (DataPragmas [] [])
  50       U_idata_pragma cs ss ->
  51         wlkList rdConDecl cs `thenUgn` \ cons  ->
  52         wlkList rd_spec   ss `thenUgn` \ specs ->
  53         returnUgn (DataPragmas cons specs)
  54   where
  55     rd_spec pt
  56       = rdU_hpragma pt  `thenUgn` \ stuff ->
  57         case stuff of { U_idata_pragma_4s ss ->
  58
  59         wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
  60         returnUgn specs }
  61 \end{code}
  62
  63 \begin{code}
  64 wlkTypePragma :: U_hpragma -> UgnM TypePragmas
  65
  66 wlkTypePragma pragma
  67   = case pragma of
  68       U_no_pragma    -> returnUgn NoTypePragmas
  69       U_itype_pragma -> returnUgn AbstractTySynonym
  70 \end{code}
  71
  72 \begin{code}
  73 wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
  74
  75 wlkClassPragma pragma
  76   = case pragma of
  77       U_no_pragma    -> returnUgn NoClassPragmas
  78       U_iclas_pragma gens ->
  79         wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
  80         ASSERT(not (null gen_pragmas))
  81         returnUgn (SuperDictPragmas gen_pragmas)
  82 \end{code}
  83
  84 \begin{code}
  85 wlkInstPragma :: U_hpragma -> UgnM (Maybe FAST_STRING, ProtoNameInstancePragmas)
  86
  87 wlkInstPragma pragma
  88   = case pragma of
  89       U_no_pragma    -> returnUgn (Nothing, NoInstancePragmas)
  90
  91       U_iinst_simpl_pragma modname dfun_gen ->
  92         wlkGenPragma dfun_gen   `thenUgn` \ gen_pragmas ->
  93         returnUgn (Just modname, SimpleInstancePragma gen_pragmas)
  94
  95       U_iinst_const_pragma modname dfun_gen constm_stuff ->
  96         wlkGenPragma      dfun_gen     `thenUgn` \ gen_pragma    ->
  97         wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
  98         returnUgn (Just modname, ConstantInstancePragma gen_pragma constm_pragmas)
  99
 100       U_iinst_spec_pragma modname dfun_gen spec_stuff ->
 101         wlkGenPragma    dfun_gen    `thenUgn` \ gen_pragma   ->
 102         wlkList rd_spec spec_stuff  `thenUgn` \ spec_pragmas ->
 103         returnUgn (Just modname, SpecialisedInstancePragma gen_pragma spec_pragmas)
 104   where
 105     rd_spec pt
 106       = rdU_hpragma pt `thenUgn` \ stuff ->
 107         case stuff of { U_iinst_pragma_3s maybe_tys num_dicts gen consts  ->
 108
 109         wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
 110         wlkGenPragma            gen      `thenUgn` \ gen_prag       ->
 111         wlkList rd_constm       consts   `thenUgn` \ constms        ->
 112         let
 113             inst_prag
 114               = if null constms then
 115                    if null_gen_prag gen_prag
 116                    then NoInstancePragmas
 117                    else SimpleInstancePragma gen_prag
 118                 else -- some constms...
 119                    ConstantInstancePragma gen_prag constms
 120         in
 121         returnUgn (mono_tys_maybe, num_dicts, inst_prag) }
 122       where
 123         null_gen_prag NoGenPragmas = True
 124         null_gen_prag _            = False
 125
 126 rd_constm pt
 127   = rdU_hpragma pt  `thenUgn` \ stuff ->
 128     case stuff of { U_iname_pragma_pr name gen ->
 129
 130     wlkGenPragma gen `thenUgn` \ prag ->
 131     returnUgn (name, prag) }
 132 \end{code}
 133
 134 \begin{code}
 135 rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
 136
 137 rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
 138
 139 wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
 140
 141 wlkGenPragma pragma
 142   = case pragma of
 143       U_no_pragma -> returnUgn NoGenPragmas
 144
 145       U_igen_pragma aritee update deforest strct uf speccs ->
 146         wlk_arity       aritee   `thenUgn` \ arity   ->
 147         wlk_update      update   `thenUgn` \ upd     ->
 148         wlk_deforest    deforest `thenUgn` \ def     ->
 149         wlk_strict      strct    `thenUgn` \ strict  ->
 150         wlk_unfold      uf       `thenUgn` \ unfold  ->
 151         wlkList rd_spec speccs   `thenUgn` \ specs   ->
 152         returnUgn (GenPragmas arity upd def strict unfold specs)
 153   where
 154     wlk_arity stuff
 155       = case stuff of
 156           U_no_pragma -> returnUgn Nothing
 157           U_iarity_pragma arity ->
 158             returnUgn (Just arity)
 159
 160     ------------
 161     wlk_update stuff
 162       = case stuff of
 163           U_no_pragma -> returnUgn Nothing
 164           U_iupdate_pragma upd_spec ->
 165             returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
 166
 167     ------------
 168     wlk_deforest stuff
 169       = case stuff of
 170           U_no_pragma -> returnUgn Don'tDeforest
 171           U_ideforest_pragma -> returnUgn DoDeforest
 172
 173     ------------
 174     wlk_unfold stuff
 175       = case stuff of
 176           U_no_pragma -> returnUgn NoImpUnfolding
 177
 178           U_imagic_unfolding_pragma magic ->
 179             returnUgn (ImpMagicUnfolding magic)
 180
 181           U_iunfolding_pragma guide core ->
 182             wlkGuidance guide   `thenUgn` \ guidance ->
 183             wlkCoreExpr core    `thenUgn` \ coresyn  ->
 184             returnUgn (ImpUnfolding guidance coresyn)
 185
 186     ------------
 187     wlk_strict stuff
 188       = case stuff of
 189           U_no_pragma -> returnUgn NoImpStrictness
 190
 191           U_istrictness_pragma strict_spec wrkr_stuff ->
 192             wlkGenPragma wrkr_stuff  `thenUgn` \ wrkr_pragma ->
 193             let
 194                 strict_spec_str = _UNPK_ strict_spec
 195                 (is_bot, ww_strict_info)
 196                   = if (strict_spec_str == "B")
 197                     then (True,  [])
 198                     else (False, (read strict_spec_str)::[Demand])
 199             in
 200             returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
 201
 202     ------------
 203     rd_spec pt
 204       = rdU_hpragma pt  `thenUgn` \ stuff ->
 205         case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
 206
 207         wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
 208         wlkGenPragma            prag      `thenUgn` \ gen_prag       ->
 209         returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
 210 \end{code}
 211
 212 The only tricky case is pragmas on signatures; we have no way of
 213 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
 214 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
 215 will sort it out later.
 216 \begin{code}
 217 wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
 218
 219 wlkTySigPragmas pragma
 220   = case pragma of
 221       U_no_pragma -> returnUgn RdrNoPragma
 222
 223       U_iclasop_pragma dsel defm ->
 224         wlkGenPragma dsel   `thenUgn` \ dsel_pragma ->
 225         wlkGenPragma defm   `thenUgn` \ defm_pragma ->
 226         returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
 227
 228       other ->
 229         wlkGenPragma other  `thenUgn` \ gen_pragmas ->
 230         returnUgn (RdrGenPragmas gen_pragmas)
 231 \end{code}
 232
 233 \begin{code}
 234 wlkGuidance guide
 235   = case guide of
 236       U_iunfold_always -> returnUgn UnfoldAlways
 237
 238       U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
 239         let
 240             con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
 241             -- if there were 0 args, we want to throw away
 242             -- any dummy con_arg_spec stuff...
 243         in
 244         returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
 245                     con_arg_info size)
 246         where
 247           cvt 'C' = True  -- want a constructor in this arg position
 248           cvt _   = False
 249 \end{code}
 250
 251 \begin{code}
 252 wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
 253
 254 wlkCoreExpr core_expr
 255   = case core_expr of
 256       U_covar v ->
 257         wlkCoreId  v    `thenUgn` \ var ->
 258         returnUgn (UfCoVar var)
 259
 260       U_coliteral l ->
 261         wlkBasicLit l   `thenUgn` \ lit ->
 262         returnUgn (UfCoLit lit)
 263
 264       U_cocon c ts as ->
 265         wlkCoreId c             `thenUgn` \ (BoringUfId con) ->
 266         wlkList rdCoreType ts   `thenUgn` \ tys ->
 267         wlkList rdCoreAtom as   `thenUgn` \ vs  ->
 268         returnUgn (UfCoCon con tys vs)
 269
 270       U_coprim o ts as ->
 271         wlk_primop         o    `thenUgn` \ op  ->
 272         wlkList rdCoreType ts   `thenUgn` \ tys ->
 273         wlkList rdCoreAtom as   `thenUgn` \ vs  ->
 274         let
 275             fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
 276         in
 277         returnUgn (UfCoPrim op tys fixed_vs)
 278        where
 279
 280         -- Question: why did ccall once panic if you looked at the
 281         -- maygc flag?  Was this just laziness or is it not needed?
 282         -- In that case, modify the stuff that writes them to pragmas
 283         -- so that it never adds the _GC_ tag. ADR
 284
 285         wlk_primop op
 286           = case op of
 287               U_co_primop op_str ->
 288                 returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
 289
 290               U_co_ccall fun_str may_gc a_tys r_ty ->
 291                 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
 292                 wlkCoreType        r_ty  `thenUgn` \ res_ty  ->
 293                 returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
 294
 295               U_co_casm litlit may_gc a_tys r_ty ->
 296                 wlkBasicLit         litlit  `thenUgn` \ (MachLitLit casm_str _) ->
 297                 wlkList rdCoreType  a_tys   `thenUgn` \ arg_tys     ->
 298                 wlkCoreType         r_ty    `thenUgn` \ res_ty      ->
 299                 returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
 300           where
 301             is_T_or_F 0 = False
 302             is_T_or_F _ = True
 303
 304         -- Now *this* is a hack: we can't distinguish Int# literals
 305         -- from Word# literals as they come in; this is only likely
 306         -- to bite on the args of certain PrimOps (shifts, etc); so
 307         -- we look for those and fix things up!!! (WDP 95/05)
 308
 309         fixup AndOp    [a1, a2] = [fixarg a1, fixarg a2]
 310         fixup OrOp     [a1, a2] = [fixarg a1, fixarg a2]
 311         fixup NotOp    [a1]     = [fixarg a1]
 312         fixup SllOp    [a1, a2] = [fixarg a1, a2]
 313         fixup SraOp    [a1, a2] = [fixarg a1, a2]
 314         fixup SrlOp    [a1, a2] = [fixarg a1, a2]
 315         fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
 316         fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
 317         fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
 318         fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
 319         fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
 320         fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
 321         fixup _        as       = as
 322
 323         fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
 324         fixarg arg                         = arg
 325
 326       U_colam vars expr ->
 327         wlkList rdCoreBinder vars   `thenUgn` \ bs   ->
 328         wlkCoreExpr          expr   `thenUgn` \ body ->
 329         returnUgn (UfCoLam bs body)
 330
 331       U_cotylam vars expr ->
 332         wlkList rdU_unkId   vars    `thenUgn` \ tvs  ->
 333         wlkCoreExpr         expr    `thenUgn` \ body ->
 334         returnUgn (foldr UfCoTyLam body tvs)
 335
 336       U_coapp f as ->
 337         wlkCoreExpr        f    `thenUgn` \ fun  ->
 338         wlkList rdCoreAtom as   `thenUgn` \ args ->
 339         returnUgn (foldl UfCoApp fun args)
 340
 341       U_cotyapp e t ->
 342         wlkCoreExpr e       `thenUgn` \ expr ->
 343         wlkCoreType t       `thenUgn` \ ty       ->
 344         returnUgn (UfCoTyApp expr ty)
 345
 346       U_cocase s as ->
 347         wlkCoreExpr s       `thenUgn` \ scrut ->
 348         wlk_alts    as      `thenUgn` \ alts  ->
 349         returnUgn (UfCoCase scrut alts)
 350        where
 351         wlk_alts (U_coalg_alts as d)
 352           = wlkList rd_alg_alt as   `thenUgn` \ alts  ->
 353             wlk_deflt          d    `thenUgn` \ deflt ->
 354             returnUgn (UfCoAlgAlts alts deflt)
 355           where
 356             rd_alg_alt pt
 357               = rdU_coresyn pt  `thenUgn` \ (U_coalg_alt c bs exp) ->
 358
 359                 wlkCoreId            c   `thenUgn` \ (BoringUfId con) ->
 360                 wlkList rdCoreBinder bs  `thenUgn` \ params           ->
 361                 wlkCoreExpr          exp `thenUgn` \ rhs              ->
 362                 returnUgn (con, params, rhs)
 363
 364         wlk_alts (U_coprim_alts as d)
 365           = wlkList rd_prim_alt as  `thenUgn` \ alts  ->
 366             wlk_deflt           d   `thenUgn` \ deflt ->
 367             returnUgn (UfCoPrimAlts alts deflt)
 368           where
 369             rd_prim_alt pt
 370               = rdU_coresyn pt  `thenUgn` \ (U_coprim_alt l exp) ->
 371
 372                 wlkBasicLit l   `thenUgn` \ lit ->
 373                 wlkCoreExpr exp `thenUgn` \ rhs ->
 374                 returnUgn (lit, rhs)
 375
 376         wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
 377         wlk_deflt (U_cobinddeflt v exp)
 378           = wlkCoreBinder v     `thenUgn` \ b   ->
 379             wlkCoreExpr   exp   `thenUgn` \ rhs ->
 380             returnUgn (UfCoBindDefault b rhs)
 381
 382       U_colet b expr ->
 383         wlk_bind    b    `thenUgn` \ bind ->
 384         wlkCoreExpr expr `thenUgn` \ body ->
 385         returnUgn (UfCoLet bind body)
 386        where
 387         wlk_bind (U_cononrec v expr)
 388           = wlkCoreBinder v     `thenUgn` \ b   ->
 389             wlkCoreExpr   expr  `thenUgn` \ rhs ->
 390             returnUgn (UfCoNonRec b rhs)
 391
 392         wlk_bind (U_corec prs)
 393           = wlkList rd_pair prs `thenUgn` \ pairs ->
 394             returnUgn (UfCoRec pairs)
 395           where
 396             rd_pair pt
 397               = rdU_coresyn pt  `thenUgn` \ (U_corec_pair v expr) ->
 398
 399                 wlkCoreBinder v    `thenUgn` \ b   ->
 400                 wlkCoreExpr   expr `thenUgn` \ rhs ->
 401                 returnUgn (b, rhs)
 402
 403       U_coscc c expr ->
 404         wlk_cc      c    `thenUgn` \ cc   ->
 405         wlkCoreExpr expr `thenUgn` \ body ->
 406         returnUgn (UfCoSCC cc body)
 407       where
 408         wlk_cc (U_co_preludedictscc dupd)
 409           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 410             returnUgn (UfPreludeDictsCC is_dupd)
 411
 412         wlk_cc (U_co_alldictscc m g dupd)
 413           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 414             returnUgn (UfAllDictsCC m g is_dupd)
 415
 416         wlk_cc (U_co_usercc n m g dupd cafd)
 417           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 418             wlk_cafd cafd       `thenUgn` \ is_cafd ->
 419             returnUgn (UfUserCC n m g is_dupd is_cafd)
 420
 421         wlk_cc (U_co_autocc id m g dupd cafd)
 422           = wlkCoreId id        `thenUgn` \ i       ->
 423             wlk_dupd  dupd      `thenUgn` \ is_dupd ->
 424             wlk_cafd  cafd      `thenUgn` \ is_cafd ->
 425             returnUgn (UfAutoCC i m g is_dupd is_cafd)
 426
 427         wlk_cc (U_co_dictcc id m g dupd cafd)
 428           = wlkCoreId id        `thenUgn` \ i       ->
 429             wlk_dupd  dupd      `thenUgn` \ is_dupd ->
 430             wlk_cafd  cafd      `thenUgn` \ is_cafd ->
 431             returnUgn (UfDictCC i m g is_dupd is_cafd)
 432
 433         ------
 434         wlk_cafd U_co_scc_noncaf  = returnUgn False
 435         wlk_cafd U_co_scc_caf     = returnUgn True
 436
 437         wlk_dupd U_co_scc_nondupd = returnUgn False
 438         wlk_dupd U_co_scc_dupd    = returnUgn True
 439 \end{code}
 440
 441 \begin{code}
 442 type ProtoUfBinder = (ProtoName, PolyType ProtoName)
 443
 444 rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
 445
 446 rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
 447
 448 wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
 449
 450 wlkCoreBinder (U_cobinder b t)
 451   = wlkCoreType t   `thenUgn` \ ty ->
 452     returnUgn (b, ty)
 453
 454 rdCoreAtom pt
 455   = rdU_coresyn pt `thenUgn` \ atom ->
 456     case atom of
 457       U_colit l ->
 458         wlkBasicLit l   `thenUgn` \ lit ->
 459         returnUgn (UfCoLitAtom lit)
 460
 461       U_colocal var ->
 462         wlkCoreId var   `thenUgn` \ v ->
 463         returnUgn (UfCoVarAtom v)
 464 \end{code}
 465
 466 \begin{code}
 467 rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
 468
 469 rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
 470
 471 wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
 472
 473 wlkCoreType (U_uniforall ts t)
 474   = wlkList rdU_unkId ts    `thenUgn` \ tvs ->
 475     wlkMonoType       t     `thenUgn` \ ty  ->
 476     returnUgn (ForAllTy tvs ty)
 477
 478 wlkCoreType other
 479   = wlkMonoType other   `thenUgn` \ ty ->
 480     returnUgn (UnoverloadedTy ty)
 481 \end{code}
 482
 483 \begin{code}
 484 {- OLD???
 485 wlkCoreTypeMaybe :: ParseTree -> RETN_TYPE(Maybe ProtoNamePolyType, FAST_STRING)
 486
 487 wlkCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
 488 wlkCoreTypeMaybe ('2' : 'E' : xs)
 489   = wlkCoreType xs)    `thenUgn` \ (ty, xs1) ->
 490     RETN(Just ty, xs1)
 491     BEND
 492 -}
 493
 494 rdMonoTypeMaybe pt
 495   = rdU_ttype pt `thenUgn` \ ty ->
 496     case ty of
 497       U_ty_maybe_nothing -> returnUgn Nothing
 498
 499       U_ty_maybe_just t ->
 500         wlkMonoType t   `thenUgn` \ mono_ty ->
 501         returnUgn (Just mono_ty)
 502 \end{code}
 503
 504 \begin{code}
 505 wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
 506
 507 wlkCoreId (U_co_id v)
 508   = returnUgn (BoringUfId (cvt_IdString v))
 509
 510 wlkCoreId (U_co_orig_id mod nm)
 511   = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
 512
 513 wlkCoreId (U_co_sdselid clas super_clas)
 514   = returnUgn (SuperDictSelUfId clas super_clas)
 515
 516 wlkCoreId (U_co_classopid clas method)
 517   = returnUgn (ClassOpUfId clas method)
 518
 519 wlkCoreId (U_co_defmid clas method)
 520   = returnUgn (DefaultMethodUfId clas method)
 521
 522 wlkCoreId (U_co_dfunid clas t)
 523   = wlkCoreType t   `thenUgn` \ ty ->
 524     returnUgn (DictFunUfId clas ty)
 525
 526 wlkCoreId (U_co_constmid clas op t)
 527   = wlkCoreType t   `thenUgn` \ ty ->
 528     returnUgn (ConstMethodUfId clas op ty)
 529
 530 wlkCoreId (U_co_specid id tys)
 531   = wlkCoreId               id  `thenUgn` \ unspec    ->
 532     wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
 533     returnUgn (SpecUfId unspec ty_maybes)
 534
 535 wlkCoreId (U_co_wrkrid un)
 536   = wlkCoreId un        `thenUgn` \ unwrkr ->
 537     returnUgn (WorkerUfId unwrkr)
 538
 539 ------------
 540 cvt_IdString :: FAST_STRING -> ProtoName
 541
 542 cvt_IdString s
 543   = if (_HEAD_ s /= '_') then
 544 --      trace (show s++(show (_HEAD_ s /= '_'))++(_HEAD_ s):'_':"/*0*/\n") (
 545         boring
 546 --      )
 547     else if (sub_s == SLIT("NIL_")) then
 548 --      trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 549         Prel (WiredInVal nilDataCon)
 550 --      )
 551     else if (sub_s == SLIT("TUP_")) then
 552 --      trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 553         Prel (WiredInVal (mkTupleCon arity))
 554 --      )
 555     else
 556 --      trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 557         boring
 558 --      )
 559   where
 560     boring = Unk s
 561     sub_s  = _SUBSTR_ s 1 4     -- chars 1--4 (0-origin)
 562     arity  = read (_UNPK_ (_SUBSTR_ s 5 999999))
 563                                 -- chars 5 onwards give the arity
 564 \end{code}
 565
 566 \begin{code}
 567 wlkBasicLit :: U_literal -> UgnM BasicLit
 568
 569 wlkBasicLit (U_norepr n d)
 570   = let
 571         num = ((read (_UNPK_ n)) :: Integer)
 572         den = ((read (_UNPK_ d)) :: Integer)
 573     in
 574     returnUgn (NoRepRational (num % den))
 575
 576 wlkBasicLit other
 577   = returnUgn (
 578     case other of
 579       U_intprim    s -> mkMachInt   (as_integer  s)
 580       U_doubleprim s -> MachDouble  (as_rational s)
 581       U_floatprim  s -> MachFloat   (as_rational s)
 582       U_charprim   s -> MachChar    (as_char     s)
 583       U_stringprim s -> MachStr     (as_string   s)
 584
 585       U_clitlit    s k -> MachLitLit (as_string  s) (guessPrimKind (_UNPK_ k))
 586
 587       U_norepi     s -> NoRepInteger (as_integer s)
 588       U_noreps     s -> NoRepStr     (as_string  s)
 589     )
 590   where
 591     as_char s     = _HEAD_ s
 592     as_integer s  = readInteger (_UNPK_ s)
 593     as_rational s = _readRational (_UNPK_ s) -- non-std
 594     as_string s   = s
 595 \end{code}