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