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