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