ghc/compiler/basicTypes/IdInfo.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
   5
   6 (And a pretty good illustration of quite a few things wrong with
   7 Haskell. [WDP 94/11])
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module IdInfo (
  13         IdInfo,         -- abstract
  14         noIdInfo,
  15         boringIdInfo,
  16         ppIdInfo,
  17         applySubstToIdInfo, apply_to_IdInfo,    -- not for general use, please
  18
  19         OptIdInfo(..),  -- class; for convenience only, really
  20         -- all the *Infos herein are instances of it
  21
  22         -- component "id infos"; also abstract:
  23         ArityInfo,
  24         mkArityInfo, unknownArity, arityMaybe,
  25
  26         DemandInfo,
  27         mkDemandInfo,
  28         willBeDemanded,
  29
  30         SpecEnv, SpecInfo(..),
  31         nullSpecEnv, mkSpecEnv, addOneToSpecEnv,
  32         lookupSpecId, lookupSpecEnv, lookupConstMethodId,
  33
  34         SrcLoc,
  35         getSrcLocIdInfo,
  36
  37         StrictnessInfo(..), -- non-abstract
  38         Demand(..),         -- non-abstract
  39         wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
  40 --UNUSED: isStrict, absentArg,
  41         indicatesWorker, nonAbsentArgs,
  42         mkStrictnessInfo, mkBottomStrictnessInfo,
  43         getWrapperArgTypeCategories,
  44         getWorkerId,
  45         workerExists,
  46         bottomIsGuaranteed,
  47
  48         UnfoldingDetails(..),   -- non-abstract! re-exported
  49         UnfoldingGuidance(..),  -- non-abstract; ditto
  50         mkUnfolding,
  51         iWantToBeINLINEd, mkMagicUnfolding,
  52         noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
  53
  54         UpdateInfo,
  55         mkUpdateInfo,
  56         UpdateSpec(..),
  57         updateInfoMaybe,
  58
  59         DeforestInfo(..),
  60
  61         ArgUsageInfo,
  62         ArgUsage(..),
  63         ArgUsageType(..),
  64         mkArgUsageInfo,
  65         getArgUsage,
  66
  67         FBTypeInfo,
  68         FBType(..),
  69         FBConsum(..),
  70         FBProd(..),
  71         mkFBTypeInfo,
  72         getFBType,
  73
  74         -- and to make the interface self-sufficient...
  75         Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id,
  76         IdEnv(..), UniqFM, Unique, IdVal, FormSummary,
  77         InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..),
  78         SimplifiableBinder(..), SimplifiableCoreExpr(..),
  79         PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..),
  80         PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..),
  81         OutId(..), Subst
  82
  83         -- and to make sure pragmas work...
  84         IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc)
  85     ) where
  86
  87 IMPORT_Trace            -- ToDo: rm (debugging)
  88
  89 import AbsPrel          ( mkFunTy, nilDataCon{-HACK-}
  90                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  91                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  92                         )
  93 import AbsUniType
  94 import Bag              ( emptyBag, Bag )
  95 import CmdLineOpts      ( GlobalSwitch(..) )
  96 import Id               ( getIdUniType, getIdInfo,
  97                           getDataConSig, getInstantiatedDataConSig,
  98                           externallyVisibleId, isDataCon,
  99                           unfoldingUnfriendlyId, isWorkerId,
 100                           isWrapperId, DataCon(..)
 101                           IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId)
 102                           IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
 103                         )
 104 import IdEnv            -- ( nullIdEnv, lookupIdEnv )
 105 import Inst             ( apply_to_Inst, applySubstToInst, Inst )
 106 import MagicUFs
 107 import Maybes
 108 import Outputable
 109 import PlainCore
 110 import Pretty
 111 import SimplEnv         -- UnfoldingDetails(..), UnfoldingGuidance(..)
 112 import SrcLoc
 113 import Subst            ( applySubstToTy, Subst )
 114 import OccurAnal        ( occurAnalyseGlobalExpr )
 115 import TaggedCore       -- SimplifiableCore* ...
 116 import Unique
 117 import Util
 118 import WwLib            ( mAX_WORKER_ARGS )
 119 \end{code}
 120
 121 An @IdInfo@ gives {\em optional} information about an @Id@.  If
 122 present it never lies, but it may not be present, in which case there
 123 is always a conservative assumption which can be made.
 124
 125 Two @Id@s may have different info even though they have the same
 126 @Unique@ (and are hence the same @Id@); for example, one might lack
 127 the properties attached to the other.
 128
 129 The @IdInfo@ gives information about the value, or definition, of the
 130 @Id@.  It does {\em not} contain information about the @Id@'s usage
 131 (except for @DemandInfo@? ToDo).
 132
 133 \begin{code}
 134 data IdInfo
 135   = IdInfo
 136         ArityInfo               -- Its arity
 137
 138         DemandInfo              -- Whether or not it is definitely
 139                                 -- demanded
 140
 141         SpecEnv                 -- Specialisations of this function which exist
 142
 143         StrictnessInfo          -- Strictness properties, notably
 144                                 -- how to conjure up "worker" functions
 145
 146         UnfoldingDetails        -- Its unfolding; for locally-defined
 147                                 -- things, this can *only* be NoUnfoldingDetails
 148                                 -- or IWantToBeINLINEd (i.e., INLINE pragma).
 149
 150         UpdateInfo              -- Which args should be updated
 151
 152         DeforestInfo            -- Whether its definition should be
 153                                 -- unfolded during deforestation
 154
 155         ArgUsageInfo            -- how this Id uses its arguments
 156
 157         FBTypeInfo              -- the Foldr/Build W/W property of this function.
 158
 159         SrcLoc                  -- Source location of definition
 160
 161         -- ToDo: SrcLoc is in FullNames too (could rm?)  but it
 162         -- is needed here too for things like ConstMethodIds and the
 163         -- like, which don't have full-names of their own Mind you,
 164         -- perhaps the FullName for a constant method could give the
 165         -- class/type involved?
 166 \end{code}
 167
 168 \begin{code}
 169 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
 170                   noInfo noInfo noInfo noInfo mkUnknownSrcLoc
 171
 172 -- "boring" means: nothing to put an interface
 173 boringIdInfo (IdInfo UnknownArity
 174                      UnknownDemand
 175                      nullSpecEnv
 176                      strictness
 177                      unfolding
 178                      NoUpdateInfo
 179                      Don'tDeforest
 180                      _ {- arg_usage: currently no interface effect -}
 181                      _ {- no f/b w/w -}
 182                      _ {- src_loc: no effect on interfaces-})
 183                      |  boring_strictness strictness
 184                      && boring_unfolding unfolding
 185   = True
 186   where
 187     boring_strictness NoStrictnessInfo = True
 188     boring_strictness BottomGuaranteed = False
 189     boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
 190
 191     boring_unfolding NoUnfoldingDetails = True
 192     boring_unfolding _                  = False
 193
 194 boringIdInfo _ = False
 195
 196 pp_NONE = ppPStr SLIT("_N_")
 197 \end{code}
 198
 199 Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
 200 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 201 nasty loop, friends...)
 202 \begin{code}
 203 apply_to_IdInfo ty_fn
 204     (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
 205   = let
 206         new_spec = apply_spec spec
 207
 208         -- NOT a good idea:
 209         --   apply_strict strictness    `thenLft` \ new_strict ->
 210         --   apply_wrap wrap            `thenLft` \ new_wrap ->
 211     in
 212     IdInfo arity demand
 213            new_spec strictness unfold
 214            update deforest arg_usage fb_ww srcloc
 215   where
 216     apply_spec (SpecEnv is)
 217       = SpecEnv (map do_one is)
 218       where
 219         do_one (SpecInfo ty_maybes ds spec_id)
 220           = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
 221             SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
 222           where
 223             apply_to_maybe Nothing   = Nothing
 224             apply_to_maybe (Just ty) = Just (ty_fn ty)
 225
 226 {- NOT a good idea;
 227     apply_strict info@NoStrictnessInfo = returnLft info
 228     apply_strict BottomGuaranteed = ???
 229     apply_strict (StrictnessInfo wrap_arg_info id_maybe)
 230       = (case id_maybe of
 231            Nothing -> returnLft Nothing
 232            Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
 233                       returnLft (Just new_xx)
 234         ) `thenLft` \ new_id_maybe ->
 235         returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
 236 -}
 237 \end{code}
 238
 239 Variant of the same thing for the typechecker.
 240 \begin{code}
 241 applySubstToIdInfo s0
 242     (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
 243   = case (apply_spec s0 spec) of { (s1, new_spec) ->
 244     (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
 245   where
 246     apply_spec s0 (SpecEnv is)
 247       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
 248         (s1, SpecEnv new_is) }
 249       where
 250         do_one s0 (SpecInfo ty_maybes ds spec_id)
 251           = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
 252             (s1, SpecInfo new_maybes ds spec_id) }
 253           where
 254             apply_to_maybe s0 Nothing   = (s0, Nothing)
 255             apply_to_maybe s0 (Just ty)
 256               = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
 257                 (s1, Just new_ty) }
 258 \end{code}
 259
 260 \begin{code}
 261 ppIdInfo :: PprStyle
 262          -> Id          -- The Id for which we're printing this IdInfo
 263          -> Bool        -- True <=> print specialisations, please
 264          -> (Id -> Id)  -- to look up "better Ids" w/ better IdInfos;
 265          -> IdEnv UnfoldingDetails
 266                         -- inlining info for top-level fns in this module
 267          -> IdInfo      -- see MkIface notes
 268          -> Pretty
 269
 270 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 271     i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc)
 272   | boringIdInfo i
 273   = ppPStr SLIT("_NI_")
 274
 275   | otherwise
 276   = let
 277         stuff = ppCat [
 278                     -- order is important!:
 279                     ppInfo sty better_id_fn arity,
 280                     ppInfo sty better_id_fn update,
 281                     ppInfo sty better_id_fn deforest,
 282
 283                     pp_strictness sty (Just for_this_id)
 284                                   better_id_fn inline_env strictness,
 285
 286                     if bottomIsGuaranteed strictness
 287                     then pp_NONE
 288                     else pp_unfolding sty for_this_id inline_env unfold,
 289
 290                     if specs_please
 291                     then pp_specs sty (not (isDataCon for_this_id))
 292                                   better_id_fn inline_env specialise
 293                     else pp_NONE,
 294
 295                     -- DemandInfo needn't be printed since it has no effect on interfaces
 296                     ppInfo sty better_id_fn demand,
 297                     ppInfo sty better_id_fn fbtype
 298                 ]
 299     in
 300     case sty of
 301       PprInterface sw_chker ->  if sw_chker OmitInterfacePragmas
 302                                 then ppNil
 303                                 else stuff
 304       _                     ->  stuff
 305 \end{code}
 306
 307 \begin{code}
 308 {- OLD:
 309 pp_info_op :: String -> Pretty -- like pprNonOp
 310
 311 pp_info_op name
 312   = if isAvarop name || isAconop name
 313     then ppBesides [ppLparen, ppStr name, ppRparen]
 314     else ppStr name
 315 -}
 316 \end{code}
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 class OptIdInfo a where
 326     noInfo      :: a
 327     getInfo     :: IdInfo -> a
 328     addInfo     :: IdInfo -> a -> IdInfo
 329                 -- By default, "addInfo" will not overwrite
 330                 -- "info" with "non-info"; look at any instance
 331                 -- to see an example.
 332     ppInfo      :: PprStyle -> (Id -> Id) -> a -> Pretty
 333 \end{code}
 334
 335 %************************************************************************
 336 %*                                                                      *
 337 \subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
 338 %*                                                                      *
 339 %************************************************************************
 340
 341 Not used much, but...
 342 \begin{code}
 343 getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection[arity-IdInfo]{Arity info about an @Id@}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 data ArityInfo
 354   = UnknownArity        -- no idea
 355   | ArityExactly Int    -- arity is exactly this
 356 \end{code}
 357
 358 \begin{code}
 359 mkArityInfo  = ArityExactly
 360 unknownArity = UnknownArity
 361
 362 arityMaybe :: ArityInfo -> Maybe Int
 363
 364 arityMaybe UnknownArity     = Nothing
 365 arityMaybe (ArityExactly i) = Just i
 366 \end{code}
 367
 368 \begin{code}
 369 instance OptIdInfo ArityInfo where
 370     noInfo = UnknownArity
 371
 372     getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
 373
 374     addInfo id_info UnknownArity = id_info
 375     addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
 376
 377     ppInfo sty _ UnknownArity         = ifPprInterface sty pp_NONE
 378     ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
 379 \end{code}
 380
 381 %************************************************************************
 382 %*                                                                      *
 383 \subsection[demand-IdInfo]{Demand info about an @Id@}
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 Whether a value is certain to be demanded or not.  (This is the
 388 information that is computed by the ``front-end'' of the strictness
 389 analyser.)
 390
 391 This information is only used within a module, it is not exported
 392 (obviously).
 393
 394 \begin{code}
 395 data DemandInfo
 396   = UnknownDemand
 397   | DemandedAsPer Demand
 398 \end{code}
 399
 400 \begin{code}
 401 mkDemandInfo :: Demand -> DemandInfo
 402 mkDemandInfo demand = DemandedAsPer demand
 403
 404 willBeDemanded :: DemandInfo -> Bool
 405 willBeDemanded (DemandedAsPer demand) = isStrict demand
 406 willBeDemanded _                      = False
 407 \end{code}
 408
 409 \begin{code}
 410 instance OptIdInfo DemandInfo where
 411     noInfo = UnknownDemand
 412
 413     getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
 414
 415 {-      DELETED!  If this line is in, there is no way to
 416         nuke a DemandInfo, and we have to be able to do that
 417         when floating let-bindings around
 418     addInfo id_info UnknownDemand = id_info
 419 -}
 420     addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
 421
 422     ppInfo (PprInterface _) _ _       = ppNil
 423     ppInfo sty _ UnknownDemand        = ppStr "{-# L #-}"
 424     ppInfo sty _ (DemandedAsPer info)
 425       = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
 426 \end{code}
 427
 428 %************************************************************************
 429 %*                                                                      *
 430 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 431 %*                                                                      *
 432 %************************************************************************
 433
 434 The details of one specialisation, held in an @Id@'s
 435 @SpecEnv@ are as follows:
 436 \begin{code}
 437 data SpecInfo
 438   = SpecInfo    [Maybe UniType] -- Instance types; no free type variables in here
 439                 Int             -- No. of dictionaries to eat
 440                 Id              -- Specialised version
 441 \end{code}
 442
 443 For example, if \tr{f} has this @SpecInfo@:
 444 \begin{verbatim}
 445         SpecInfo [Just t1, Nothing, Just t3] 2 f'
 446 \end{verbatim}
 447 then
 448 \begin{verbatim}
 449         f t1 t2 t3 d1 d2  ===>  f t2
 450 \end{verbatim}
 451 The \tr{Nothings} identify type arguments in which the specialised
 452 version is polymorphic.
 453
 454 \begin{code}
 455 data SpecEnv = SpecEnv [SpecInfo]
 456
 457 mkSpecEnv = SpecEnv
 458 nullSpecEnv = SpecEnv []
 459 addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
 460
 461 lookupConstMethodId :: Id -> UniType -> Maybe Id
 462     -- slight variant on "lookupSpecEnv" below
 463
 464 lookupConstMethodId sel_id spec_ty
 465   = case (getInfo (getIdInfo sel_id)) of
 466       SpecEnv spec_infos -> firstJust (map try spec_infos)
 467   where
 468     try (SpecInfo (Just ty:nothings) _ const_meth_id)
 469       = ASSERT(all nothing_is_nothing nothings)
 470         case (cmpUniType True{-properly-} ty spec_ty) of
 471           EQ_ -> Just const_meth_id
 472           _   -> Nothing
 473
 474     nothing_is_nothing Nothing = True  -- debugging only
 475     nothing_is_nothing _       = panic "nothing_is_nothing!"
 476
 477 lookupSpecId :: Id              -- *un*specialised Id
 478              -> [Maybe UniType] -- types to which it is to be specialised
 479              -> Id              -- specialised Id
 480
 481 lookupSpecId unspec_id ty_maybes
 482   = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
 483
 484     case (firstJust (map try spec_infos)) of
 485       Just id -> id
 486       Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
 487     }
 488   where
 489     try (SpecInfo template_maybes _ id)
 490         | and (zipWith same template_maybes ty_maybes)
 491         && length template_maybes == length ty_maybes = Just id
 492         | otherwise                                   = Nothing
 493
 494     same Nothing    Nothing    = True
 495     same (Just ty1) (Just ty2) = ty1 == ty2
 496     same _          _          = False
 497
 498 lookupSpecEnv :: SpecEnv
 499               -> [UniType]
 500               -> Maybe (Id,
 501                         [UniType],
 502                         Int)
 503
 504 lookupSpecEnv (SpecEnv []) _ = Nothing  -- rather common case
 505
 506 lookupSpecEnv spec_env [] = Nothing     -- another common case
 507
 508         -- This can happen even if there is a non-empty spec_env, because
 509         -- of eta reduction.  For example, we might have a defn
 510         --
 511         --      f = /\a -> \d -> g a d
 512         -- which gets transformed to
 513         --      f = g
 514         --
 515         -- Now g isn't applied to any arguments
 516
 517 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
 518   = select_match spec_infos
 519   where
 520     select_match []             -- no matching spec_infos
 521       = Nothing
 522     select_match (SpecInfo ty_maybes toss spec_id : rest)
 523       = case (match ty_maybes spec_tys) of
 524           Nothing       -> select_match rest
 525           Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
 526
 527         -- Ambiguity can only arise as a result of specialisations with
 528         -- an explicit spec_id. The best match is deemed to be the match
 529         -- with least polymorphism i.e. has the least number of tys left.
 530         -- This is a non-critical approximation. The only type arguments
 531         -- where there may be some discretion is for non-overloaded boxed
 532         -- types. Unboxed types must be matched and we insist that we
 533         -- always specialise on overloaded types (and discard all the dicts).
 534
 535     select_next best _ toss []
 536       = case best of
 537             [match] -> Just match       -- Unique best match
 538             ambig   -> pprPanic "Ambiguous Specialisation:\n"
 539                                 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
 540                                            ppCat (ppStr "between spec ids:" :
 541                                                   map (ppr PprDebug) [id | (id, _, _) <- ambig]),
 542                                            pp_stuff])
 543
 544     select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
 545       = ASSERT(dnum == toss)
 546         case (match ty_maybes spec_tys) of
 547           Nothing       -> select_next best tnum dnum rest
 548           Just tys_left ->
 549              let tys_len = length tys_left in
 550              case _tagCmp tnum tys_len of
 551                _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest   -- better match
 552                _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
 553                _GT -> select_next best tnum dnum rest                           -- worse match
 554
 555
 556     match [{-out of templates-}] [] = Just []
 557
 558     match (Nothing:ty_maybes) (spec_ty:spec_tys)
 559       = case (isUnboxedDataType spec_ty) of
 560           True  -> Nothing      -- Can only match boxed type against
 561                                 -- type argument which has not been
 562                                 -- specialised on
 563           False -> case match ty_maybes spec_tys of
 564                      Nothing  -> Nothing
 565                      Just tys -> Just (spec_ty:tys)
 566
 567     match (Just ty:ty_maybes) (spec_ty:spec_tys)
 568       = case (cmpUniType True{-properly-} ty spec_ty) of
 569           EQ_   -> match ty_maybes spec_tys
 570           other -> Nothing
 571
 572     match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
 573                  -- This is a Real Problem
 574
 575     match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
 576                  -- Partial eta abstraction might make this happen;
 577                  -- meanwhile let's leave in the check
 578
 579     pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
 580 \end{code}
 581
 582
 583 \begin{code}
 584 instance OptIdInfo SpecEnv where
 585     noInfo = nullSpecEnv
 586
 587     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 588
 589     addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
 590         = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
 591         -- We *add* the new specialisation info rather than just replacing it
 592         -- so that we don't lose old specialisation details.
 593
 594     ppInfo sty better_id_fn spec_env
 595       = pp_specs sty True better_id_fn nullIdEnv spec_env
 596
 597 pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
 598 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
 599   = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
 600        ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
 601               ppInt numds,
 602               let
 603                  better_spec_id = better_id_fn spec_id
 604                  spec_id_info = getIdInfo better_spec_id
 605               in
 606               if not print_spec_ids || boringIdInfo spec_id_info then
 607                  ppNil
 608               else
 609                  ppCat [ppChar '{',
 610                         ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
 611                         ppChar '}']
 612              ]
 613        | (SpecInfo ty_maybes numds spec_id) <- specs ])
 614   where
 615     pp_the_list [p]    = p
 616     pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
 617
 618     pp_maybe Nothing  = ifPprInterface sty pp_NONE
 619     pp_maybe (Just t) = pprParendUniType sty t
 620 \end{code}
 621
 622 %************************************************************************
 623 %*                                                                      *
 624 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
 625 %*                                                                      *
 626 %************************************************************************
 627
 628 We specify the strictness of a function by giving information about
 629 each of the ``wrapper's'' arguments (see the description about
 630 worker/wrapper-style transformations in the PJ/Launchbury paper on
 631 unboxed types).
 632
 633 The list of @Demands@ specifies: (a)~the strictness properties
 634 of a function's arguments; (b)~the {\em existence} of a ``worker''
 635 version of the function; and (c)~the type signature of that worker (if
 636 it exists); i.e. its calling convention.
 637
 638 \begin{code}
 639 data StrictnessInfo
 640   = NoStrictnessInfo
 641
 642   | BottomGuaranteed    -- This Id guarantees never to return;
 643                         -- it is bottom regardless of its arguments.
 644                         -- Useful for "error" and other disguised
 645                         -- variants thereof.
 646
 647   | StrictnessInfo      [Demand]        -- the main stuff; see below.
 648                         (Maybe Id)      -- worker's Id, if applicable.
 649 \end{code}
 650
 651 This type is also actually used in the strictness analyser:
 652 \begin{code}
 653 data Demand
 654   = WwLazy              -- Argument is lazy as far as we know
 655         MaybeAbsent     -- (does not imply worker's existence [etc]).
 656                         -- If MaybeAbsent == True, then it is
 657                         -- *definitely* lazy.  (NB: Absence implies
 658                         -- a worker...)
 659
 660   | WwStrict            -- Argument is strict but that's all we know
 661                         -- (does not imply worker's existence or any
 662                         -- calling-convention magic)
 663
 664   | WwUnpack            -- Argument is strict & a single-constructor
 665         [Demand]        -- type; its constituent parts (whose StrictInfos
 666                         -- are in the list) should be passed
 667                         -- as arguments to the worker.
 668
 669   | WwPrim              -- Argument is of primitive type, therefore
 670                         -- strict; doesn't imply existence of a worker;
 671                         -- argument should be passed as is to worker.
 672
 673   | WwEnum              -- Argument is strict & an enumeration type;
 674                         -- an Int# representing the tag (start counting
 675                         -- at zero) should be passed to the worker.
 676   deriving (Eq, Ord)
 677       -- we need Eq/Ord to cross-chk update infos in interfaces
 678
 679 type MaybeAbsent = Bool -- True <=> not even used
 680
 681 -- versions that don't worry about Absence:
 682 wwLazy      = WwLazy      False
 683 wwStrict    = WwStrict
 684 wwUnpack xs = WwUnpack xs
 685 wwPrim      = WwPrim
 686 wwEnum      = WwEnum
 687 \end{code}
 688
 689 \begin{code}
 690 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
 691
 692 mkStrictnessInfo [] _    = NoStrictnessInfo
 693 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
 694
 695 mkBottomStrictnessInfo = BottomGuaranteed
 696
 697 bottomIsGuaranteed BottomGuaranteed = True
 698 bottomIsGuaranteed other            = False
 699
 700 getWrapperArgTypeCategories
 701         :: UniType              -- wrapper's type
 702         -> StrictnessInfo       -- strictness info about its args
 703         -> Maybe String
 704
 705 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 706 getWrapperArgTypeCategories _ BottomGuaranteed
 707   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 708 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 709
 710 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 711   = Just (mkWrapperArgTypeCategories ty arg_info)
 712
 713 workerExists :: StrictnessInfo -> Bool
 714 workerExists (StrictnessInfo _ (Just worker_id)) = True
 715 workerExists other                               = False
 716
 717 getWorkerId :: StrictnessInfo -> Id
 718
 719 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
 720 #ifdef DEBUG
 721 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
 722 #endif
 723 \end{code}
 724
 725 \begin{code}
 726 isStrict :: Demand -> Bool
 727
 728 isStrict WwStrict       = True
 729 isStrict (WwUnpack _)   = True
 730 isStrict WwPrim         = True
 731 isStrict WwEnum         = True
 732 isStrict _              = False
 733
 734 {- UNUSED:
 735 absentArg :: Demand -> Bool
 736
 737 absentArg (WwLazy absentp) = absentp
 738 absentArg other            = False
 739 -}
 740
 741 nonAbsentArgs :: [Demand] -> Int
 742
 743 nonAbsentArgs cmpts
 744   = foldr tick_non 0 cmpts
 745   where
 746     tick_non (WwLazy True) acc = acc
 747     tick_non other         acc = acc + 1
 748
 749 all_present_WwLazies :: [Demand] -> Bool
 750 all_present_WwLazies infos
 751   = and (map is_L infos)
 752   where
 753     is_L (WwLazy False) = True  -- False <=> "Absent" args do *not* count!
 754     is_L _              = False -- (as they imply a worker)
 755 \end{code}
 756
 757 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
 758 an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
 759 check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
 760 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
 761 in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
 762 or an Absent {\em that we accept}.
 763 \begin{code}
 764 indicatesWorker :: [Demand] -> Bool
 765
 766 indicatesWorker dems
 767   = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
 768   where
 769     fake_mk_ww _ [] = False
 770     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
 771     fake_mk_ww extra_args (WwUnpack cmpnts : dems)
 772       | extra_args_now > 0 = True -- we accepted an Unpack
 773       where
 774         extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
 775
 776     fake_mk_ww extra_args (_ : dems)
 777       = fake_mk_ww extra_args dems
 778 \end{code}
 779
 780 \begin{code}
 781 mkWrapperArgTypeCategories
 782         :: UniType              -- wrapper's type
 783         -> [Demand]     -- info about its arguments
 784         -> String               -- a string saying lots about the args
 785
 786 mkWrapperArgTypeCategories wrapper_ty wrap_info
 787   = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
 788     map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
 789     }
 790   where
 791     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 792     do_one (WwPrim, _) = 'P'
 793     do_one (WwEnum, _) = 'E'
 794     do_one (WwStrict, arg_ty_char) = arg_ty_char
 795     do_one (WwUnpack _, arg_ty_char)
 796       = if arg_ty_char `elem` "CIJFDTS"
 797         then toLower arg_ty_char
 798         else if arg_ty_char == '+' then 't'
 799         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 800     do_one (other_wrap_info, _) = '-'
 801 \end{code}
 802
 803 Whether a worker exists depends on whether the worker has an
 804 absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
 805
 806 If a @WwUnpack@ argument is for an {\em abstract} type (or one that
 807 will be abstract outside this module), which might happen for an
 808 imported function, then we can't (or don't want to...) unpack the arg
 809 as the worker requires.  Hence we have to give up altogether, and call
 810 the wrapper only; so under these circumstances we return \tr{False}.
 811
 812 \begin{code}
 813 instance Text Demand where
 814     readList str = read_em [{-acc-}] str
 815       where
 816         read_em acc []          = [(reverse acc, "")]
 817         -- lower case indicates absence...
 818         read_em acc ('L' : xs)  = read_em (WwLazy   False : acc) xs
 819         read_em acc ('A' : xs)  = read_em (WwLazy   True  : acc) xs
 820         read_em acc ('S' : xs)  = read_em (WwStrict : acc) xs
 821         read_em acc ('P' : xs)  = read_em (WwPrim : acc) xs
 822         read_em acc ('E' : xs)  = read_em (WwEnum : acc) xs
 823
 824         read_em acc (')' : xs)  = [(reverse acc, xs)]
 825         read_em acc ( 'U'  : '(' : xs)
 826           = case (read_em [] xs) of
 827               [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
 828               _ -> panic ("Text.Demand:"++str++"::"++xs)
 829
 830         read_em acc other = panic ("IdInfo.readem:"++other)
 831
 832     showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
 833       where
 834         show1 (WwLazy False) = "L"
 835         show1 (WwLazy True)  = "A"
 836         show1 WwStrict       = "S"
 837         show1 WwPrim         = "P"
 838         show1 WwEnum         = "E"
 839         show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
 840
 841 instance Outputable Demand where
 842     ppr sty si = ppStr (showList [si] "")
 843
 844 instance OptIdInfo StrictnessInfo where
 845     noInfo = NoStrictnessInfo
 846
 847     getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
 848
 849     addInfo id_info NoStrictnessInfo = id_info
 850     addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
 851
 852     ppInfo sty better_id_fn strictness_info
 853       = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
 854 \end{code}
 855
 856 We'll omit the worker info if the thing has an explicit unfolding
 857 already.
 858 \begin{code}
 859 pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
 860
 861 pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
 862
 863 pp_strictness sty for_this_id_maybe better_id_fn inline_env
 864     info@(StrictnessInfo wrapper_args wrkr_maybe)
 865   = let
 866         (have_wrkr, wrkr_id) = case wrkr_maybe of
 867                                  Nothing -> (False, panic "ppInfo(Strictness)")
 868                                  Just xx -> (True,  xx)
 869
 870         wrkr_to_print   = better_id_fn wrkr_id
 871         wrkr_info       = getIdInfo   wrkr_to_print
 872
 873         -- if we aren't going to be able to *read* the strictness info
 874         -- in TcPragmas, we need not even print it.
 875         wrapper_args_to_use
 876           = if not (indicatesWorker wrapper_args) then
 877                 wrapper_args -- no worker/wrappering in any case
 878             else
 879                 case for_this_id_maybe of
 880                   Nothing -> wrapper_args
 881                   Just id -> if externallyVisibleId id
 882                              && (unfoldingUnfriendlyId id || not have_wrkr) then
 883                                 -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) (
 884                                 map un_workerise wrapper_args
 885                                 -- )
 886                              else
 887                                 wrapper_args
 888
 889         id_is_worker
 890           = case for_this_id_maybe of
 891               Nothing -> False
 892               Just id -> isWorkerId id
 893
 894         am_printing_iface
 895           = case sty of
 896               PprInterface _ -> True
 897               _ -> False
 898
 899         pp_basic_info
 900           = ppBesides [ppStr "_S_ \"",
 901                 ppStr (showList wrapper_args_to_use ""), ppStr "\""]
 902
 903         pp_with_worker
 904           = ppBesides [ ppSP, ppChar '{',
 905                         ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
 906                         ppChar '}' ]
 907     in
 908     if all_present_WwLazies wrapper_args_to_use then -- too boring
 909         ifPprInterface sty pp_NONE
 910
 911     else if id_is_worker && am_printing_iface then
 912         pp_NONE -- we don't put worker strictness in interfaces
 913                 -- (it can be deduced)
 914
 915     else if not (indicatesWorker wrapper_args_to_use)
 916          || not have_wrkr
 917          || boringIdInfo wrkr_info then
 918         ppBeside pp_basic_info ppNil
 919     else
 920         ppBeside pp_basic_info pp_with_worker
 921   where
 922     un_workerise (WwLazy   _) = WwLazy False -- avoid absence
 923     un_workerise (WwUnpack _) = WwStrict
 924     un_workerise other        = other
 925 \end{code}
 926
 927 %************************************************************************
 928 %*                                                                      *
 929 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
 930 %*                                                                      *
 931 %************************************************************************
 932
 933 \begin{code}
 934 mkUnfolding      :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails
 935 iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
 936 mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails
 937
 938 mkUnfolding guide expr
 939   = GeneralForm False (mkFormSummary NoStrictnessInfo expr)
 940         (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
 941         guide
 942 \end{code}
 943
 944 \begin{code}
 945 iWantToBeINLINEd guide = IWantToBeINLINEd guide
 946
 947 mkMagicUnfolding tag  = MagicForm tag (mkMagicUnfoldingFun tag)
 948
 949 \end{code}
 950
 951 \begin{code}
 952 noInfo_UF = NoUnfoldingDetails
 953
 954 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
 955   = case unfolding of
 956       NoUnfoldingDetails             -> NoUnfoldingDetails
 957       GeneralForm _ _ _ BadUnfolding -> NoUnfoldingDetails
 958       unfold_ok                      -> unfold_ok
 959
 960 -- getInfo_UF ensures that any BadUnfoldings are never returned
 961 -- We had to delay the test required in TcPragmas until now due
 962 -- to strictness constraints in TcPragmas
 963
 964 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
 965 addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
 966
 967 \end{code}
 968
 969 \begin{code}
 970 pp_unfolding sty for_this_id inline_env uf_details
 971   = case (lookupIdEnv inline_env for_this_id) of
 972       Nothing -> pp uf_details
 973       Just dt -> pp dt
 974   where
 975     pp NoUnfoldingDetails = pp_NONE
 976
 977     pp (IWantToBeINLINEd guide) -- not in interfaces
 978       = if isWrapperId for_this_id
 979         then pp_NONE -- wrapper: don't complain or mutter
 980         else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE]
 981
 982     pp (MagicForm tag _)
 983       = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
 984
 985     pp (GeneralForm _ _ _ BadUnfolding) = pp_NONE
 986
 987     pp (GeneralForm _ _ template guide)
 988       = let
 989             untagged = unTagBinders template
 990         in
 991         if untagged `isWrapperFor` for_this_id
 992         then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
 993              pp_NONE
 994         else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
 995
 996 \end{code}
 997
 998 %************************************************************************
 999 %*                                                                      *
1000 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
1001 %*                                                                      *
1002 %************************************************************************
1003
1004 \begin{code}
1005 data UpdateInfo
1006   = NoUpdateInfo
1007   | SomeUpdateInfo UpdateSpec
1008   deriving (Eq, Ord)
1009       -- we need Eq/Ord to cross-chk update infos in interfaces
1010
1011 -- the form in which we pass update-analysis info between modules:
1012 type UpdateSpec = [Int]
1013 \end{code}
1014
1015 \begin{code}
1016 mkUpdateInfo = SomeUpdateInfo
1017
1018 updateInfoMaybe NoUpdateInfo        = Nothing
1019 updateInfoMaybe (SomeUpdateInfo []) = Nothing
1020 updateInfoMaybe (SomeUpdateInfo  u) = Just u
1021 \end{code}
1022
1023 Text instance so that the update annotations can be read in.
1024
1025 \begin{code}
1026 instance Text UpdateInfo where
1027     readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
1028                   | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
1029       where
1030         ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
1031                    | otherwise = panic "IdInfo: not a digit while reading update pragma"
1032
1033 instance OptIdInfo UpdateInfo where
1034     noInfo = NoUpdateInfo
1035
1036     getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
1037
1038     addInfo id_info NoUpdateInfo = id_info
1039     addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j
1040
1041     ppInfo sty better_id_fn NoUpdateInfo        = ifPprInterface sty pp_NONE
1042     ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
1043     ppInfo sty better_id_fn (SomeUpdateInfo spec)
1044       = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
1045 \end{code}
1046
1047 %************************************************************************
1048 %*                                                                    *
1049 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
1050 %*                                                                    *
1051 %************************************************************************
1052
1053 The deforest info says whether this Id is to be unfolded during
1054 deforestation.  Therefore, when the deforest pragma is true, we must
1055 also have the unfolding information available for this Id.
1056
1057 \begin{code}
1058 data DeforestInfo
1059   = Don'tDeforest                     -- just a bool, might extend this
1060   | DoDeforest                                -- later.
1061   -- deriving (Eq, Ord)
1062 \end{code}
1063
1064 \begin{code}
1065 instance OptIdInfo DeforestInfo where
1066     noInfo = Don'tDeforest
1067
1068     getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
1069
1070     addInfo id_info Don'tDeforest = id_info
1071     addInfo (IdInfo a b d e f g _ h i j) deforest =
1072         IdInfo a b d e f g deforest h i j
1073
1074     ppInfo sty better_id_fn Don'tDeforest
1075       = ifPprInterface sty pp_NONE
1076     ppInfo sty better_id_fn DoDeforest
1077       = ppPStr SLIT("_DEFOREST_")
1078 \end{code}
1079
1080 %************************************************************************
1081 %*                                                                      *
1082 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
1083 %*                                                                      *
1084 %************************************************************************
1085
1086 \begin{code}
1087 data ArgUsageInfo
1088   = NoArgUsageInfo
1089   | SomeArgUsageInfo ArgUsageType
1090   -- ??? deriving (Eq, Ord)
1091
1092 data ArgUsage = ArgUsage Int    -- number of arguments (is linear!)
1093               | UnknownArgUsage
1094 type ArgUsageType  = [ArgUsage]         -- c_1 -> ... -> BLOB
1095 \end{code}
1096
1097 \begin{code}
1098 mkArgUsageInfo = SomeArgUsageInfo
1099
1100 getArgUsage :: ArgUsageInfo -> ArgUsageType
1101 getArgUsage NoArgUsageInfo          = []
1102 getArgUsage (SomeArgUsageInfo u)  = u
1103 \end{code}
1104
1105 \begin{code}
1106 instance OptIdInfo ArgUsageInfo where
1107     noInfo = NoArgUsageInfo
1108
1109     getInfo (IdInfo _ _ _ _ _  _ _ au _ _) = au
1110
1111     addInfo id_info NoArgUsageInfo = id_info
1112     addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j
1113
1114     ppInfo sty better_id_fn NoArgUsageInfo        = ifPprInterface sty pp_NONE
1115     ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
1116     ppInfo sty better_id_fn (SomeArgUsageInfo aut)
1117       = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
1118
1119
1120 ppArgUsage (ArgUsage n)      = ppInt n
1121 ppArgUsage (UnknownArgUsage) = ppChar '-'
1122
1123 ppArgUsageType aut = ppBesides
1124         [ ppChar '"' ,
1125           ppIntersperse ppComma (map ppArgUsage aut),
1126           ppChar '"' ]
1127 \end{code}
1128 %************************************************************************
1129 %*                                                                      *
1130 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
1131 %*                                                                      *
1132 %************************************************************************
1133
1134 \begin{code}
1135 data FBTypeInfo
1136   = NoFBTypeInfo
1137   | SomeFBTypeInfo FBType
1138   -- ??? deriving (Eq, Ord)
1139
1140 data FBType = FBType [FBConsum] FBProd deriving (Eq)
1141
1142 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
1143 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
1144 \end{code}
1145
1146 \begin{code}
1147 mkFBTypeInfo = SomeFBTypeInfo
1148
1149 getFBType :: FBTypeInfo -> Maybe FBType
1150 getFBType NoFBTypeInfo        = Nothing
1151 getFBType (SomeFBTypeInfo u)  = Just u
1152 \end{code}
1153
1154 \begin{code}
1155 instance OptIdInfo FBTypeInfo where
1156     noInfo = NoFBTypeInfo
1157
1158     getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
1159
1160     addInfo id_info NoFBTypeInfo = id_info
1161     addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j
1162
1163     ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil
1164     ppInfo sty better_id_fn NoFBTypeInfo        = ifPprInterface sty pp_NONE
1165     ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod))
1166       = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
1167
1168 --ppFBType (FBType n)      = ppBesides [ppInt n]
1169 --ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
1170 --
1171
1172 ppFBType cons prod = ppBesides
1173         ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
1174   where
1175         ppCons FBGoodConsum = ppChar 'G'
1176         ppCons FBBadConsum  = ppChar 'B'
1177         ppProd FBGoodProd   = ppChar 'G'
1178         ppProd FBBadProd    = ppChar 'B'
1179 \end{code}