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