ghc/compiler/prelude/PrelVals.lhs

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