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