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 rdInstPragma ('P' : 'i' : 'S' : xs)
 103   = BIND (rdIdString     xs)  _TO_ (modname,      xs1) ->
 104     BIND (rdGenPragma    xs1) _TO_ (gen_pragma,   xs2) ->
 105     BIND (rdList rd_spec xs2) _TO_ (spec_pragmas, xs3) ->
 106     RETN (Just modname, SpecialisedInstancePragma gen_pragma spec_pragmas, xs3)
 107     BEND BEND BEND
 108   where
 109     rd_spec ('P' : '3' : xs)
 110       = BIND (rdList rdMonoTypeMaybe xs) _TO_ (mono_tys_maybe,  xs1) ->
 111         BIND (rdIdString       xs1)      _TO_ (num_dicts,       xs2) ->
 112         BIND (rdGenPragma      xs2)      _TO_ (gen_prag,        xs3) ->
 113         BIND (rdList rd_constm xs3)      _TO_ (constms,         xs4) ->
 114         let
 115             inst_prag
 116               = if null constms then
 117                    if null_gen_prag gen_prag
 118                    then NoInstancePragmas
 119                    else SimpleInstancePragma gen_prag
 120                 else -- some constms...
 121                    ConstantInstancePragma gen_prag constms
 122         in
 123         RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts)) :: Int), inst_prag), xs4)
 124         BEND BEND BEND BEND
 125       where
 126         null_gen_prag NoGenPragmas = True
 127         null_gen_prag _            = False
 128
 129 rd_constm ('P' : '1' : xs)
 130   = BIND (rdId  xs)  _TO_ (name, xs1) ->
 131     BIND (rdGenPragma  xs1) _TO_ (prag, xs2) ->
 132     RETN ((name, prag), xs2)
 133     BEND BEND
 134 \end{code}
 135
 136 \begin{code}
 137 rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String)
 138
 139 rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs)
 140
 141 rdGenPragma ('P': 'g' : xs)
 142   = BIND (rd_arity  xs)       _TO_ (arity,  xs1) ->
 143     BIND (rd_update xs1)      _TO_ (upd,    xs2) ->
 144     BIND (rd_strict xs2)      _TO_ (strict, xs3) ->
 145     BIND (rd_unfold xs3)      _TO_ (unfold, xs4) ->
 146     BIND (rdList rd_spec xs4) _TO_ (specs,  xs5) ->
 147 ToDo: do something for DeforestInfo
 148     RETN (GenPragmas arity upd strict unfold specs, xs5)
 149     BEND BEND BEND BEND BEND
 150   where
 151     rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs)
 152     rd_arity ('P' : 'A' : xs)
 153       = BIND (rdIdString xs)    _TO_ (a_str, xs1) ->
 154         RETN (Just ((read (_UNPK_ a_str))::Int), xs1)
 155         BEND
 156
 157     rd_update ('P' : 'N' : xs) = RETN (Nothing, xs)
 158     rd_update ('P' : 'u' : xs)
 159       = BIND (rdIdString xs)    _TO_ (upd_spec, xs1) ->
 160         RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1)
 161         BEND
 162
 163     rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs)
 164
 165     rd_unfold ('P' : 'M' : xs)
 166       = BIND (rdIdString xs)    _TO_ (str, xs1) ->
 167         RETN (ImpMagicUnfolding str, xs1)
 168         BEND
 169
 170     rd_unfold ('P' : 'U' : xs)
 171       = BIND (rdGuidance xs)    _TO_ (guidance, xs1) ->
 172         BIND (rdCoreExpr xs1)   _TO_ (core,     xs2) ->
 173         RETN (ImpUnfolding guidance core, xs2)
 174         BEND BEND
 175
 176     rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs)
 177     rd_strict ('P' : 'S' : xs)
 178       = BIND (rdString    xs)   _TO_ (strict_spec, xs1) ->
 179         BIND (rdGenPragma xs1)  _TO_ (wrkr_pragma, xs2) ->
 180         let
 181             ww_strict_info = (read (_UNPK_ strict_spec))::[Demand]
 182         in
 183         RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2)
 184         BEND BEND
 185
 186     rd_spec ('P' : '2' : xs)
 187       = BIND (rdList rdMonoTypeMaybe xs)  _TO_ (mono_tys_maybe, xs1) ->
 188         BIND (rdIdString             xs1) _TO_ (num_dicts,      xs2) ->
 189         BIND (rdGenPragma            xs2) _TO_ (gen_prag,       xs3) ->
 190         RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3)
 191         BEND BEND BEND
 192 \end{code}
 193
 194 The only tricky case is pragmas on signatures; we have no way of
 195 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
 196 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
 197 will sort it out later.
 198 \begin{code}
 199 rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String)
 200
 201 rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs)
 202
 203 rdTySigPragmas ('P' : 'o' : xs)
 204   = BIND (rdGenPragma xs)   _TO_ (dsel_pragma, xs1) ->
 205     BIND (rdGenPragma xs1)  _TO_ (defm_pragma, xs2) ->
 206     RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2)
 207     BEND BEND
 208
 209 rdTySigPragmas xs
 210   = BIND (rdGenPragma    xs)  _TO_ (gen_pragmas, xs1) ->
 211     RETN (RdrGenPragmas gen_pragmas, xs1)
 212     BEND
 213 \end{code}
 214
 215 \begin{code}
 216 rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs)
 217
 218 -- EssentialUnfolding should never appear in interfaces, so we
 219 -- don't have any way to read them.
 220
 221 rdGuidance ('P' : 'y' : xs)
 222   = BIND (rdIdString xs)        _TO_ (m_ty_args,    xs1) ->
 223     BIND (rdIdString xs1)       _TO_ (n_val_args,   xs2) ->
 224     BIND (rdIdString xs2)       _TO_ (con_arg_spec, xs3) ->
 225     BIND (rdIdString xs3)       _TO_ (size_str,     xs4) ->
 226     let
 227         num_val_args = ((read (_UNPK_ n_val_args)) :: Int)
 228         con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
 229         -- if there were 0 args, we want to throw away
 230         -- any dummy con_arg_spec stuff...
 231     in
 232     RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args
 233                 con_arg_info (read (_UNPK_ size_str)), xs4)
 234     BEND BEND BEND BEND
 235   where
 236     cvt 'C' = True  -- want a constructor in this arg position
 237     cvt _   = False
 238
 239 {- OLD:
 240 rdGuidance ('P' : 'z' : xs)
 241   = BIND (rdIdString xs)        _TO_ (m_ty_args, xs1) ->
 242     BIND (rdIdString xs1)       _TO_ (size,      xs2) ->
 243     RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm
 244     BEND BEND
 245 -}
 246 \end{code}
 247
 248 \begin{code}
 249 rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String)
 250
 251 rdCoreExpr ('F' : 'g' : xs)
 252   = BIND (rdCoreId   xs)        _TO_ (var, xs1) ->
 253     RETN (UfCoVar var, xs1)
 254     BEND
 255
 256 rdCoreExpr ('F' : 'h' : xs)
 257   = BIND (rdBasicLit xs)        _TO_ (lit, xs1) ->
 258     RETN (UfCoLit lit, xs1)
 259     BEND
 260
 261 rdCoreExpr ('F' : 'i' : xs)
 262   = BIND (rdCoreId xs)              _TO_ (BoringUfId con, xs1) ->
 263     BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
 264     BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
 265     RETN (UfCoCon con tys vs, xs3)
 266     BEND BEND BEND
 267
 268 rdCoreExpr ('F' : 'j' : xs)
 269   = BIND (rd_primop xs)             _TO_ (op,  xs1) ->
 270     BIND (rdList rdCoreType xs1)    _TO_ (tys, xs2) ->
 271     BIND (rdList rdCoreAtom xs2)    _TO_ (vs,  xs3) ->
 272     RETN (UfCoPrim op tys vs, xs3)
 273     BEND BEND BEND
 274   where
 275
 276 -- Question: why did ccall once panic if you looked at the maygc flag?
 277 -- Was this just laziness or is it not needed?  In that case, modify
 278 -- the stuff that writes them to pragmas so that it never adds the _GC_
 279 -- tag. ADR
 280
 281     rd_primop ('F' : 'w' : xs)
 282       = BIND (rdIdString xs)    _TO_ (op_str, xs1) ->
 283         RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1)
 284         BEND
 285     rd_primop ('F' : 'x' : t_or_f : xs)
 286       = BIND (rdIdString        xs)  _TO_ (fun_str, xs1) ->
 287         BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
 288         BIND (rdCoreType        xs2) _TO_ (res_ty,  xs3) ->
 289         RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3)
 290         BEND BEND BEND
 291     rd_primop ('F' : 'y' : t_or_f : xs)
 292       = BIND (rdBasicLit        xs)  _TO_ (casm_litlit, xs1) ->
 293         BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
 294         BIND (rdCoreType        xs2) _TO_ (res_ty,  xs3) ->
 295         let
 296             (MachLitLit casm_str _) = casm_litlit
 297         in
 298         RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3)
 299         BEND BEND BEND
 300
 301     is_T_or_F 'T' = True
 302     is_T_or_F 'F' = False
 303
 304 rdCoreExpr ('F' : 'k' : xs)
 305   = BIND (rdList rdCoreBinder xs)   _TO_ (bs,   xs1) ->
 306     BIND (rdCoreExpr          xs1)  _TO_ (body, xs2) ->
 307     RETN (UfCoLam bs body, xs2)
 308     BEND BEND
 309
 310 rdCoreExpr ('F' : 'l' : xs)
 311   = BIND (rdList rdId   xs)         _TO_ (tvs,  xs1) ->
 312     BIND (rdCoreExpr    xs1)        _TO_ (body, xs2) ->
 313     RETN (foldr UfCoTyLam body tvs, xs2)
 314     BEND BEND
 315
 316 rdCoreExpr ('F' : 'm' : xs)
 317   = BIND (rdCoreExpr        xs)     _TO_ (fun,  xs1) ->
 318     BIND (rdList rdCoreAtom xs1)    _TO_ (args, xs2) ->
 319     RETN (foldl UfCoApp fun args, xs2)
 320     BEND BEND
 321
 322
 323 rdCoreExpr ('F' : 'n' : xs)
 324   = BIND (rdCoreExpr    xs)         _TO_ (expr, xs1) ->
 325     BIND (rdCoreType    xs1)        _TO_ (ty,   xs2) ->
 326     RETN (UfCoTyApp expr ty, xs2)
 327     BEND BEND
 328
 329 rdCoreExpr ('F' : 'o' : xs)
 330   = BIND (rdCoreExpr    xs)         _TO_ (scrut, xs1) ->
 331     BIND (rd_alts       xs1)        _TO_ (alts,  xs2) ->
 332     RETN (UfCoCase scrut alts, xs2)
 333     BEND BEND
 334   where
 335     rd_alts ('F' : 'q' : xs)
 336       = BIND (rdList rd_alg_alt xs)     _TO_ (alts,  xs1) ->
 337         BIND (rd_deflt          xs1)    _TO_ (deflt, xs2) ->
 338         RETN (UfCoAlgAlts alts deflt, xs2)
 339         BEND BEND
 340       where
 341         rd_alg_alt ('F' : 'r' : xs)
 342           = BIND (rdCoreId            xs)   _TO_ (BoringUfId con, xs1) ->
 343             BIND (rdList rdCoreBinder xs1)  _TO_ (params,         xs2) ->
 344             BIND (rdCoreExpr          xs2)  _TO_ (rhs,            xs3) ->
 345             RETN ((con, params, rhs), xs3)
 346             BEND BEND BEND
 347
 348     rd_alts ('F' : 's' : xs)
 349       = BIND (rdList rd_prim_alt xs)    _TO_ (alts,  xs1) ->
 350         BIND (rd_deflt           xs1)   _TO_ (deflt, xs2) ->
 351         RETN (UfCoPrimAlts alts deflt, xs2)
 352         BEND BEND
 353       where
 354         rd_prim_alt ('F' : 't' : xs)
 355           = BIND (rdBasicLit    xs)   _TO_ (lit, xs1) ->
 356             BIND (rdCoreExpr    xs1)  _TO_ (rhs, xs2) ->
 357             RETN ((lit, rhs), xs2)
 358             BEND BEND
 359
 360     rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs)
 361     rd_deflt ('F' : 'v' : xs)
 362       = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 363         BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 364         RETN (UfCoBindDefault b rhs, xs2)
 365         BEND BEND
 366
 367 rdCoreExpr ('F' : 'p' : xs)
 368   = BIND (rd_bind    xs)  _TO_ (bind, xs1) ->
 369     BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
 370     RETN (UfCoLet bind body, xs2)
 371     BEND BEND
 372   where
 373     rd_bind ('F' : 'd' : xs)
 374       = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 375         BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 376         RETN (UfCoNonRec b rhs, xs2)
 377         BEND BEND
 378
 379     rd_bind ('F' : 'e' : xs)
 380       = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) ->
 381         RETN (UfCoRec pairs, xs1)
 382         BEND
 383       where
 384         rd_pair ('F' : 'f' : xs)
 385           = BIND (rdCoreBinder xs)  _TO_ (b,   xs1) ->
 386             BIND (rdCoreExpr   xs1) _TO_ (rhs, xs2) ->
 387             RETN ((b, rhs), xs2)
 388             BEND BEND
 389
 390 rdCoreExpr ('F' : 'z' : xs)
 391   = BIND (rd_cc      xs)  _TO_ (cc,   xs1) ->
 392     BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
 393     RETN (UfCoSCC cc body, xs2)
 394     BEND BEND
 395   where
 396     rd_cc ('F' : '?' : 'a' : xs)
 397       = BIND (rd_dupd xs)       _TO_ (is_dupd, xs1) ->
 398         RETN (UfPreludeDictsCC is_dupd, xs1)
 399         BEND
 400
 401     rd_cc ('F' : '?' : 'b' : xs)
 402       = BIND (rdString xs)      _TO_ (m,       xs1) ->
 403         BIND (rdString xs1)     _TO_ (g,       xs2) ->
 404         BIND (rd_dupd  xs2)     _TO_ (is_dupd, xs3) ->
 405         RETN (UfAllDictsCC m g is_dupd, xs3)
 406         BEND BEND BEND
 407
 408     rd_cc ('F' : '?' : 'c' : xs)
 409       = BIND (rdString xs)      _TO_ (n, xs1) ->
 410         BIND (rdString xs1)     _TO_ (m, xs2) ->
 411         BIND (rdString xs2)     _TO_ (g, xs3) ->
 412         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 413         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 414         RETN (UfUserCC n m g is_dupd is_cafd, xs5)
 415         BEND BEND BEND BEND BEND
 416
 417     rd_cc ('F' : '?' : 'd' : xs)
 418       = BIND (rdCoreId   xs)    _TO_ (i, xs1) ->
 419         BIND (rdString xs1)     _TO_ (m, xs2) ->
 420         BIND (rdString xs2)     _TO_ (g, xs3) ->
 421         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 422         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 423         RETN (UfAutoCC i m g is_dupd is_cafd, xs5)
 424         BEND BEND BEND BEND BEND
 425
 426     rd_cc ('F' : '?' : 'e' : xs)
 427       = BIND (rdCoreId   xs)    _TO_ (i, xs1) ->
 428         BIND (rdString xs1)     _TO_ (m, xs2) ->
 429         BIND (rdString xs2)     _TO_ (g, xs3) ->
 430         BIND (rd_dupd  xs3)     _TO_ (is_dupd, xs4) ->
 431         BIND (rd_cafd  xs4)     _TO_ (is_cafd, xs5) ->
 432         RETN (UfDictCC i m g is_dupd is_cafd, xs5)
 433         BEND BEND BEND BEND BEND
 434
 435     ------
 436     rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs)
 437     rd_cafd ('F' : '?' : 'g' : xs) = RETN (True,  xs)
 438 --  rd_cafd xs = panic ("rd_cafd:\n"++xs)
 439
 440     rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs)
 441     rd_dupd ('F' : '?' : 'i' : xs) = RETN (True,  xs)
 442 \end{code}
 443
 444 \begin{code}
 445 rdCoreBinder ('F' : 'a' : xs)
 446   = BIND (rdId          xs)     _TO_ (b,  xs1) ->
 447     BIND (rdCoreType    xs1)    _TO_ (ty, xs2) ->
 448     RETN ((b, ty), xs2)
 449     BEND BEND
 450
 451 rdCoreAtom ('F' : 'b' : xs)
 452   = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
 453     RETN (UfCoLitAtom lit, xs1)
 454     BEND
 455
 456 rdCoreAtom ('F' : 'c' : xs)
 457   = BIND (rdCoreId xs)   _TO_ (v,   xs1) ->
 458     RETN (UfCoVarAtom v, xs1)
 459     BEND
 460 \end{code}
 461
 462 \begin{code}
 463 rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String)
 464
 465 rdCoreType ('2' : 'C' : xs)
 466   = BIND (rdList rdId xs)       _TO_ (tvs, xs1) ->
 467     BIND (rdMonoType  xs1)      _TO_ (ty,  xs2) ->
 468     RETN (ForAllTy tvs ty, xs2)
 469     BEND BEND
 470
 471 rdCoreType other
 472   = BIND (rdMonoType other)     _TO_ (ty, xs1) ->
 473     RETN (UnoverloadedTy ty, xs1)
 474     BEND
 475 \end{code}
 476
 477 \begin{code}
 478 rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String)
 479
 480 rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
 481 rdCoreTypeMaybe ('2' : 'E' : xs)
 482   = BIND (rdCoreType xs)    _TO_ (ty, xs1) ->
 483     RETN(Just ty, xs1)
 484     BEND
 485
 486 rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs)
 487
 488 rdMonoTypeMaybe ('2' : 'E' : xs)
 489   = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
 490     RETN (Just mono_ty, xs1)
 491     BEND
 492 \end{code}
 493
 494 \begin{code}
 495 rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String)
 496
 497 rdCoreId ('F' : '1' : xs)
 498   = BIND (rdIdString xs)        _TO_ (v, xs1) ->
 499     RETN (BoringUfId (cvt_IdString v), xs1)
 500     BEND
 501 rdCoreId ('F' : '9' : xs)
 502   = BIND (rdIdString xs)        _TO_ (mod, xs1) ->
 503     BIND (rdIdString xs1)       _TO_ (nm,  xs2) ->
 504     RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2)
 505     BEND BEND
 506 rdCoreId ('F' : '2' : xs)
 507   = BIND (rdId xs)              _TO_ (clas,       xs1) ->
 508     BIND (rdId xs1)             _TO_ (super_clas, xs2) ->
 509     RETN (SuperDictSelUfId clas super_clas, xs2)
 510     BEND BEND
 511 rdCoreId ('F' : '3' : xs)
 512   = BIND (rdId xs)              _TO_ (clas,   xs1) ->
 513     BIND (rdId xs1)             _TO_ (method, xs2) ->
 514     RETN (ClassOpUfId clas method, xs2)
 515     BEND BEND
 516 rdCoreId ('F' : '4' : xs)
 517   = BIND (rdId xs)              _TO_ (clas,   xs1) ->
 518     BIND (rdId xs1)             _TO_ (method, xs2) ->
 519     RETN (DefaultMethodUfId clas method, xs2)
 520     BEND BEND
 521 rdCoreId ('F' : '5' : xs)
 522   = BIND (rdId       xs)        _TO_ (clas, xs1) ->
 523     BIND (rdCoreType xs1)       _TO_ (ty,   xs2) ->
 524     RETN (DictFunUfId clas ty, xs2)
 525     BEND BEND
 526 rdCoreId ('F' : '6' : xs)
 527   = BIND (rdId       xs)        _TO_ (clas, xs1) ->
 528     BIND (rdId       xs1)       _TO_ (op,   xs2) ->
 529     BIND (rdCoreType xs2)       _TO_ (ty,   xs3) ->
 530     RETN (ConstMethodUfId clas op ty, xs3)
 531     BEND BEND BEND
 532 rdCoreId ('F' : '7' : xs)
 533   = BIND (rdCoreId xs)                  _TO_ (unspec,    xs1) ->
 534     BIND (rdList rdMonoTypeMaybe xs1)   _TO_ (ty_maybes, xs2) ->
 535     RETN (SpecUfId unspec ty_maybes, xs2)
 536     BEND BEND
 537 rdCoreId ('F' : '8' : xs)
 538   = BIND (rdCoreId xs)                  _TO_ (unwrkr,    xs1) ->
 539     RETN (WorkerUfId unwrkr, xs1)
 540     BEND
 541
 542 cvt_IdString :: FAST_STRING -> ProtoName
 543
 544 cvt_IdString s
 545   = if (_HEAD_ s /= '_') then
 546         boring
 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 rdBasicLit :: String -> RETN_TYPE (BasicLit, String)
 568
 569 rdBasicLit ('R' : xs)
 570   = BIND (rdString xs)  _TO_ (n, xs1) ->
 571     BIND (rdString xs1) _TO_ (d, xs2) ->
 572     let
 573         num = ((read (_UNPK_ n)) :: Integer)
 574         den = ((read (_UNPK_ d)) :: Integer)
 575     in
 576     RETN (NoRepRational (num % den), xs2)
 577     BEND BEND
 578
 579 rdBasicLit ( tag : xs)
 580   = BIND (rdString xs) _TO_ (x, zs) ->
 581     let
 582         s = _UNPK_ x
 583
 584         as_char     = chr ((read s) :: Int)
 585             -- a char comes in as a number string
 586             -- representing its ASCII code
 587         as_integer  = readInteger s
 588 #ifdef __GLASGOW_HASKELL__
 589         as_rational = _readRational s -- non-std
 590 #else
 591         as_rational = ((read s)::Rational)
 592 #endif
 593         as_double   = ((read s) :: Double)
 594     in
 595     case tag of {
 596      'H' -> RETN (mkMachInt     as_integer, zs);
 597      'J' -> RETN (MachDouble    as_rational,zs);
 598      'K' -> RETN (MachFloat     as_rational,zs);
 599      'P' -> RETN (MachChar      as_char,    zs);
 600      'V' -> RETN (MachStr       x,          zs);
 601      'Y' -> BIND (rdString zs) _TO_ (k, zs2) ->
 602             RETN (MachLitLit    x (guessPrimKind k), zs2)
 603             BEND;
 604      'I' -> RETN (NoRepInteger  as_integer, zs);
 605      's' -> RETN (NoRepStr      x,          zs)
 606     } BEND
 607 \end{code}