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