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, 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             ( mkWiredInIdName )
  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-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
  38
  39 pcMiscPrelId key mod occ ty info
  40   = let
  41         name = mkWiredInIdName key mod occ imp
  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 `addStrictnessInfo` mkBottomStrictnessInfo
  77         -- these "bottom" out, no matter what their arguments
  78
  79 eRROR_ID
  80   = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
  81
  82 generic_ERROR_ID u n
  83   = pc_bottoming_Id u gHC_ERR 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 gHC_ERR SLIT("absentErr")
 102         (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 103
 104 pAR_ERROR_ID
 105   = pcMiscPrelId parErrorIdKey gHC_ERR 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 iO_BASE SLIT("trace") traceTy
 124         (noIdInfo `addSpecInfo` 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-} pACKED_STRING SLIT("packCString#")
 138         (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 139
 140 --------------------------------------------------------------------
 141
 142 unpackCStringId
 143   = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
 144                  (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 145 -- Andy says:
 146 --      (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 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 pACKED_STRING SLIT("unpackCString2#")
 151                  (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
 152                  noIdInfo
 153
 154 --------------------------------------------------------------------
 155 unpackCStringAppendId
 156   = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
 157                 (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
 158                 ((noIdInfo
 159                  {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
 160                  `addArityInfo` exactArity 2)
 161
 162 unpackCStringFoldrId
 163   = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
 164                 (mkSigmaTy [alphaTyVar] []
 165                 (mkFunTys [addrPrimTy{-a "char *" pointer-},
 166                            mkFunTys [charTy, alphaTy] alphaTy,
 167                            alphaTy]
 168                           alphaTy))
 169                 ((noIdInfo
 170                  {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
 171                  `addArityInfo` exactArity 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
 177 \begin{code}
 178 integerZeroId
 179   = pcMiscPrelId integerZeroIdKey     pREL_NUM SLIT("integer_0")  integerTy noIdInfo
 180 integerPlusOneId
 181   = pcMiscPrelId integerPlusOneIdKey  pREL_NUM SLIT("integer_1")  integerTy noIdInfo
 182 integerPlusTwoId
 183   = pcMiscPrelId integerPlusTwoIdKey  pREL_NUM SLIT("integer_2")  integerTy noIdInfo
 184 integerMinusOneId
 185   = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 {- OUT:
 196 --------------------------------------------------------------------
 197 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
 198 -- dangerousEval
 199 {-
 200    OLDER:
 201    seq = /\ a b -> \ x y -> case x of { _ -> y }
 202
 203    OLD:
 204    seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
 205
 206    NEW (95/05):
 207    seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
 208
 209 -}
 210
 211 seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
 212                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 213                     (mkFunTys [alphaTy, betaTy] betaTy))
 214                   (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template))
 215   where
 216     [x, y, z]
 217       = mkTemplateLocals [
 218         {-x-} alphaTy,
 219         {-y-} betaTy,
 220         {-z-} intPrimTy
 221         ]
 222
 223     seq_template
 224       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 225                 Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
 226                   PrimAlts
 227                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 228                     (BindDefault z (Var y))))
 229
 230 --------------------------------------------------------------------
 231 -- parId :: "par", also used w/ GRIP, etc.
 232 {-
 233     OLDER:
 234
 235     par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
 236
 237     OLD:
 238
 239     par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
 240
 241     NEW (95/05):
 242
 243     par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
 244
 245 -}
 246 parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
 247                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 248                     (mkFunTys [alphaTy, betaTy] betaTy))
 249                   (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template))
 250   where
 251     [x, y, z]
 252       = mkTemplateLocals [
 253         {-x-} alphaTy,
 254         {-y-} betaTy,
 255         {-z-} intPrimTy
 256         ]
 257
 258     par_template
 259       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 260                 Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
 261                   PrimAlts
 262                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 263                     (BindDefault z (Var y))))
 264
 265 -- forkId :: "fork", for *required* concurrent threads
 266 {-
 267    _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
 268 -}
 269 forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
 270                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 271                     (mkFunTys [alphaTy, betaTy] betaTy))
 272                   (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template))
 273   where
 274     [x, y, z]
 275       = mkTemplateLocals [
 276         {-x-} alphaTy,
 277         {-y-} betaTy,
 278         {-z-} intPrimTy
 279         ]
 280
 281     fork_template
 282       = mkLam [alphaTyVar, betaTyVar] [x, y] (
 283                 Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
 284                   PrimAlts
 285                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 286                     (BindDefault z (Var y))))
 287 -}
 288 \end{code}
 289
 290 GranSim ones:
 291 \begin{code}
 292 {- OUT:
 293 parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
 294                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 295                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 296                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template))
 297   where
 298     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 299     [w, g, s, p, x, y, z]
 300       = mkTemplateLocals [
 301         {-w-} intPrimTy,
 302         {-g-} intPrimTy,
 303         {-s-} intPrimTy,
 304         {-p-} intPrimTy,
 305         {-x-} alphaTy,
 306         {-y-} betaTy,
 307         {-z-} intPrimTy
 308         ]
 309
 310     parLocal_template
 311       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
 312                 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 313                   PrimAlts
 314                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 315                     (BindDefault z (Var y))))
 316
 317 parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
 318                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 319                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 320                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template))
 321   where
 322     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 323     [w, g, s, p, x, y, z]
 324       = mkTemplateLocals [
 325         {-w-} intPrimTy,
 326         {-g-} intPrimTy,
 327         {-s-} intPrimTy,
 328         {-p-} intPrimTy,
 329         {-x-} alphaTy,
 330         {-y-} betaTy,
 331         {-z-} intPrimTy
 332         ]
 333
 334     parGlobal_template
 335       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
 336                 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 337                   PrimAlts
 338                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 339                     (BindDefault z (Var y))))
 340
 341
 342 parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
 343                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 344                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 345                                alphaTy, betaTy, gammaTy] gammaTy))
 346                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template))
 347   where
 348     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 349     [w, g, s, p, v, x, y, z]
 350       = mkTemplateLocals [
 351         {-w-} intPrimTy,
 352         {-g-} intPrimTy,
 353         {-s-} intPrimTy,
 354         {-p-} intPrimTy,
 355         {-v-} alphaTy,
 356         {-x-} betaTy,
 357         {-y-} gammaTy,
 358         {-z-} intPrimTy
 359         ]
 360
 361     parAt_template
 362       = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
 363                 Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 364                   PrimAlts
 365                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
 366                     (BindDefault z (Var y))))
 367
 368 parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
 369                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 370                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 371                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template))
 372   where
 373     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 374     [w, g, s, p, v, x, y, z]
 375       = mkTemplateLocals [
 376         {-w-} intPrimTy,
 377         {-g-} intPrimTy,
 378         {-s-} intPrimTy,
 379         {-p-} intPrimTy,
 380         {-v-} intPrimTy,
 381         {-x-} alphaTy,
 382         {-y-} betaTy,
 383         {-z-} intPrimTy
 384         ]
 385
 386     parAtAbs_template
 387       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
 388                 Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 389                   PrimAlts
 390                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 391                     (BindDefault z (Var y))))
 392
 393 parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
 394                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 395                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 396                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template))
 397   where
 398     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 399     [w, g, s, p, v, x, y, z]
 400       = mkTemplateLocals [
 401         {-w-} intPrimTy,
 402         {-g-} intPrimTy,
 403         {-s-} intPrimTy,
 404         {-p-} intPrimTy,
 405         {-v-} intPrimTy,
 406         {-x-} alphaTy,
 407         {-y-} betaTy,
 408         {-z-} intPrimTy
 409         ]
 410
 411     parAtRel_template
 412       = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
 413                 Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 414                   PrimAlts
 415                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
 416                     (BindDefault z (Var y))))
 417
 418 parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
 419                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 420                     (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
 421                                 alphaTy, betaTy, gammaTy] gammaTy))
 422                   (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template))
 423   where
 424     -- Annotations: w: name, g: gran. info, s: size info, p: par info  -- HWL
 425     [w, g, s, p, v, x, y, z]
 426       = mkTemplateLocals [
 427         {-w-} intPrimTy,
 428         {-g-} intPrimTy,
 429         {-s-} intPrimTy,
 430         {-p-} intPrimTy,
 431         {-v-} alphaTy,
 432         {-x-} betaTy,
 433         {-y-} gammaTy,
 434         {-z-} intPrimTy
 435         ]
 436
 437     parAtForNow_template
 438       = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
 439                 Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
 440                   PrimAlts
 441                     [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
 442                     (BindDefault z (Var y))))
 443
 444 -- copyable and noFollow are currently merely hooks: they are translated into
 445 -- calls to the macros COPYABLE and NOFOLLOW                            -- HWL
 446
 447 copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
 448                   (mkSigmaTy [alphaTyVar] []
 449                     alphaTy)
 450                   (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template))
 451   where
 452     -- Annotations: x: closure that's tagged to by copyable
 453     [x, z]
 454       = mkTemplateLocals [
 455         {-x-} alphaTy,
 456         {-z-} alphaTy
 457         ]
 458
 459     copyable_template
 460       = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
 461
 462 noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
 463                   (mkSigmaTy [alphaTyVar] []
 464                     alphaTy)
 465                   (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template))
 466   where
 467     -- Annotations: x: closure that's tagged to not follow
 468     [x, z]
 469       = mkTemplateLocals [
 470         {-x-} alphaTy,
 471         {-z-} alphaTy
 472         ]
 473
 474     noFollow_template
 475       = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
 476 -}
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 @runST@ has a non-Haskell-able type:
 486 \begin{verbatim}
 487 -- runST :: forall a. (forall s. _ST s a) -> a
 488 -- which is to say ::
 489 --           forall a. (forall s. (_State s -> (a, _State s))) -> a
 490
 491 runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
 492                (r :: a, wild :: _State _RealWorld) -> r
 493 \end{verbatim}
 494
 495 We unfold always, just for simplicity:
 496 \begin{code}
 497 runSTId
 498   = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info
 499   where
 500     s_tv = betaTyVar
 501     s    = betaTy
 502
 503     st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
 504
 505     run_ST_ty
 506       = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
 507             -- NB: rank-2 polymorphism! (forall inside the st_ty...)
 508
 509     id_info
 510       = noIdInfo
 511         `addArityInfo` exactArity 1
 512         `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
 513         `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
 514         -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template)
 515         -- see example below
 516 {- OUT:
 517     [m, t, r, wild]
 518       = mkTemplateLocals [
 519         {-m-} st_ty alphaTy,
 520         {-t-} realWorldStateTy,
 521         {-r-} alphaTy,
 522         {-_-} realWorldStateTy
 523         ]
 524
 525     run_ST_template
 526       = mkLam [alphaTyVar] [m] (
 527             Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
 528               Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
 529                 AlgAlts
 530                   [(pairDataCon, [r, wild], Var r)]
 531                   NoDefault)))
 532 -}
 533 \end{code}
 534
 535 SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
 536 \begin{verbatim}
 537 f x =
 538   runST ( \ s -> let
 539                     (a, s')  = newArray# 100 [] s
 540                     (_, s'') = fill_in_array_or_something a x s'
 541                   in
 542                   freezeArray# a s'' )
 543 \end{verbatim}
 544 If we inline @runST@, we'll get:
 545 \begin{verbatim}
 546 f x = let
 547         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 548         (_, s'') = fill_in_array_or_something a x s'
 549       in
 550       freezeArray# a s''
 551 \end{verbatim}
 552 And now the @newArray#@ binding can be floated to become a CAF, which
 553 is totally and utterly wrong:
 554 \begin{verbatim}
 555 f = let
 556     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 557     in
 558     \ x ->
 559         let (_, s'') = fill_in_array_or_something a x s' in
 560         freezeArray# a s''
 561 \end{verbatim}
 562 All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 563
 564 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 565 nasty as-is, change it back to a literal (@Literal@).
 566 \begin{code}
 567 realWorldPrimId
 568   = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
 569         realWorldStatePrimTy
 570         noIdInfo
 571 \end{code}
 572
 573 \begin{code}
 574 voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
 575 \end{code}
 576
 577 %************************************************************************
 578 %*                                                                      *
 579 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 buildId
 585   = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
 586         ((((noIdInfo
 587                 {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
 588                 `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
 589                 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
 590                 `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 591         -- cheating, but since _build never actually exists ...
 592   where
 593     -- The type of this strange object is:
 594     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 595
 596     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 597         where
 598             build_ty = mkSigmaTy [betaTyVar] []
 599                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 600 \end{code}
 601
 602 @mkBuild@ is sugar for building a build!
 603
 604 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 605 @ty@ is the type of the list.
 606 @tv@ is always a new type variable.
 607 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 608         c :: a -> b -> b
 609         n :: b
 610         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 611 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 612 @e@ is the object right inside the @build@
 613
 614 \begin{code}
 615 mkBuild :: Type
 616         -> TyVar
 617         -> Id
 618         -> Id
 619         -> Id
 620         -> CoreExpr -- template
 621         -> CoreExpr -- template
 622
 623 mkBuild ty tv c n g expr
 624   = Let (NonRec g (mkLam [tv] [c,n] expr))
 625         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 626 \end{code}
 627
 628 \begin{code}
 629 augmentId
 630   = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
 631         (((noIdInfo
 632                 {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
 633                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 634                 `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 635         -- cheating, but since _augment never actually exists ...
 636   where
 637     -- The type of this strange object is:
 638     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 639
 640     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 641         where
 642             aug_ty = mkSigmaTy [betaTyVar] []
 643                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 644 \end{code}
 645
 646 \begin{code}
 647 foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
 648                  foldrTy idInfo
 649   where
 650         foldrTy =
 651           mkSigmaTy [alphaTyVar, betaTyVar] []
 652                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 653
 654         idInfo = (((((noIdInfo
 655                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
 656                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 657                         `addArityInfo` exactArity 3)
 658                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 659                         `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 660
 661 foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
 662                  foldlTy idInfo
 663   where
 664         foldlTy =
 665           mkSigmaTy [alphaTyVar, betaTyVar] []
 666                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 667
 668         idInfo = (((((noIdInfo
 669                         {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
 670                         `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 671                         `addArityInfo` exactArity 3)
 672                         `addUpdateInfo` mkUpdateInfo [2,2,1])
 673                         `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 674
 675 -- A bit of magic goes no here. We translate appendId into ++,
 676 -- you have to be carefull when you actually compile append:
 677 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 678 --               {- unfold augment -}
 679 --               = foldr (:) ys xs
 680 --               {- fold foldr to append -}
 681 --               = ys `appendId` xs
 682 --               = ys ++ xs             -- ugg!
 683 -- *BUT* you want (++) and not _append in your interfaces.
 684 --
 685 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 686 -- the prelude.
 687 --
 688 {- OLD: doesn't apply with 1.3
 689 appendId
 690   = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
 691   where
 692     appendTy =
 693       (mkSigmaTy [alphaTyVar] []
 694             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 695     idInfo = (((noIdInfo
 696                 `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 697                 `addArityInfo` exactArity 2)
 698                 `addUpdateInfo` mkUpdateInfo [1,2])
 699 -}
 700 \end{code}
 701
 702 %************************************************************************
 703 %*                                                                      *
 704 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 The specialisations which exist for the builtin values must be recorded in
 709 their IdInfos.
 710
 711 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 712       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 713
 714 HACK: We currently use the same unique for the specialised Ids.
 715
 716 The list @specing_types@ determines the types for which specialised
 717 versions are created. Note: This should correspond with the
 718 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 719
 720 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 721
 722 \begin{code}
 723 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
 724 pcGenerateSpecs key id info ty
 725   = nullSpecEnv
 726
 727 {- LATER:
 728
 729 pc_gen_specs True key id info ty
 730
 731 pc_gen_specs is_id key id info ty
 732  = mkSpecEnv spec_infos
 733  where
 734    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 735                       spec_id = if is_id
 736                                 then mkSpecId key {- HACK WARNING: same unique! -}
 737                                               id spec_tys spec_ty info
 738                                 else panic "SpecData:SpecInfo:SpecId"
 739                   in
 740                   SpecInfo spec_tys (length ctxts) spec_id
 741                 | spec_tys <- specialisations ]
 742
 743    (tyvars, ctxts, _) = splitSigmaTy ty
 744    no_tyvars          = length tyvars
 745
 746    specialisations    = if no_tyvars == 0
 747                         then []
 748                         else tail (cross_product no_tyvars specing_types)
 749
 750                         -- N.B. tail removes fully polymorphic specialisation
 751
 752 cross_product 0 tys = []
 753 cross_product 1 tys = map (:[]) tys
 754 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 755
 756
 757 specing_types = [Nothing,
 758                  Just charPrimTy,
 759                  Just doublePrimTy,
 760                  Just intPrimTy ]
 761 -}
 762 \end{code}