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