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