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