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 )
  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_CORE SLIT("__integer0")  integerTy noIdInfo
 168 integerPlusOneId
 169   = pcMiscPrelId integerPlusOneIdKey  pRELUDE_CORE SLIT("__integer1")  integerTy noIdInfo
 170 integerPlusTwoId
 171   = pcMiscPrelId integerPlusTwoIdKey  pRELUDE_CORE SLIT("__integer2")  integerTy noIdInfo
 172 integerMinusOneId
 173   = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE 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 \begin{code}
 278 #ifdef GRAN
 279
 280 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
 281                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 282                     (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
 283                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
 284   where
 285     [w, x, y, z]
 286       = mkTemplateLocals [
 287         {-w-} intPrimTy,
 288         {-x-} alphaTy,
 289         {-y-} betaTy,
 290         {-z-} betaTy
 291         ]
 292
 293     parLocal_template
 294       = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
 295                 Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
 296                   AlgAlts
 297                     [(liftDataCon, [z], Var z)]
 298                     (NoDefault)))
 299
 300 parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
 301                   (mkSigmaTy [alphaTyVar, betaTyVar] []
 302                     (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
 303                   (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
 304   where
 305     [w, x, y, z]
 306       = mkTemplateLocals [
 307         {-w-} intPrimTy,
 308         {-x-} alphaTy,
 309         {-y-} betaTy,
 310         {-z-} betaTy
 311         ]
 312
 313     parGlobal_template
 314       = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
 315                 Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
 316                   AlgAlts
 317                     [(liftDataCon, [z], Var z)]
 318                     (NoDefault)))
 319
 320 #endif {-GRAN-}
 321 \end{code}
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 map             :: (a -> b) -> [a] -> [b]
 330         -- this is up in the here-because-of-unfolding list
 331
 332 --??showChar    :: Char -> ShowS
 333 showSpace       :: ShowS        -- non-std: == "showChar ' '"
 334 showString      :: String -> ShowS
 335 showParen       :: Bool -> ShowS -> ShowS
 336
 337 (++)            :: [a] -> [a] -> [a]
 338 readParen       :: Bool -> ReadS a -> ReadS a
 339 lex             :: ReadS String
 340
 341 %************************************************************************
 342 %*                                                                      *
 343 \subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
 344 %*                                                                      *
 345 %************************************************************************
 346
 347 I don't think this is available to the user; it's used in the
 348 simplifier (WDP 94/06).
 349 \begin{code}
 350 voidPrimId
 351   = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
 352         voidPrimTy noIdInfo
 353 \end{code}
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 @_runST@ has a non-Haskell-able type:
 362 \begin{verbatim}
 363 -- _runST :: forall a. (forall s. _ST s a) -> a
 364 -- which is to say ::
 365 --           forall a. (forall s. (_State s -> (a, _State s))) -> a
 366
 367 _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
 368                (r :: a, wild :: _State _RealWorld) -> r
 369 \end{verbatim}
 370 We unfold always, just for simplicity:
 371 \begin{code}
 372 runSTId
 373   = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
 374   where
 375     s_tv = betaTyVar
 376     s    = betaTy
 377
 378     st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
 379
 380     run_ST_ty
 381       = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
 382             -- NB: rank-2 polymorphism! (forall inside the st_ty...)
 383
 384     id_info
 385       = noIdInfo
 386         `addInfo` mkArityInfo 1
 387         `addInfo` mkStrictnessInfo [WwStrict] Nothing
 388         `addInfo` mkArgUsageInfo [ArgUsage 1]
 389         -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
 390         -- see example below
 391 {- OUT:
 392     [m, t, r, wild]
 393       = mkTemplateLocals [
 394         {-m-} st_ty alphaTy,
 395         {-t-} realWorldStateTy,
 396         {-r-} alphaTy,
 397         {-_-} realWorldStateTy
 398         ]
 399
 400     run_ST_template
 401       = mkLam [alphaTyVar] [m] (
 402             Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
 403               Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
 404                 AlgAlts
 405                   [(mkTupleCon 2, [r, wild], Var r)]
 406                   NoDefault)))
 407 -}
 408 \end{code}
 409
 410 SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
 411 \begin{verbatim}
 412 f x =
 413   _runST ( \ s -> let
 414                     (a, s')  = newArray# 100 [] s
 415                     (_, s'') = fill_in_array_or_something a x s'
 416                   in
 417                   freezeArray# a s'' )
 418 \end{verbatim}
 419 If we inline @_runST@, we'll get:
 420 \begin{verbatim}
 421 f x = let
 422         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 423         (_, s'') = fill_in_array_or_something a x s'
 424       in
 425       freezeArray# a s''
 426 \end{verbatim}
 427 And now the @newArray#@ binding can be floated to become a CAF, which
 428 is totally and utterly wrong:
 429 \begin{verbatim}
 430 f = let
 431     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 432     in
 433     \ x ->
 434         let (_, s'') = fill_in_array_or_something a x s' in
 435         freezeArray# a s''
 436 \end{verbatim}
 437 All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
 438
 439 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 440 nasty as-is, change it back to a literal (@Literal@).
 441 \begin{code}
 442 realWorldPrimId
 443   = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
 444         realWorldStatePrimTy
 445         noIdInfo
 446 \end{code}
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 buildId
 456   = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
 457         ((((noIdInfo
 458                 {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
 459                 `addInfo` mkStrictnessInfo [WwStrict] Nothing)
 460                 `addInfo` mkArgUsageInfo [ArgUsage 2])
 461                 `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
 462         -- cheating, but since _build never actually exists ...
 463   where
 464     -- The type of this strange object is:
 465     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
 466
 467     buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
 468         where
 469             build_ty = mkSigmaTy [betaTyVar] []
 470                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 471 \end{code}
 472
 473 @mkBuild@ is sugar for building a build!
 474
 475 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 476 @ty@ is the type of the list.
 477 @tv@ is always a new type variable.
 478 @c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
 479         c :: a -> b -> b
 480         n :: b
 481         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 482 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 483 @e@ is the object right inside the @build@
 484
 485 \begin{code}
 486 mkBuild :: Type
 487         -> TyVar
 488         -> Id
 489         -> Id
 490         -> Id
 491         -> CoreExpr -- template
 492         -> CoreExpr -- template
 493
 494 mkBuild ty tv c n g expr
 495   = Let (NonRec g (mkLam [tv] [c,n] expr))
 496         (App (mkTyApp (Var buildId) [ty]) (VarArg g))
 497 \end{code}
 498
 499 \begin{code}
 500 augmentId
 501   = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
 502         (((noIdInfo
 503                 {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
 504                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 505                 `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
 506         -- cheating, but since _augment never actually exists ...
 507   where
 508     -- The type of this strange object is:
 509     --  \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
 510
 511     augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
 512         where
 513             aug_ty = mkSigmaTy [betaTyVar] []
 514                         (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
 515 \end{code}
 516
 517 \begin{code}
 518 foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
 519                  foldrTy idInfo
 520   where
 521         foldrTy =
 522           mkSigmaTy [alphaTyVar, betaTyVar] []
 523                 (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
 524
 525         idInfo = (((((noIdInfo
 526                         {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
 527                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 528                         `addInfo` mkArityInfo 3)
 529                         `addInfo` mkUpdateInfo [2,2,1])
 530                         `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
 531
 532 foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
 533                  foldlTy idInfo
 534   where
 535         foldlTy =
 536           mkSigmaTy [alphaTyVar, betaTyVar] []
 537                 (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
 538
 539         idInfo = (((((noIdInfo
 540                         {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
 541                         `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
 542                         `addInfo` mkArityInfo 3)
 543                         `addInfo` mkUpdateInfo [2,2,1])
 544                         `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
 545
 546 -- A bit of magic goes no here. We translate appendId into ++,
 547 -- you have to be carefull when you actually compile append:
 548 --      xs ++ ys = augment (\ c n -> foldr c n xs) ys
 549 --               {- unfold augment -}
 550 --               = foldr (:) ys xs
 551 --               {- fold foldr to append -}
 552 --               = ys `appendId` xs
 553 --               = ys ++ xs             -- ugg!
 554 -- *BUT* you want (++) and not _append in your interfaces.
 555 --
 556 -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
 557 -- the prelude.
 558 --
 559
 560 appendId
 561   = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
 562   where
 563     appendTy =
 564       (mkSigmaTy [alphaTyVar] []
 565             (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
 566     idInfo = (((noIdInfo
 567                 `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
 568                 `addInfo` mkArityInfo 2)
 569                 `addInfo` mkUpdateInfo [1,2])
 570 \end{code}
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection[PrelUtils-specialisations]{Specialisations for builtin values}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 The specialisations which exist for the builtin values must be recorded in
 579 their IdInfos.
 580
 581 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
 582       TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
 583
 584 HACK: We currently use the same unique for the specialised Ids.
 585
 586 The list @specing_types@ determines the types for which specialised
 587 versions are created. Note: This should correspond with the
 588 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
 589
 590 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
 591
 592 \begin{code}
 593 pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
 594 pcGenerateSpecs key id info ty
 595   = nullSpecEnv
 596
 597 {- LATER:
 598
 599 pc_gen_specs True key id info ty
 600
 601 pc_gen_specs is_id key id info ty
 602  = mkSpecEnv spec_infos
 603  where
 604    spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
 605                       spec_id = if is_id
 606                                 then mkSpecId key {- HACK WARNING: same unique! -}
 607                                               id spec_tys spec_ty info
 608                                 else panic "SpecData:SpecInfo:SpecId"
 609                   in
 610                   SpecInfo spec_tys (length ctxts) spec_id
 611                 | spec_tys <- specialisations ]
 612
 613    (tyvars, ctxts, _) = splitSigmaTy ty
 614    no_tyvars          = length tyvars
 615
 616    specialisations    = if no_tyvars == 0
 617                         then []
 618                         else tail (cross_product no_tyvars specing_types)
 619
 620                         -- N.B. tail removes fully polymorphic specialisation
 621
 622 cross_product 0 tys = []
 623 cross_product 1 tys = map (:[]) tys
 624 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 625
 626
 627 specing_types = [Nothing,
 628                  Just charPrimTy,
 629                  Just doublePrimTy,
 630                  Just intPrimTy ]
 631 -}
 632 \end{code}