ghc/compiler/prelude/PrelVals.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[PrelVals]{Prelude values the compiler ``knows about''}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module PrelVals where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(IdLoop)         ( UnfoldingGuidance(..) )
  13 import Id               ( Id(..), GenId, mkImported, mkUserId, mkTemplateLocals )
  14 IMPORT_DELOOPER(PrelLoop)
  15
  16 -- friends:
  17 import PrelMods
  18 import TysPrim
  19 import TysWiredIn
  20
  21 -- others:
  22 import CmdLineOpts      ( maybe_CompilingPrelude )
  23 import CoreSyn          -- quite a bit
  24 import IdInfo           -- quite a bit
  25 import Literal          ( mkMachInt )
  26 import PragmaInfo
  27 import PrimOp           ( PrimOp(..) )
  28 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  29 import Type             ( mkTyVarTy )
  30 import TyVar            ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
  31 import Unique           -- lots of *Keys
  32 import Util             ( panic )
  33 \end{code}
  34
  35
  36
  37
  38 \begin{code}
  39 -- only used herein:
  40 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
  41
  42 pcMiscPrelId key m n ty info
  43   = let
  44         name = mkWiredInName key (OrigName m n)
  45         imp  = mkImported name ty info -- the usual case...
  46     in
  47     imp
  48     -- We lie and say the thing is imported; otherwise, we get into
  49     -- a mess with dependency analysis; e.g., core2stg may heave in
  50     -- random calls to GHCbase.unpackPS.  If GHCbase is the module
  51     -- being compiled, then it's just a matter of luck if the definition
  52     -- will be in "the right place" to be in scope.
  53 {- ???
  54     case maybe_CompilingPrelude of
  55       Nothing -> imp
  56       Just modname ->
  57         if modname == _UNPK_ m -- we are compiling the module where this thing is defined...
  58         then mkUserId name ty NoPragmaInfo
  59         else imp
  60 -}
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 GHC randomly injects these into the code.
  70
  71 @patError@ is just a version of @error@ for pattern-matching
  72 failures.  It knows various ``codes'' which expand to longer
  73 strings---this saves space!
  74
  75 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
  76 well shouldn't be yanked on, but if one is, then you will get a
  77 friendly message from @absentErr@ (rather a totally random crash).
  78
  79 @parError@ is a special version of @error@ which the compiler does
  80 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
  81 templates, but we don't ever expect to generate code for it.
  82
  83 \begin{code}
  84 pc_bottoming_Id key mod name ty
  85  = pcMiscPrelId key mod name ty bottoming_info
  86  where
  87     bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
  88         -- these "bottom" out, no matter what their arguments
  89
  90 eRROR_ID
  91   = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
  92
  93 generic_ERROR_ID u n
  94   = pc_bottoming_Id u gHC__ n errorTy
  95
  96 pAT_ERROR_ID
  97   = generic_ERROR_ID patErrorIdKey SLIT("patError")
  98 rEC_CON_ERROR_ID
  99   = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
 100 rEC_UPD_ERROR_ID
 101   = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
 102 iRREFUT_PAT_ERROR_ID
 103   = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
 104 nON_EXHAUSTIVE_GUARDS_ERROR_ID
 105   = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
 106 nO_DEFAULT_METHOD_ERROR_ID
 107   = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
 108 nO_EXPLICIT_METHOD_ERROR_ID
 109   = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
 110
 111 aBSENT_ERROR_ID
 112   = pc_bottoming_Id absentErrorIdKey gHC__ SLIT("absentErr")
 113         (mkSigmaTy [alphaTyVar] [] alphaTy)
 114
 115 pAR_ERROR_ID
 116   = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError")
 117     (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
 118
 119 errorTy  :: Type
 120 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar))
 121 \end{code}
 122
 123 We want \tr{_trace} (NB: name not in user namespace) to be wired in
 124 because we don't want the strictness analyser to get ahold of it,
 125 decide that the second argument is strict, evaluate that first (!!),
 126 and make a jolly old mess.  Having \tr{_trace} wired in also helps when
 127 attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
 128 won't get an \tr{import} declaration in the interface file, so the
 129 importing-subsequently module needs to know it's magic.
 130 \begin{code}
 131 tRACE_ID
 132   = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
 133         (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
 134   where
 135     traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
 136 \end{code}
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 packStringForCId
 146   = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC")
 147         (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 148
 149 --------------------------------------------------------------------
 150
 151 unpackCStringId
 152   = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS")
 153                  (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 154 -- Andy says:
 155 --      (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
 156 -- but I don't like wired-in IdInfos (WDP)
 157
 158 unpackCString2Id -- for cases when a string has a NUL in it
 159   = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2")
 160                  (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
 161                  noIdInfo
 162
 163 --------------------------------------------------------------------
 164 unpackCStringAppendId
 165   = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS")
 166                 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
 167                 ((noIdInfo
 168                  {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
 169                  `addInfo` mkArityInfo 2)
 170
 171 unpackCStringFoldrId
 172   = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS")
 173                 (mkSigmaTy [alphaTyVar] []
 174                 (mkFunTys [addrPrimTy{-a "char *" pointer-},
 175                            mkFunTys [charTy, alphaTy] alphaTy,
 176                            alphaTy]
 177                           alphaTy))
 178                 ((noIdInfo
 179                  {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
 180                  `addInfo` mkArityInfo 3)
 181 \end{code}
 182
 183 OK, this is Will's idea: we should have magic values for Integers 0,
 184 +1, +2, and -1 (go ahead, fire me):
 185 \begin{code}
 186 integerZeroId
 187   = pcMiscPrelId integerZeroIdKey     gHC__ SLIT("integer_0")  integerTy noIdInfo
 188 integerPlusOneId
 189   = pcMiscPrelId integerPlusOneIdKey  gHC__ SLIT("integer_1")  integerTy noIdInfo
 190 integerPlusTwoId
 191   = pcMiscPrelId integerPlusTwoIdKey  gHC__ SLIT("integer_2")  integerTy noIdInfo
 192 integerMinusOneId
 193   = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
 194 \end{code}
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 \begin{code}
 203 --------------------------------------------------------------------
 204 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
 205 -- dangerousEval
 206 {-
 207    OLDER:
 208    seq = /\ a b -> \ x y -> case x of { _ -> y }
 209
 210    OLD:
 211    seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
 212
 213    NEW (95/05):
 214    seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
 215
 216 -}
 217
 218 seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
 219                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 220                     (mkFunTys [alphaTy, betaTy] betaTy))
 221                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
 222   where
 223     [x, y, z]
 224       = mkTemplateLocals [
 225         {-x-} alphaTy,
 226         {-y-} betaTy,
 227         {-z-} intPrimTy
 228         ]
 229
 230     seq_template
 231       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 232                 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
 233                   PrimAlts
 234                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 235                     (BindDefault z (Var y))))
 236
 237 --------------------------------------------------------------------
 238 -- parId :: "par", also used w/ GRIP, etc.
 239 {-
 240     OLDER:
 241
 242     par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
 243
 244     OLD:
 245
 246     par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
 247
 248     NEW (95/05):
 249
 250     par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
 251
 252 -}
 253 parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
 254                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 255                     (mkFunTys [alphaTy, betaTy] betaTy))
 256                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
 257   where
 258     [x, y, z]
 259       = mkTemplateLocals [
 260         {-x-} alphaTy,
 261         {-y-} betaTy,
 262         {-z-} intPrimTy
 263         ]
 264
 265     par_template
 266       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 267                 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
 268                   PrimAlts
 269                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 270                     (BindDefault z (Var y))))
 271
 272 -- forkId :: "fork", for *required* concurrent threads
 273 {-
 274    _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
 275 -}
 276 forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
 277                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 278                     (mkFunTys [alphaTy, betaTy] betaTy))
 279                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
 280   where
 281     [x, y, z]
 282       = mkTemplateLocals [
 283         {-x-} alphaTy,
 284         {-y-} betaTy,
 285         {-z-} intPrimTy
 286         ]
 287
 288     fork_template
 289       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 290                 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
 291                   PrimAlts
 292                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 293                     (BindDefault z (Var y))))
 294
 295 \end{code}
 296
 297 GranSim ones:
 298 \begin{code}
 299 parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
 300                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 301                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 302                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
 303   where
 304     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 305     [w, g, s, p, x, y, z]
 306       = mkTemplateLocals [
 307         {-w-} intPrimTy,
 308         {-g-} intPrimTy,
 309         {-s-} intPrimTy,
 310         {-p-} intPrimTy,
 311         {-x-} alphaTy,
 312         {-y-} betaTy,
 313         {-z-} intPrimTy
 314         ]
 315
 316     parLocal_template
 317       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
 318                 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 319                   PrimAlts
 320                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 321                     (BindDefault z (Var y))))
 322
 323 parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
 324                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 325                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 326                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
 327   where
 328     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 329     [w, g, s, p, x, y, z]
 330       = mkTemplateLocals [
 331         {-w-} intPrimTy,
 332         {-g-} intPrimTy,
 333         {-s-} intPrimTy,
 334         {-p-} intPrimTy,
 335         {-x-} alphaTy,
 336         {-y-} betaTy,
 337         {-z-} intPrimTy
 338         ]
 339
 340     parGlobal_template
 341       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
 342                 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 343                   PrimAlts
 344                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 345                     (BindDefault z (Var y))))
 346
 347
 348 parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
 349                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 350                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 351                                alphaTy, betaTy, gammaTy] gammaTy))
 352                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
 353   where
 354     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 355     [w, g, s, p, v, x, y, z]
 356       = mkTemplateLocals [
 357         {-w-} intPrimTy,
 358         {-g-} intPrimTy,
 359         {-s-} intPrimTy,
 360         {-p-} intPrimTy,
 361         {-v-} alphaTy,
 362         {-x-} betaTy,
 363         {-y-} gammaTy,
 364         {-z-} intPrimTy
 365         ]
 366
 367     parAt_template
 368       = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
 369                 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 370                   PrimAlts
 371                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 372                     (BindDefault z (Var y))))
 373
 374 parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
 375                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 376                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 377                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
 378   where
 379     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 380     [w, g, s, p, v, x, y, z]
 381       = mkTemplateLocals [
 382         {-w-} intPrimTy,
 383         {-g-} intPrimTy,
 384         {-s-} intPrimTy,
 385         {-p-} intPrimTy,
 386         {-v-} intPrimTy,
 387         {-x-} alphaTy,
 388         {-y-} betaTy,
 389         {-z-} intPrimTy
 390         ]
 391
 392     parAtAbs_template
 393       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
 394                 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 395                   PrimAlts
 396                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 397                     (BindDefault z (Var y))))
 398
 399 parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
 400                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 401                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 402                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
 403   where
 404     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 405     [w, g, s, p, v, x, y, z]
 406       = mkTemplateLocals [
 407         {-w-} intPrimTy,
 408         {-g-} intPrimTy,
 409         {-s-} intPrimTy,
 410         {-p-} intPrimTy,
 411         {-v-} intPrimTy,
 412         {-x-} alphaTy,
 413         {-y-} betaTy,
 414         {-z-} intPrimTy
 415         ]
 416
 417     parAtRel_template
 418       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
 419                 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 420                   PrimAlts
 421                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 422                     (BindDefault z (Var y))))
 423
 424 parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
 425                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 426                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 427                                 alphaTy, betaTy, gammaTy] gammaTy))
 428                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
 429   where
 430     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 431     [w, g, s, p, v, x, y, z]
 432       = mkTemplateLocals [
 433         {-w-} intPrimTy,
 434         {-g-} intPrimTy,
 435         {-s-} intPrimTy,
 436         {-p-} intPrimTy,
 437         {-v-} alphaTy,
 438         {-x-} betaTy,
 439         {-y-} gammaTy,
 440         {-z-} intPrimTy
 441         ]
 442
 443     parAtForNow_template
 444       = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
 445                 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 446                   PrimAlts
 447                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 448                     (BindDefault z (Var y))))
 449
 450 -- copyable and noFollow are currently merely hooks: they are translated into
 451 -- calls to the macros COPYABLE and NOFOLLOW                            -- HWL
 452
 453 copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
 454                   (mkSigmaTy [alphaTyVar] []
 455                     alphaTy)
 456                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
 457   where
 458     -- Annotations: x: closure that's tagged to by copyable
 459     [x, z]
 460       = mkTemplateLocals [
 461         {-x-} alphaTy,
 462         {-z-} alphaTy
 463         ]
 464
 465     copyable_template
 466       = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
 467
 468 noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
 469                   (mkSigmaTy [alphaTyVar] []
 470                     alphaTy)
 471                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
 472   where
 473     -- Annotations: x: closure that's tagged to not follow
 474     [x, z]
 475       = mkTemplateLocals [
 476         {-x-} alphaTy,
 477         {-z-} alphaTy
 478         ]
 479
 480     noFollow_template
 481       = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
 482 \end{code}
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 map             :: (a -> b) -> [a] -> [b]
 491         -- this is up in the here-because-of-unfolding list
 492
 493 --??showChar    :: Char -> ShowS
 494 showSpace       :: ShowS        -- non-std: == "showChar ' '"
 495 showString      :: String -> ShowS
 496 showParen       :: Bool -> ShowS -> ShowS
 497
 498 (++)            :: [a] -> [a] -> [a]
 499 readParen       :: Bool -> ReadS a -> ReadS a
 500 lex             :: ReadS String
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 @_runST@ has a non-Haskell-able type:
 509 \begin{verbatim}
 510 -- _runST :: forall a. (forall s. _ST s a) -> a
 511 -- which is to say ::
 512 --           forall a. (forall s. (_State s -> (a, _State s))) -> a
 513
 514 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
 515                (r :: a, wild :: _State _RealWorld) -> r
 516 \end{verbatim}
 517 We unfold always, just for simplicity:
 518 \begin{code}
 519 runSTId
 520   = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
 521   where
 522     s_tv = betaTyVar
 523     s    = betaTy
 524
 525     st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
 526
 527     run_ST_ty
 528       = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
 529             -- NB: rank-2 polymorphism! (forall inside the st_ty...)
 530
 531     id_info
 532       = noIdInfo
 533         `addInfo` mkArityInfo 1
 534         `addInfo` mkStrictnessInfo [WwStrict] Nothing
 535         `addInfo` mkArgUsageInfo [ArgUsage 1]
 536         -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
 537         -- see example below
 538 {- OUT:
 539     [m, t, r, wild]
 540       = mkTemplateLocals [
 541         {-m-} st_ty alphaTy,
 542         {-t-} realWorldStateTy,
 543         {-r-} alphaTy,
 544         {-_-} realWorldStateTy
 545         ]
 546
 547     run_ST_template
 548       = mkLam [alphaTyVar] [m] (
 549             Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
 550               Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
 551                 AlgAlts
 552                   [(mkTupleCon 2, [r, wild], Var r)]
 553                   NoDefault)))
 554 -}
 555 \end{code}
 556
 557 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
 558 \begin{verbatim}
 559 f x =
 560   _runST ( \ s -> let
 561                     (a, s')  = newArray# 100 [] s
 562                     (_, s'') = fill_in_array_or_something a x s'
 563                   in
 564                   freezeArray# a s'' )
 565 \end{verbatim}
 566 If we inline @_runST@, we'll get:
 567 \begin{verbatim}
 568 f x = let
 569         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 570         (_, s'') = fill_in_array_or_something a x s'
 571       in
 572       freezeArray# a s''
 573 \end{verbatim}
 574 And now the @newArray#@ binding can be floated to become a CAF, which
 575 is totally and utterly wrong:
 576 \begin{verbatim}
 577 f = let
 578     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 579     in
 580     \ x ->
 581         let (_, s'') = fill_in_array_or_something a x s' in
 582         freezeArray# a s''
 583 \end{verbatim}
 584 All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 585
 586 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 587 nasty as-is, change it back to a literal (@Literal@).
 588 \begin{code}
 589 realWorldPrimId
 590   = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
 591         realWorldStatePrimTy
 592         noIdInfo
 593 \end{code}
 594
 595 \begin{code}
 596 voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
 597 \end{code}
 598
 599 %************************************************************************
 600 %*                                                                      *
 601 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
 602 %*                                                                      *
 603 %************************************************************************
 604
 605 \begin{code}
 606 buildId
 607   = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy
 608         ((((noIdInfo
 609                 {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
 610                 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
 611                 `addInfo` mkArgUsageInfo [ArgUsage 2])
 612                 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 613         -- cheating, but since _build never actually exists ...
 614   where
 615     -- The type of this strange object is:
 616     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 617
 618     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 619         where
 620             build_ty = mkSigmaTy [betaTyVar] []
 621                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 622 \end{code}
 623
 624 @mkBuild@ is sugar for building a build!
 625
 626 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 627 @ty@ is the type of the list.
 628 @tv@ is always a new type variable.
 629 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 630         c :: a -> b -> b
 631         n :: b
 632         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 633 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 634 @e@ is the object right inside the @build@
 635
 636 \begin{code}
 637 mkBuild :: Type
 638         -> TyVar
 639         -> Id
 640         -> Id
 641         -> Id
 642         -> CoreExpr -- template
 643         -> CoreExpr -- template
 644
 645 mkBuild ty tv c n g expr
 646   = Let (NonRec g (mkLam [tv] [c,n] expr))
 647         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 648 \end{code}
 649
 650 \begin{code}
 651 augmentId
 652   = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy
 653         (((noIdInfo
 654                 {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
 655                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 656                 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 657         -- cheating, but since _augment never actually exists ...
 658   where
 659     -- The type of this strange object is:
 660     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 661
 662     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 663         where
 664             aug_ty = mkSigmaTy [betaTyVar] []
 665                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 666 \end{code}
 667
 668 \begin{code}
 669 foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
 670                  foldrTy idInfo
 671   where
 672         foldrTy =
 673           mkSigmaTy [alphaTyVar, betaTyVar] []
 674                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 675
 676         idInfo = (((((noIdInfo
 677                         {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
 678                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 679                         `addInfo` mkArityInfo 3)
 680                         `addInfo` mkUpdateInfo [2,2,1])
 681                         `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 682
 683 foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
 684                  foldlTy idInfo
 685   where
 686         foldlTy =
 687           mkSigmaTy [alphaTyVar, betaTyVar] []
 688                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 689
 690         idInfo = (((((noIdInfo
 691                         {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
 692                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 693                         `addInfo` mkArityInfo 3)
 694                         `addInfo` mkUpdateInfo [2,2,1])
 695                         `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 696
 697 -- A bit of magic goes no here. We translate appendId into ++,
 698 -- you have to be carefull when you actually compile append:
 699 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 700 --               {- unfold augment -}
 701 --               = foldr (:) ys xs
 702 --               {- fold foldr to append -}
 703 --               = ys `appendId` xs
 704 --               = ys ++ xs             -- ugg!
 705 -- *BUT* you want (++) and not _append in your interfaces.
 706 --
 707 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 708 -- the prelude.
 709 --
 710 {- OLD: doesn't apply with 1.3
 711 appendId
 712   = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
 713   where
 714     appendTy =
 715       (mkSigmaTy [alphaTyVar] []
 716             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 717     idInfo = (((noIdInfo
 718                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 719                 `addInfo` mkArityInfo 2)
 720                 `addInfo` mkUpdateInfo [1,2])
 721 -}
 722 \end{code}
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 The specialisations which exist for the builtin values must be recorded in
 731 their IdInfos.
 732
 733 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 734       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 735
 736 HACK: We currently use the same unique for the specialised Ids.
 737
 738 The list @specing_types@ determines the types for which specialised
 739 versions are created. Note: This should correspond with the
 740 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 741
 742 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 743
 744 \begin{code}
 745 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
 746 pcGenerateSpecs key id info ty
 747   = nullSpecEnv
 748
 749 {- LATER:
 750
 751 pc_gen_specs True key id info ty
 752
 753 pc_gen_specs is_id key id info ty
 754  = mkSpecEnv spec_infos
 755  where
 756    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 757                       spec_id = if is_id
 758                                 then mkSpecId key {- HACK WARNING: same unique! -}
 759                                               id spec_tys spec_ty info
 760                                 else panic "SpecData:SpecInfo:SpecId"
 761                   in
 762                   SpecInfo spec_tys (length ctxts) spec_id
 763                 | spec_tys <- specialisations ]
 764
 765    (tyvars, ctxts, _) = splitSigmaTy ty
 766    no_tyvars          = length tyvars
 767
 768    specialisations    = if no_tyvars == 0
 769                         then []
 770                         else tail (cross_product no_tyvars specing_types)
 771
 772                         -- N.B. tail removes fully polymorphic specialisation
 773
 774 cross_product 0 tys = []
 775 cross_product 1 tys = map (:[]) tys
 776 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 777
 778
 779 specing_types = [Nothing,
 780                  Just charPrimTy,
 781                  Just doublePrimTy,
 782                  Just intPrimTy ]
 783 -}
 784 \end{code}