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