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