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 eRROR 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 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 496 nasty as-is, change it back to a literal (@Literal@).
 497 \begin{code}
 498 realWorldPrimId
 499   = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
 500         realWorldStatePrimTy
 501         noIdInfo
 502 \end{code}
 503
 504 \begin{code}
 505 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
 506 \end{code}
 507
 508 %************************************************************************
 509 %*                                                                      *
 510 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
 511 %*                                                                      *
 512 %************************************************************************
 513
 514 \begin{code}
 515 buildId
 516   = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
 517         ((((noIdInfo
 518                 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
 519                 `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
 520                 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
 521                 `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 522         -- cheating, but since _build never actually exists ...
 523   where
 524     -- The type of this strange object is:
 525     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 526
 527     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 528         where
 529             build_ty = mkSigmaTy [betaTyVar] []
 530                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 531 \end{code}
 532
 533 @mkBuild@ is sugar for building a build!
 534
 535 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 536 @ty@ is the type of the list.
 537 @tv@ is always a new type variable.
 538 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 539         c :: a -> b -> b
 540         n :: b
 541         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 542 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 543 @e@ is the object right inside the @build@
 544
 545 \begin{code}
 546 mkBuild :: Type
 547         -> TyVar
 548         -> Id
 549         -> Id
 550         -> Id
 551         -> CoreExpr -- template
 552         -> CoreExpr -- template
 553
 554 mkBuild ty tv c n g expr
 555   = Let (NonRec g (mkLam [tv] [c,n] expr))
 556         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 557 \end{code}
 558
 559 \begin{code}
 560 augmentId
 561   = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
 562         (((noIdInfo
 563                 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
 564                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
 565                 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 566         -- cheating, but since _augment never actually exists ...
 567   where
 568     -- The type of this strange object is:
 569     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 570
 571     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 572         where
 573             aug_ty = mkSigmaTy [betaTyVar] []
 574                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 575 \end{code}
 576
 577 \begin{code}
 578 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
 579                  foldrTy idInfo
 580   where
 581         foldrTy =
 582           mkSigmaTy [alphaTyVar, betaTyVar] []
 583                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 584
 585         idInfo = (((((noIdInfo
 586                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
 587                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
 588                         `addArityInfo` exactArity 3)
 589                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 590                         `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 591
 592 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
 593                  foldlTy idInfo
 594   where
 595         foldlTy =
 596           mkSigmaTy [alphaTyVar, betaTyVar] []
 597                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 598
 599         idInfo = (((((noIdInfo
 600                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
 601                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
 602                         `addArityInfo` exactArity 3)
 603                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 604                         `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 605
 606 -- A bit of magic goes no here. We translate appendId into ++,
 607 -- you have to be carefull when you actually compile append:
 608 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 609 --               {- unfold augment -}
 610 --               = foldr (:) ys xs
 611 --               {- fold foldr to append -}
 612 --               = ys `appendId` xs
 613 --               = ys ++ xs             -- ugg!
 614 -- *BUT* you want (++) and not _append in your interfaces.
 615 --
 616 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 617 -- the prelude.
 618 --
 619 {- OLD: doesn't apply with 1.3
 620 appendId
 621   = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
 622   where
 623     appendTy =
 624       (mkSigmaTy [alphaTyVar] []
 625             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 626     idInfo = (((noIdInfo
 627                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
 628                 `addArityInfo` exactArity 2)
 629                 `addUpdateInfo` mkUpdateInfo [1,2])
 630 -}
 631 \end{code}
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 The specialisations which exist for the builtin values must be recorded in
 640 their IdInfos.
 641
 642 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 643       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 644
 645 HACK: We currently use the same unique for the specialised Ids.
 646
 647 The list @specing_types@ determines the types for which specialised
 648 versions are created. Note: This should correspond with the
 649 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 650
 651 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 652
 653 \begin{code}
 654 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
 655 pcGenerateSpecs key id info ty
 656   = nullSpecEnv
 657
 658 {- LATER:
 659
 660 pc_gen_specs True key id info ty
 661
 662 pc_gen_specs is_id key id info ty
 663  = mkSpecEnv spec_infos
 664  where
 665    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 666                       spec_id = if is_id
 667                                 then mkSpecId key {- HACK WARNING: same unique! -}
 668                                               id spec_tys spec_ty info
 669                                 else panic "SpecData:SpecInfo:SpecId"
 670                   in
 671                   SpecInfo spec_tys (length ctxts) spec_id
 672                 | spec_tys <- specialisations ]
 673
 674    (tyvars, ctxts, _) = splitSigmaTy ty
 675    no_tyvars          = length tyvars
 676
 677    specialisations    = if no_tyvars == 0
 678                         then []
 679                         else tail (cross_product no_tyvars specing_types)
 680
 681                         -- N.B. tail removes fully polymorphic specialisation
 682
 683 cross_product 0 tys = []
 684 cross_product 1 tys = map (:[]) tys
 685 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 686
 687
 688 specing_types = [Nothing,
 689                  Just charPrimTy,
 690                  Just doublePrimTy,
 691                  Just intPrimTy ]
 692 -}
 693 \end{code}