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