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(..) )
  13 import Id               ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
  14 IMPORT_DELOOPER(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            ( openAlphaTyVar, 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 [openAlphaTyVar] [] (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 \begin{code}
 489 voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo
 490 \end{code}
 491
 492 %************************************************************************
 493 %*                                                                      *
 494 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 @_runST@ has a non-Haskell-able type:
 499 \begin{verbatim}
 500 -- _runST :: forall a. (forall s. _ST s a) -> a
 501 -- which is to say ::
 502 --           forall a. (forall s. (_State s -> (a, _State s))) -> a
 503
 504 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
 505                (r :: a, wild :: _State _RealWorld) -> r
 506 \end{verbatim}
 507 We unfold always, just for simplicity:
 508 \begin{code}
 509 runSTId
 510   = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
 511   where
 512     s_tv = betaTyVar
 513     s    = betaTy
 514
 515     st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
 516
 517     run_ST_ty
 518       = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
 519             -- NB: rank-2 polymorphism! (forall inside the st_ty...)
 520
 521     id_info
 522       = noIdInfo
 523         `addInfo` mkArityInfo 1
 524         `addInfo` mkStrictnessInfo [WwStrict] Nothing
 525         `addInfo` mkArgUsageInfo [ArgUsage 1]
 526         -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
 527         -- see example below
 528 {- OUT:
 529     [m, t, r, wild]
 530       = mkTemplateLocals [
 531         {-m-} st_ty alphaTy,
 532         {-t-} realWorldStateTy,
 533         {-r-} alphaTy,
 534         {-_-} realWorldStateTy
 535         ]
 536
 537     run_ST_template
 538       = mkLam [alphaTyVar] [m] (
 539             Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
 540               Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
 541                 AlgAlts
 542                   [(mkTupleCon 2, [r, wild], Var r)]
 543                   NoDefault)))
 544 -}
 545 \end{code}
 546
 547 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
 548 \begin{verbatim}
 549 f x =
 550   _runST ( \ s -> let
 551                     (a, s')  = newArray# 100 [] s
 552                     (_, s'') = fill_in_array_or_something a x s'
 553                   in
 554                   freezeArray# a s'' )
 555 \end{verbatim}
 556 If we inline @_runST@, we'll get:
 557 \begin{verbatim}
 558 f x = let
 559         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 560         (_, s'') = fill_in_array_or_something a x s'
 561       in
 562       freezeArray# a s''
 563 \end{verbatim}
 564 And now the @newArray#@ binding can be floated to become a CAF, which
 565 is totally and utterly wrong:
 566 \begin{verbatim}
 567 f = let
 568     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 569     in
 570     \ x ->
 571         let (_, s'') = fill_in_array_or_something a x s' in
 572         freezeArray# a s''
 573 \end{verbatim}
 574 All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 575
 576 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 577 nasty as-is, change it back to a literal (@Literal@).
 578 \begin{code}
 579 realWorldPrimId
 580   = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
 581         realWorldStatePrimTy
 582         noIdInfo
 583 \end{code}
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 \begin{code}
 592 buildId
 593   = pcMiscPrelId buildIdKey pRELUDE_BUILTIN SLIT("_build") buildTy
 594         ((((noIdInfo
 595                 {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
 596                 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
 597                 `addInfo` mkArgUsageInfo [ArgUsage 2])
 598                 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 599         -- cheating, but since _build never actually exists ...
 600   where
 601     -- The type of this strange object is:
 602     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 603
 604     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 605         where
 606             build_ty = mkSigmaTy [betaTyVar] []
 607                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 608 \end{code}
 609
 610 @mkBuild@ is sugar for building a build!
 611
 612 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 613 @ty@ is the type of the list.
 614 @tv@ is always a new type variable.
 615 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 616         c :: a -> b -> b
 617         n :: b
 618         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 619 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 620 @e@ is the object right inside the @build@
 621
 622 \begin{code}
 623 mkBuild :: Type
 624         -> TyVar
 625         -> Id
 626         -> Id
 627         -> Id
 628         -> CoreExpr -- template
 629         -> CoreExpr -- template
 630
 631 mkBuild ty tv c n g expr
 632   = Let (NonRec g (mkLam [tv] [c,n] expr))
 633         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 634 \end{code}
 635
 636 \begin{code}
 637 augmentId
 638   = pcMiscPrelId augmentIdKey pRELUDE_BUILTIN SLIT("_augment") augmentTy
 639         (((noIdInfo
 640                 {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
 641                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 642                 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 643         -- cheating, but since _augment never actually exists ...
 644   where
 645     -- The type of this strange object is:
 646     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 647
 648     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 649         where
 650             aug_ty = mkSigmaTy [betaTyVar] []
 651                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 652 \end{code}
 653
 654 \begin{code}
 655 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
 656                  foldrTy idInfo
 657   where
 658         foldrTy =
 659           mkSigmaTy [alphaTyVar, betaTyVar] []
 660                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 661
 662         idInfo = (((((noIdInfo
 663                         {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
 664                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 665                         `addInfo` mkArityInfo 3)
 666                         `addInfo` mkUpdateInfo [2,2,1])
 667                         `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 668
 669 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
 670                  foldlTy idInfo
 671   where
 672         foldlTy =
 673           mkSigmaTy [alphaTyVar, betaTyVar] []
 674                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 675
 676         idInfo = (((((noIdInfo
 677                         {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
 678                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 679                         `addInfo` mkArityInfo 3)
 680                         `addInfo` mkUpdateInfo [2,2,1])
 681                         `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 682
 683 -- A bit of magic goes no here. We translate appendId into ++,
 684 -- you have to be carefull when you actually compile append:
 685 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 686 --               {- unfold augment -}
 687 --               = foldr (:) ys xs
 688 --               {- fold foldr to append -}
 689 --               = ys `appendId` xs
 690 --               = ys ++ xs             -- ugg!
 691 -- *BUT* you want (++) and not _append in your interfaces.
 692 --
 693 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 694 -- the prelude.
 695 --
 696
 697 appendId
 698   = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
 699   where
 700     appendTy =
 701       (mkSigmaTy [alphaTyVar] []
 702             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 703     idInfo = (((noIdInfo
 704                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 705                 `addInfo` mkArityInfo 2)
 706                 `addInfo` mkUpdateInfo [1,2])
 707 \end{code}
 708
 709 %************************************************************************
 710 %*                                                                      *
 711 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 712 %*                                                                      *
 713 %************************************************************************
 714
 715 The specialisations which exist for the builtin values must be recorded in
 716 their IdInfos.
 717
 718 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 719       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 720
 721 HACK: We currently use the same unique for the specialised Ids.
 722
 723 The list @specing_types@ determines the types for which specialised
 724 versions are created. Note: This should correspond with the
 725 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 726
 727 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 728
 729 \begin{code}
 730 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
 731 pcGenerateSpecs key id info ty
 732   = nullSpecEnv
 733
 734 {- LATER:
 735
 736 pc_gen_specs True key id info ty
 737
 738 pc_gen_specs is_id key id info ty
 739  = mkSpecEnv spec_infos
 740  where
 741    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 742                       spec_id = if is_id
 743                                 then mkSpecId key {- HACK WARNING: same unique! -}
 744                                               id spec_tys spec_ty info
 745                                 else panic "SpecData:SpecInfo:SpecId"
 746                   in
 747                   SpecInfo spec_tys (length ctxts) spec_id
 748                 | spec_tys <- specialisations ]
 749
 750    (tyvars, ctxts, _) = splitSigmaTy ty
 751    no_tyvars          = length tyvars
 752
 753    specialisations    = if no_tyvars == 0
 754                         then []
 755                         else tail (cross_product no_tyvars specing_types)
 756
 757                         -- N.B. tail removes fully polymorphic specialisation
 758
 759 cross_product 0 tys = []
 760 cross_product 1 tys = map (:[]) tys
 761 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 762
 763
 764 specing_types = [Nothing,
 765                  Just charPrimTy,
 766                  Just doublePrimTy,
 767                  Just intPrimTy ]
 768 -}
 769 \end{code}