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, mkImported )
  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 PragmaInfo
  26 import Type
  27 import TyVar            ( openAlphaTyVar, alphaTyVar, betaTyVar, TyVar )
  28 import Unique           -- lots of *Keys
  29 import Util             ( panic )
  30 \end{code}
  31
  32 \begin{code}
  33 -- only used herein:
  34
  35 mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
  36
  37 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
  38
  39 pcMiscPrelId key mod occ ty info
  40   = let
  41         name = mkWiredInIdName key mod occ imp
  42         imp  = mkImported name ty info -- the usual case...
  43     in
  44     imp
  45     -- We lie and say the thing is imported; otherwise, we get into
  46     -- a mess with dependency analysis; e.g., core2stg may heave in
  47     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
  48     -- being compiled, then it's just a matter of luck if the definition
  49     -- will be in "the right place" to be in scope.
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 GHC randomly injects these into the code.
  59
  60 @patError@ is just a version of @error@ for pattern-matching
  61 failures.  It knows various ``codes'' which expand to longer
  62 strings---this saves space!
  63
  64 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
  65 well shouldn't be yanked on, but if one is, then you will get a
  66 friendly message from @absentErr@ (rather a totally random crash).
  67
  68 @parError@ is a special version of @error@ which the compiler does
  69 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
  70 templates, but we don't ever expect to generate code for it.
  71
  72 \begin{code}
  73 pc_bottoming_Id key mod name ty
  74  = pcMiscPrelId key mod name ty bottoming_info
  75  where
  76     bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
  77         -- these "bottom" out, no matter what their arguments
  78
  79 eRROR_ID
  80   = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
  81
  82 generic_ERROR_ID u n
  83   = pc_bottoming_Id u pREL_ERR n errorTy
  84
  85 pAT_ERROR_ID
  86   = generic_ERROR_ID patErrorIdKey SLIT("patError")
  87 rEC_CON_ERROR_ID
  88   = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
  89 rEC_UPD_ERROR_ID
  90   = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
  91 iRREFUT_PAT_ERROR_ID
  92   = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
  93 nON_EXHAUSTIVE_GUARDS_ERROR_ID
  94   = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
  95 nO_METHOD_BINDING_ERROR_ID
  96   = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
  97
  98 aBSENT_ERROR_ID
  99   = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
 100         (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 101
 102 pAR_ERROR_ID
 103   = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
 104     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
 105
 106 openAlphaTy = mkTyVarTy openAlphaTyVar
 107
 108 errorTy  :: Type
 109 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
 110     -- Notice the openAlphaTyVar.  It says that "error" can be applied
 111     -- to unboxed as well as boxed types.  This is OK because it never
 112     -- returns, so the return type is irrelevant.
 113 \end{code}
 114
 115 We want \tr{GHCbase.trace} to be wired in
 116 because we don't want the strictness analyser to get ahold of it,
 117 decide that the second argument is strict, evaluate that first (!!),
 118 and make a jolly old mess.
 119 \begin{code}
 120 tRACE_ID
 121   = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy
 122         (noIdInfo `setSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
 123   where
 124     traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
 125 \end{code}
 126
 127 %************************************************************************
 128 %*                                                                      *
 129 \subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 \begin{code}
 134 packStringForCId
 135   = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#")
 136         (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 137
 138 --------------------------------------------------------------------
 139
 140 unpackCStringId
 141   = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
 142                  (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 143 -- Andy says:
 144 --      (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
 145 -- but I don't like wired-in IdInfos (WDP)
 146
 147 unpackCString2Id -- for cases when a string has a NUL in it
 148   = pcMiscPrelId unpackCString2IdKey pREL_PACK SLIT("unpackNBytes#")
 149                  (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
 150                  noIdInfo
 151
 152 --------------------------------------------------------------------
 153 unpackCStringAppendId
 154   = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
 155                 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
 156                 ((noIdInfo
 157                  {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
 158                  `addArityInfo` exactArity 2)
 159
 160 unpackCStringFoldrId
 161   = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
 162                 (mkSigmaTy [alphaTyVar] []
 163                 (mkFunTys [addrPrimTy{-a "char *" pointer-},
 164                            mkFunTys [charTy, alphaTy] alphaTy,
 165                            alphaTy]
 166                           alphaTy))
 167                 ((noIdInfo
 168                  {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
 169                  `addArityInfo` exactArity 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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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                   (noIdInfo `addUnfoldInfo` (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         -- cheating, but since _build never actually exists ...
 505   where
 506     -- The type of this strange object is:
 507     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 508
 509     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 510         where
 511             build_ty = mkSigmaTy [betaTyVar] []
 512                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 513 \end{code}
 514
 515 @mkBuild@ is sugar for building a build!
 516
 517 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 518 @ty@ is the type of the list.
 519 @tv@ is always a new type variable.
 520 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 521         c :: a -> b -> b
 522         n :: b
 523         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 524 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 525 @e@ is the object right inside the @build@
 526
 527 \begin{code}
 528 mkBuild :: Type
 529         -> TyVar
 530         -> Id
 531         -> Id
 532         -> Id
 533         -> CoreExpr -- template
 534         -> CoreExpr -- template
 535
 536 mkBuild ty tv c n g expr
 537   = Let (NonRec g (mkLam [tv] [c,n] expr))
 538         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 539 \end{code}
 540
 541 \begin{code}
 542 augmentId
 543   = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
 544         (((noIdInfo
 545                 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
 546                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
 547                 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 548         -- cheating, but since _augment never actually exists ...
 549   where
 550     -- The type of this strange object is:
 551     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 552
 553     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 554         where
 555             aug_ty = mkSigmaTy [betaTyVar] []
 556                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 557 \end{code}
 558
 559 \begin{code}
 560 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
 561                  foldrTy idInfo
 562   where
 563         foldrTy =
 564           mkSigmaTy [alphaTyVar, betaTyVar] []
 565                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 566
 567         idInfo = (((((noIdInfo
 568                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
 569                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
 570                         `addArityInfo` exactArity 3)
 571                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 572                         `setSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 573
 574 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
 575                  foldlTy idInfo
 576   where
 577         foldlTy =
 578           mkSigmaTy [alphaTyVar, betaTyVar] []
 579                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 580
 581         idInfo = (((((noIdInfo
 582                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
 583                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
 584                         `addArityInfo` exactArity 3)
 585                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 586                         `setSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 587
 588 -- A bit of magic goes no here. We translate appendId into ++,
 589 -- you have to be carefull when you actually compile append:
 590 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 591 --               {- unfold augment -}
 592 --               = foldr (:) ys xs
 593 --               {- fold foldr to append -}
 594 --               = ys `appendId` xs
 595 --               = ys ++ xs             -- ugg!
 596 -- *BUT* you want (++) and not _append in your interfaces.
 597 --
 598 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 599 -- the prelude.
 600 --
 601 {- OLD: doesn't apply with 1.3
 602 appendId
 603   = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
 604   where
 605     appendTy =
 606       (mkSigmaTy [alphaTyVar] []
 607             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 608     idInfo = (((noIdInfo
 609                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
 610                 `addArityInfo` exactArity 2)
 611                 `addUpdateInfo` mkUpdateInfo [1,2])
 612 -}
 613 \end{code}
 614
 615 %************************************************************************
 616 %*                                                                      *
 617 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 618 %*                                                                      *
 619 %************************************************************************
 620
 621 The specialisations which exist for the builtin values must be recorded in
 622 their IdInfos.
 623
 624 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 625       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 626
 627 HACK: We currently use the same unique for the specialised Ids.
 628
 629 The list @specing_types@ determines the types for which specialised
 630 versions are created. Note: This should correspond with the
 631 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 632
 633 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 634
 635 \begin{code}
 636 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv
 637 pcGenerateSpecs key id info ty
 638   = emptySpecEnv
 639
 640 {- LATER:
 641
 642 pc_gen_specs True key id info ty
 643
 644 pc_gen_specs is_id key id info ty
 645  = mkSpecEnv spec_infos
 646  where
 647    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 648                       spec_id = if is_id
 649                                 then mkSpecId key {- HACK WARNING: same unique! -}
 650                                               id spec_tys spec_ty info
 651                                 else panic "SpecData:SpecInfo:SpecId"
 652                   in
 653                   SpecInfo spec_tys (length ctxts) spec_id
 654                 | spec_tys <- specialisations ]
 655
 656    (tyvars, ctxts, _) = splitSigmaTy ty
 657    no_tyvars          = length tyvars
 658
 659    specialisations    = if no_tyvars == 0
 660                         then []
 661                         else tail (cross_product no_tyvars specing_types)
 662
 663                         -- N.B. tail removes fully polymorphic specialisation
 664
 665 cross_product 0 tys = []
 666 cross_product 1 tys = map (:[]) tys
 667 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 668
 669
 670 specing_types = [Nothing,
 671                  Just charPrimTy,
 672                  Just doublePrimTy,
 673                  Just intPrimTy ]
 674 -}
 675 \end{code}