ghc/compiler/reader/ReadPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[ReadPragmas]{Read pragmatic interface info, including Core}
   5
   6 \begin{code}
   7 -- HBC does not have stack stubbing; you get a space leak w/
   8 -- default defns from HsVersions.h.
   9
  10 -- GHC may be overly slow to compile w/ the defaults...
  11
  12 #define BIND {--}
  13 #define _TO_ `thenLft` ( \ {--}
  14 #define BEND )
  15 #define RETN returnLft
  16 #define RETN_TYPE LiftM
  17
  18 #include "HsVersions.h"
  19 \end{code}
  20
  21 \begin{code}
  22 module ReadPragmas where
  23
  24 IMPORT_Trace            -- ToDo: rm (debugging)
  25 import Pretty
  26
  27 import AbsPrel          ( nilDataCon, readUnfoldingPrimOp, PrimOp(..), PrimKind
  28                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  29                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  30                         )
  31 import AbsSyn
  32 import BasicLit         ( mkMachInt, BasicLit(..) )
  33 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  34 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  35 import Id               ( mkTupleCon )
  36 import IdInfo           -- ( UnfoldingGuidance(..) )
  37 import LiftMonad
  38 import Maybes           ( Maybe(..) )
  39 import PrefixToHs
  40 import PrefixSyn
  41 import ProtoName
  42 import Outputable
  43 import ReadPrefix       ( rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType )
  44 import Util
  45 \end{code}
  46
  47 \begin{code}
  48 rdDataPragma :: String -> RETN_TYPE (ProtoNameDataPragmas, String)
  49
  50 rdDataPragma ('P' : 'N' : xs) = RETN (DataPragmas [] [], xs)
  51
  52 rdDataPragma ('P' : 'd' : xs)
  53   = BIND (rdList (rdConDecl srcfile) xs)  _TO_ (cons, xs1) ->
  54     BIND (rdList rd_spec xs1)             _TO_ (specs, xs2) ->
  55     RETN (DataPragmas cons specs, xs2)
  56     BEND BEND
  57   where
  58     srcfile = SLIT("<pragma>")
  59
  60     rd_spec ('P' : '4' : xs)
  61       = BIND (rdList rdMonoTypeMaybe xs)  _TO_ (spec, xs1) ->
  62         RETN (spec, xs1)
  63         BEND
  64 \end{code}
  65
  66 \begin{code}
  67 rdTypePragma :: String -> RETN_TYPE (TypePragmas, String)
  68
  69 rdTypePragma ('P' : 'N' : xs) = RETN (NoTypePragmas, xs)
  70 rdTypePragma ('P' : 't' : xs) = RETN (AbstractTySynonym, xs)
  71 \end{code}
  72
  73 \begin{code}
  74 rdClassPragma :: String -> RETN_TYPE (ProtoNameClassPragmas, String)
  75
  76 rdClassPragma ('P' : 'N' : xs) = RETN (NoClassPragmas, xs)
  77 rdClassPragma ('P' : 'c' : xs)
  78   = BIND (rdList rdGenPragma xs)   _TO_ (gen_pragmas, xs1) ->
  79     ASSERT(not (null gen_pragmas))
  80     RETN (SuperDictPragmas gen_pragmas, xs1)
  81     BEND
  82 \end{code}
  83
  84 \begin{code}
  85 rdInstPragma :: String -> RETN_TYPE (Maybe FAST_STRING, ProtoNameInstancePragmas, String)
  86
  87 rdInstPragma ('P' : 'N' : xs) = RETN (Nothing, NoInstancePragmas, xs)
  88
  89 rdInstPragma ('P' : 'i' : 's' : xs)
  90   = BIND (rdIdString  xs)       _TO_ (modname,     xs1) ->
  91     BIND (rdGenPragma xs1)      _TO_ (gen_pragmas, xs2) ->
  92     RETN (Just modname, SimpleInstancePragma gen_pragmas, xs2)
  93     BEND BEND
  94
  95 rdInstPragma ('P' : 'i' : 'c' : xs)
  96   = BIND (rdIdString         xs)  _TO_ (modname,        xs1) ->
  97     BIND (rdGenPragma        xs1) _TO_ (gen_pragma,     xs2) ->
  98     BIND (rdList rd_constm   xs2) _TO_ (constm_pragmas, xs3) ->
  99     RETN (Just modname, ConstantInstancePragma gen_pragma constm_pragmas, xs3)
 100     BEND BEND BEND
 101
 102 rd_constm ('P' : '1' : xs)
 103   = BIND (rdId  xs)  _TO_ (name, xs1) ->
 104     BIND (rdGenPragma  xs1) _TO_ (prag, xs2) ->
 105     RETN ((name, prag), xs2)
 106     BEND BEND
 107 \end{code}
 108
 109 \begin{code}
 110 rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String)
 111
 112 rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs)
 113
 114 rdGenPragma ('P': 'g' : xs)
 115   = BIND (rd_arity  xs)       _TO_ (arity,  xs1) ->
 116     BIND (rd_update xs1)      _TO_ (upd,    xs2) ->
 117     BIND (rd_strict xs2)      _TO_ (strict, xs3) ->
 118     BIND (rd_unfold xs3)      _TO_ (unfold, xs4) ->
 119     BIND (rdList rd_spec xs4) _TO_ (specs,  xs5) ->
 120 ToDo: do something for DeforestInfo
 121     RETN (GenPragmas arity upd strict unfold specs, xs5)
 122     BEND BEND BEND BEND BEND
 123   where
 124     rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs)
 125     rd_arity ('P' : 'A' : xs)
 126       = BIND (rdIdString xs)    _TO_ (a_str, xs1) ->
 127         RETN (Just ((read (_UNPK_ a_str))::Int), xs1)
 128         BEND
 129
 130     rd_update ('P' : 'N' : xs) = RETN (Nothing, xs)
 131     rd_update ('P' : 'u' : xs)
 132       = BIND (rdIdString xs)    _TO_ (upd_spec, xs1) ->
 133         RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1)
 134         BEND
 135
 136     rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs)
 137
 138     rd_unfold ('P' : 'M' : xs)
 139       = BIND (rdIdString xs)    _TO_ (str, xs1) ->
 140         RETN (ImpMagicUnfolding str, xs1)
 141         BEND
 142
 143     rd_unfold ('P' : 'U' : xs)
 144       = BIND (rdGuidance xs)    _TO_ (guidance, xs1) ->
 145         BIND (rdCoreExpr xs1)   _TO_ (core,     xs2) ->
 146         RETN (ImpUnfolding guidance core, xs2)
 147         BEND BEND
 148
 149     rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs)
 150     rd_strict ('P' : 'S' : xs)
 151       = BIND (rdString    xs)   _TO_ (strict_spec, xs1) ->
 152         BIND (rdGenPragma xs1)  _TO_ (wrkr_pragma, xs2) ->
 153         let
 154             ww_strict_info = (read (_UNPK_ strict_spec))::[Demand]
 155         in
 156         RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2)
 157         BEND BEND
 158
 159     rd_spec ('P' : '2' : xs)
 160       = BIND (rdList rdMonoTypeMaybe xs)  _TO_ (mono_tys_maybe, xs1) ->
 161         BIND (rdIdString             xs1) _TO_ (num_dicts,      xs2) ->
 162         BIND (rdGenPragma            xs2) _TO_ (gen_prag,       xs3) ->
 163         RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3)
 164         BEND BEND BEND
 165 \end{code}
 166
 167 The only tricky case is pragmas on signatures; we have no way of
 168 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
 169 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
 170 will sort it out later.
 171 \begin{code}
 172 rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String)
 173
 174 rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs)
 175
 176 rdTySigPragmas ('P' : 'o' : xs)
 177   = BIND (rdGenPragma xs)   _TO_ (dsel_pragma, xs1) ->
 178     BIND (rdGenPragma xs1)  _TO_ (defm_pragma, xs2) ->
 179     RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2)
 180     BEND BEND
 181
 182 rdTySigPragmas xs
 183   = BIND (rdGenPragma    xs)  _TO_ (gen_pragmas, xs1) ->
 184     RETN (RdrGenPragmas gen_pragmas, xs1)
 185     BEND
 186 \end{code}
 187
 188 \begin{code}
 189 rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs)
 190
 191 -- EssentialUnfolding should never appear in interfaces, so we
 192 -- don't have any way to read them.
 193
 194 rdGuidance ('P' : 'y' : xs)
 195   = BIND (rdIdString xs)        _TO_ (m_ty_args,    xs1) ->
 196     BIND (rdIdString xs1)       _TO_ (n_val_args,   xs2) ->
 197     BIND (rdIdString xs2)       _TO_ (con_arg_spec, xs3) ->
 198     BIND (rdIdString xs3)       _TO_ (size_str,     xs4) ->
 199     let
 200         num_val_args = ((read (_UNPK_ n_val_args)) :: Int)
 201         con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
 202         -- if there were 0 args, we want to throw away
 203         -- any dummy con_arg_spec stuff...
 204     in
 205     RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args
 206                 con_arg_info (read (_UNPK_ size_str)), xs4)
 207     BEND BEND BEND BEND
 208   where
 209     cvt 'C' = True  -- want a constructor in this arg position
 210     cvt _   = False
 211
 212 {- OLD:
 213 rdGuidance ('P' : 'z' : xs)
 214   = BIND (rdIdString xs)        _TO_ (m_ty_args, xs1) ->
 215     BIND (rdIdString xs1)       _TO_ (size,      xs2) ->
 216     RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm
 217     BEND BEND
 218 -}
 219 \end{code}
 220
 221 \begin{code}
 222 rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String)
 223
 224 rdCoreExpr ('F' : 'g' : xs)
 225   = BIND (rdCoreId   xs)        _TO_ (var, xs1) ->
 226     RETN (UfCoVar var, xs1)
 227     BEND
 228
 229 rdCoreExpr ('F' : 'h' : xs)
 230   = BIND (rdBasicLit xs)        _TO_ (lit, xs1) ->
 231     RETN (UfCoLit lit, xs1)
 232     BEND
 233
 234 rdCoreExpr ('F' : 'i' : xs)
 235   = BIND (rdCoreId xs)              _TO_ (BoringUfId con, xs1) ->
 236     BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
 237     BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
 238     RETN (UfCoCon con tys vs, xs3)
 239     BEND BEND BEND
 240
 241 rdCoreExpr ('F' : 'j' : xs)
 242   = BIND (rd_primop xs)             _TO_ (op,  xs1) ->
 243     BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
 244     BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
 245     RETN (UfCoPrim op tys vs, xs3)
 246     BEND BEND BEND
 247   where
 248
 249 -- Question: why did ccall once panic if you looked at the maygc flag?
 250 -- Was this just laziness or is it not needed?  In that case, modify
 251 -- the stuff that writes them to pragmas so that it never adds the _GC_
 252 -- tag. ADR
 253
 254     rd_primop ('F' : 'w' : xs)
 255       = BIND (rdIdString xs)    _TO_ (op_str, xs1) ->
 256         RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1)
 257         BEND
 258     rd_primop ('F' : 'x' : t_or_f : xs)
 259       = BIND (rdIdString        xs)  _TO_ (fun_str, xs1) ->
 260         BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
 261         BIND (rdCoreType        xs2) _TO_ (res_ty,  xs3) ->
 262         RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3)
 263         BEND BEND BEND
 264     rd_primop ('F' : 'y' : t_or_f : xs)
 265       = BIND (rdBasicLit        xs)  _TO_ (casm_litlit, xs1) ->
 266         BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
 267         BIND (rdCoreType        xs2) _TO_ (res_ty,  xs3) ->
 268         let
 269             (MachLitLit casm_str _) = casm_litlit
 270         in
 271         RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3)
 272         BEND BEND BEND
 273
 274     is_T_or_F 'T' = True
 275     is_T_or_F 'F' = False
 276
 277 rdCoreExpr ('F' : 'k' : xs)
 278   = BIND (rdList rdCoreBinder xs)   _TO_ (bs,   xs1) ->
 279     BIND (rdCoreExpr          xs1)  _TO_ (body, xs2) ->
 280     RETN (UfCoLam bs body, xs2)
 281     BEND BEND
 282
 283 rdCoreExpr ('F' : 'l' : xs)
 284   = BIND (rdList rdId   xs)         _TO_ (tvs,  xs1) ->
 285     BIND (rdCoreExpr    xs1)        _TO_ (body, xs2) ->
 286     RETN (foldr UfCoTyLam body tvs, xs2)
 287     BEND BEND
 288
 289 rdCoreExpr ('F' : 'm' : xs)
 290   = BIND (rdCoreExpr        xs)     _TO_ (fun,  xs1) ->
 291     BIND (rdList rdCoreAtom xs1)    _TO_ (args, xs2) ->
 292     RETN (foldl UfCoApp fun args, xs2)
 293     BEND BEND
 294
 295
 296 rdCoreExpr ('F' : 'n' : xs)
 297   = BIND (rdCoreExpr    xs)         _TO_ (expr, xs1) ->
 298     BIND (rdCoreType    xs1)        _TO_ (ty,   xs2) ->
 299     RETN (UfCoTyApp expr ty, xs2)
 300     BEND BEND
 301
 302 rdCoreExpr ('F' : 'o' : xs)
 303   = BIND (rdCoreExpr    xs)         _TO_ (scrut, xs1) ->
 304     BIND (rd_alts       xs1)        _TO_ (alts,  xs2) ->
 305     RETN (UfCoCase scrut alts, xs2)
 306     BEND BEND
 307   where
 308     rd_alts ('F' : 'q' : xs)
 309       = BIND (rdList rd_alg_alt xs)     _TO_ (alts,  xs1) ->
 310         BIND (rd_deflt          xs1)    _TO_ (deflt, xs2) ->
 311         RETN (UfCoAlgAlts alts deflt, xs2)
 312         BEND BEND
 313       where
 314         rd_alg_alt ('F' : 'r' : xs)
 315           = BIND (rdCoreId            xs)   _TO_ (BoringUfId con, xs1) ->
 316             BIND (rdList rdCoreBinder xs1)  _TO_ (params,         xs2) ->
 317             BIND (rdCoreExpr          xs2)  _TO_ (rhs,            xs3) ->
 318             RETN ((con, params, rhs), xs3)
 319             BEND BEND BEND
 320
 321     rd_alts ('F' : 's' : xs)
 322       = BIND (rdList rd_prim_alt xs)    _TO_ (alts,  xs1) ->
 323         BIND (rd_deflt           xs1)   _TO_ (deflt, xs2) ->
 324         RETN (UfCoPrimAlts alts deflt, xs2)
 325         BEND BEND
 326       where
 327         rd_prim_alt ('F' : 't' : xs)
 328           = BIND (rdBasicLit    xs)   _TO_ (lit, xs1) ->
 329             BIND (rdCoreExpr    xs1)  _TO_ (rhs, xs2) ->
 330             RETN ((lit, rhs), xs2)
 331             BEND BEND
 332
 333     rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs)
 334     rd_deflt ('F' : 'v' : xs)
 335       = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 336         BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 337         RETN (UfCoBindDefault b rhs, xs2)
 338         BEND BEND
 339
 340 rdCoreExpr ('F' : 'p' : xs)
 341   = BIND (rd_bind    xs)  _TO_ (bind, xs1) ->
 342     BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
 343     RETN (UfCoLet bind body, xs2)
 344     BEND BEND
 345   where
 346     rd_bind ('F' : 'd' : xs)
 347       = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 348         BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 349         RETN (UfCoNonRec b rhs, xs2)
 350         BEND BEND
 351
 352     rd_bind ('F' : 'e' : xs)
 353       = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) ->
 354         RETN (UfCoRec pairs, xs1)
 355         BEND
 356       where
 357         rd_pair ('F' : 'f' : xs)
 358           = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 359             BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 360             RETN ((b, rhs), xs2)
 361             BEND BEND
 362
 363 rdCoreExpr ('F' : 'z' : xs)
 364   = BIND (rd_cc      xs)  _TO_ (cc,   xs1) ->
 365     BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
 366     RETN (UfCoSCC cc body, xs2)
 367     BEND BEND
 368   where
 369     rd_cc ('F' : '?' : 'a' : xs)
 370       = BIND (rd_dupd xs)       _TO_ (is_dupd, xs1) ->
 371         RETN (UfPreludeDictsCC is_dupd, xs1)
 372         BEND
 373
 374     rd_cc ('F' : '?' : 'b' : xs)
 375       = BIND (rdString xs)      _TO_ (m,       xs1) ->
 376         BIND (rdString xs1)     _TO_ (g,       xs2) ->
 377         BIND (rd_dupd  xs2)     _TO_ (is_dupd, xs3) ->
 378         RETN (UfAllDictsCC m g is_dupd, xs3)
 379         BEND BEND BEND
 380
 381     rd_cc ('F' : '?' : 'c' : xs)
 382       = BIND (rdString xs)      _TO_ (n, xs1) ->
 383         BIND (rdString xs1)     _TO_ (m, xs2) ->
 384         BIND (rdString xs2)     _TO_ (g, xs3) ->
 385         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 386         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 387         RETN (UfUserCC n m g is_dupd is_cafd, xs5)
 388         BEND BEND BEND BEND BEND
 389
 390     rd_cc ('F' : '?' : 'd' : xs)
 391       = BIND (rdCoreId   xs)    _TO_ (i, xs1) ->
 392         BIND (rdString xs1)     _TO_ (m, xs2) ->
 393         BIND (rdString xs2)     _TO_ (g, xs3) ->
 394         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 395         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 396         RETN (UfAutoCC i m g is_dupd is_cafd, xs5)
 397         BEND BEND BEND BEND BEND
 398
 399     rd_cc ('F' : '?' : 'e' : xs)
 400       = BIND (rdCoreId   xs)    _TO_ (i, xs1) ->
 401         BIND (rdString xs1)     _TO_ (m, xs2) ->
 402         BIND (rdString xs2)     _TO_ (g, xs3) ->
 403         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 404         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 405         RETN (UfDictCC i m g is_dupd is_cafd, xs5)
 406         BEND BEND BEND BEND BEND
 407
 408     ------
 409     rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs)
 410     rd_cafd ('F' : '?' : 'g' : xs) = RETN (True,  xs)
 411 --  rd_cafd xs = panic ("rd_cafd:\n"++xs)
 412
 413     rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs)
 414     rd_dupd ('F' : '?' : 'i' : xs) = RETN (True,  xs)
 415 \end{code}
 416
 417 \begin{code}
 418 rdCoreBinder ('F' : 'a' : xs)
 419   = BIND (rdId          xs)     _TO_ (b,  xs1) ->
 420     BIND (rdCoreType    xs1)    _TO_ (ty, xs2) ->
 421     RETN ((b, ty), xs2)
 422     BEND BEND
 423
 424 rdCoreAtom ('F' : 'b' : xs)
 425   = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
 426     RETN (UfCoLitAtom lit, xs1)
 427     BEND
 428
 429 rdCoreAtom ('F' : 'c' : xs)
 430   = BIND (rdCoreId xs)   _TO_ (v,   xs1) ->
 431     RETN (UfCoVarAtom v, xs1)
 432     BEND
 433 \end{code}
 434
 435 \begin{code}
 436 rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String)
 437
 438 rdCoreType ('2' : 'C' : xs)
 439   = BIND (rdList rdId xs)       _TO_ (tvs, xs1) ->
 440     BIND (rdMonoType  xs1)      _TO_ (ty,  xs2) ->
 441     RETN (ForAllTy tvs ty, xs2)
 442     BEND BEND
 443
 444 rdCoreType other
 445   = BIND (rdMonoType other)     _TO_ (ty, xs1) ->
 446     RETN (UnoverloadedTy ty, xs1)
 447     BEND
 448 \end{code}
 449
 450 \begin{code}
 451 rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String)
 452
 453 rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
 454 rdCoreTypeMaybe ('2' : 'E' : xs)
 455   = BIND (rdCoreType xs)    _TO_ (ty, xs1) ->
 456     RETN(Just ty, xs1)
 457     BEND
 458
 459 rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs)
 460
 461 rdMonoTypeMaybe ('2' : 'E' : xs)
 462   = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
 463     RETN (Just mono_ty, xs1)
 464     BEND
 465 \end{code}
 466
 467 \begin{code}
 468 rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String)
 469
 470 rdCoreId ('F' : '1' : xs)
 471   = BIND (rdIdString xs)        _TO_ (v, xs1) ->
 472     RETN (BoringUfId (cvt_IdString v), xs1)
 473     BEND
 474 rdCoreId ('F' : '9' : xs)
 475   = BIND (rdIdString xs)        _TO_ (mod, xs1) ->
 476     BIND (rdIdString xs1)       _TO_ (nm,  xs2) ->
 477     RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2)
 478     BEND BEND
 479 rdCoreId ('F' : '2' : xs)
 480   = BIND (rdId xs)              _TO_ (clas,       xs1) ->
 481     BIND (rdId xs1)             _TO_ (super_clas, xs2) ->
 482     RETN (SuperDictSelUfId clas super_clas, xs2)
 483     BEND BEND
 484 rdCoreId ('F' : '3' : xs)
 485   = BIND (rdId xs)              _TO_ (clas,   xs1) ->
 486     BIND (rdId xs1)             _TO_ (method, xs2) ->
 487     RETN (ClassOpUfId clas method, xs2)
 488     BEND BEND
 489 rdCoreId ('F' : '4' : xs)
 490   = BIND (rdId xs)              _TO_ (clas,   xs1) ->
 491     BIND (rdId xs1)             _TO_ (method, xs2) ->
 492     RETN (DefaultMethodUfId clas method, xs2)
 493     BEND BEND
 494 rdCoreId ('F' : '5' : xs)
 495   = BIND (rdId       xs)        _TO_ (clas, xs1) ->
 496     BIND (rdCoreType xs1)       _TO_ (ty,   xs2) ->
 497     RETN (DictFunUfId clas ty, xs2)
 498     BEND BEND
 499 rdCoreId ('F' : '6' : xs)
 500   = BIND (rdId       xs)        _TO_ (clas, xs1) ->
 501     BIND (rdId       xs1)       _TO_ (op,   xs2) ->
 502     BIND (rdCoreType xs2)       _TO_ (ty,   xs3) ->
 503     RETN (ConstMethodUfId clas op ty, xs3)
 504     BEND BEND BEND
 505 rdCoreId ('F' : '7' : xs)
 506   = BIND (rdCoreId xs)                  _TO_ (unspec,    xs1) ->
 507     BIND (rdList rdMonoTypeMaybe xs1)   _TO_ (ty_maybes, xs2) ->
 508     RETN (SpecUfId unspec ty_maybes, xs2)
 509     BEND BEND
 510 rdCoreId ('F' : '8' : xs)
 511   = BIND (rdCoreId xs)                  _TO_ (unwrkr,    xs1) ->
 512     RETN (WorkerUfId unwrkr, xs1)
 513     BEND
 514
 515 cvt_IdString :: FAST_STRING -> ProtoName
 516
 517 cvt_IdString s
 518   = if (_HEAD_ s /= '_') then
 519         boring
 520     else if (sub_s == SLIT("NIL_")) then
 521 --      trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 522         Prel (WiredInVal nilDataCon)
 523 --      )
 524     else if (sub_s == SLIT("TUP_")) then
 525 --      trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 526         Prel (WiredInVal (mkTupleCon arity))
 527 --      )
 528     else
 529 --      trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
 530         boring
 531 --      )
 532   where
 533     boring = Unk s
 534     sub_s  = _SUBSTR_ s 1 4     -- chars 1--4 (0-origin)
 535     arity  = read (_UNPK_ (_SUBSTR_ s 5 999999))
 536                                 -- chars 5 onwards give the arity
 537 \end{code}
 538
 539 \begin{code}
 540 rdBasicLit :: String -> RETN_TYPE (BasicLit, String)
 541
 542 rdBasicLit ('R' : xs)
 543   = BIND (rdString xs)  _TO_ (n, xs1) ->
 544     BIND (rdString xs1) _TO_ (d, xs2) ->
 545     let
 546         num = ((read (_UNPK_ n)) :: Integer)
 547         den = ((read (_UNPK_ d)) :: Integer)
 548     in
 549     RETN (NoRepRational (num % den), xs2)
 550     BEND BEND
 551
 552 rdBasicLit ( tag : xs)
 553   = BIND (rdString xs) _TO_ (x, zs) ->
 554     let
 555         s = _UNPK_ x
 556
 557         as_char     = chr ((read s) :: Int)
 558             -- a char comes in as a number string
 559             -- representing its ASCII code
 560         as_integer  = readInteger s
 561 #ifdef __GLASGOW_HASKELL__
 562         as_rational = _readRational s -- non-std
 563 #else
 564         as_rational = ((read s)::Rational)
 565 #endif
 566         as_double   = ((read s) :: Double)
 567     in
 568     case tag of {
 569      'H' -> RETN (mkMachInt     as_integer, zs);
 570      'J' -> RETN (MachDouble    as_rational,zs);
 571      'K' -> RETN (MachFloat     as_rational,zs);
 572      'P' -> RETN (MachChar      as_char,    zs);
 573      'V' -> RETN (MachStr       x,          zs);
 574      'Y' -> BIND (rdString zs) _TO_ (k, zs2) ->
 575             RETN (MachLitLit    x (guessPrimKind k), zs2)
 576             BEND;
 577      'I' -> RETN (NoRepInteger  as_integer, zs);
 578      's' -> RETN (NoRepStr      x,          zs)
 579     } BEND
 580 \end{code}