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