ghc/compiler/basicTypes/IdInfo.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   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
  20                         -- all the *Infos herein are instances of it
  21
  22         -- component "id infos"; also abstract:
  23         SrcLoc,
  24         getSrcLocIdInfo,
  25
  26         ArityInfo,
  27         mkArityInfo, unknownArity, arityMaybe,
  28
  29         DemandInfo,
  30         mkDemandInfo,
  31         willBeDemanded,
  32
  33         MatchEnv,               -- the SpecEnv (why is this exported???)
  34         StrictnessInfo(..),     -- non-abstract
  35         Demand(..),             -- non-abstract
  36
  37         wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
  38         indicatesWorker, nonAbsentArgs,
  39         mkStrictnessInfo, mkBottomStrictnessInfo,
  40         getWrapperArgTypeCategories,
  41         getWorkerId,
  42         workerExists,
  43         bottomIsGuaranteed,
  44
  45         mkUnfolding,
  46         noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
  47
  48         UpdateInfo,
  49         mkUpdateInfo,
  50         SYN_IE(UpdateSpec),
  51         updateInfoMaybe,
  52
  53         DeforestInfo(..),
  54
  55         ArgUsageInfo,
  56         ArgUsage(..),
  57         SYN_IE(ArgUsageType),
  58         mkArgUsageInfo,
  59         getArgUsage,
  60
  61         FBTypeInfo,
  62         FBType(..),
  63         FBConsum(..),
  64         FBProd(..),
  65         mkFBTypeInfo,
  66         getFBType
  67
  68     ) where
  69
  70 IMP_Ubiq()
  71 IMPORT_1_3(Char(toLower))
  72
  73 IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
  74                         -- we break those loops by using IdLoop and
  75                         -- *not* importing much of anything else,
  76                         -- except from the very general "utils".
  77
  78 import CmdLineOpts      ( opt_OmitInterfacePragmas )
  79 import Maybes           ( firstJust )
  80 import Outputable       ( ifPprInterface, Outputable(..){-instances-} )
  81 import PprStyle         ( PprStyle(..) )
  82 import Pretty
  83 import SrcLoc           ( mkUnknownSrcLoc )
  84 import Type             ( eqSimpleTy, splitFunTyExpandingDicts )
  85 import Unique           ( pprUnique )
  86 import Util             ( mapAccumL, panic, assertPanic, pprPanic )
  87
  88 #ifdef REALLY_HASKELL_1_3
  89 ord = fromEnum :: Char -> Int
  90 #endif
  91
  92 applySubstToTy = panic "IdInfo.applySubstToTy"
  93 showTypeCategory = panic "IdInfo.showTypeCategory"
  94 mkFormSummary = panic "IdInfo.mkFormSummary"
  95 isWrapperFor = panic "IdInfo.isWrapperFor"
  96 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
  97 \end{code}
  98
  99 An @IdInfo@ gives {\em optional} information about an @Id@.  If
 100 present it never lies, but it may not be present, in which case there
 101 is always a conservative assumption which can be made.
 102
 103 Two @Id@s may have different info even though they have the same
 104 @Unique@ (and are hence the same @Id@); for example, one might lack
 105 the properties attached to the other.
 106
 107 The @IdInfo@ gives information about the value, or definition, of the
 108 @Id@.  It does {\em not} contain information about the @Id@'s usage
 109 (except for @DemandInfo@? ToDo).
 110
 111 \begin{code}
 112 data IdInfo
 113   = IdInfo
 114         ArityInfo               -- Its arity
 115
 116         DemandInfo              -- Whether or not it is definitely
 117                                 -- demanded
 118
 119         SpecEnv                 -- Specialisations of this function which exist
 120
 121         StrictnessInfo          -- Strictness properties, notably
 122                                 -- how to conjure up "worker" functions
 123
 124         Unfolding               -- Its unfolding; for locally-defined
 125                                 -- things, this can *only* be NoUnfolding
 126
 127         UpdateInfo              -- Which args should be updated
 128
 129         DeforestInfo            -- Whether its definition should be
 130                                 -- unfolded during deforestation
 131
 132         ArgUsageInfo            -- how this Id uses its arguments
 133
 134         FBTypeInfo              -- the Foldr/Build W/W property of this function.
 135
 136         SrcLoc                  -- Source location of definition
 137
 138         -- ToDo: SrcLoc is in FullNames too (could rm?)  but it
 139         -- is needed here too for things like ConstMethodIds and the
 140         -- like, which don't have full-names of their own Mind you,
 141         -- perhaps the Name for a constant method could give the
 142         -- class/type involved?
 143 \end{code}
 144
 145 \begin{code}
 146 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
 147                   noInfo noInfo noInfo noInfo mkUnknownSrcLoc
 148
 149 -- "boring" means: nothing to put in interface
 150 boringIdInfo (IdInfo UnknownArity
 151                      UnknownDemand
 152                      specenv
 153                      strictness
 154                      unfolding
 155                      NoUpdateInfo
 156                      Don'tDeforest
 157                      _ {- arg_usage: currently no interface effect -}
 158                      _ {- no f/b w/w -}
 159                      _ {- src_loc: no effect on interfaces-}
 160               )
 161               |  isNullSpecEnv specenv
 162               && boring_strictness strictness
 163               && boring_unfolding unfolding
 164   = True
 165   where
 166     boring_strictness NoStrictnessInfo = True
 167     boring_strictness BottomGuaranteed = False
 168     boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
 169
 170     boring_unfolding NoUnfolding = True
 171     boring_unfolding _           = False
 172
 173 boringIdInfo _ = False
 174
 175 pp_NONE = ppPStr SLIT("_N_")
 176 \end{code}
 177
 178 Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
 179 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 180 nasty loop, friends...)
 181 \begin{code}
 182 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 183                               update deforest arg_usage fb_ww srcloc)
 184   | isNullSpecEnv spec
 185   = idinfo
 186   | otherwise
 187   = panic "IdInfo:apply_to_IdInfo"
 188 {- LATER:
 189     let
 190         new_spec = apply_spec spec
 191
 192         -- NOT a good idea:
 193         --   apply_strict strictness    `thenLft` \ new_strict ->
 194         --   apply_wrap wrap            `thenLft` \ new_wrap ->
 195     in
 196     IdInfo arity demand new_spec strictness unfold
 197            update deforest arg_usage fb_ww srcloc
 198   where
 199     apply_spec (SpecEnv is)
 200       = SpecEnv (map do_one is)
 201       where
 202         do_one (SpecInfo ty_maybes ds spec_id)
 203           = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
 204             SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
 205           where
 206             apply_to_maybe Nothing   = Nothing
 207             apply_to_maybe (Just ty) = Just (ty_fn ty)
 208 -}
 209
 210 {- NOT a good idea;
 211     apply_strict info@NoStrictnessInfo = returnLft info
 212     apply_strict BottomGuaranteed = ???
 213     apply_strict (StrictnessInfo wrap_arg_info id_maybe)
 214       = (case id_maybe of
 215            Nothing -> returnLft Nothing
 216            Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
 217                       returnLft (Just new_xx)
 218         ) `thenLft` \ new_id_maybe ->
 219         returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
 220 -}
 221 \end{code}
 222
 223 Variant of the same thing for the typechecker.
 224 \begin{code}
 225 applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
 226                               update deforest arg_usage fb_ww srcloc)
 227   = panic "IdInfo:applySubstToIdInfo"
 228 {- LATER:
 229     case (apply_spec s0 spec) of { (s1, new_spec) ->
 230     (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
 231   where
 232     apply_spec s0 (SpecEnv is)
 233       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
 234         (s1, SpecEnv new_is) }
 235       where
 236         do_one s0 (SpecInfo ty_maybes ds spec_id)
 237           = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
 238             (s1, SpecInfo new_maybes ds spec_id) }
 239           where
 240             apply_to_maybe s0 Nothing   = (s0, Nothing)
 241             apply_to_maybe s0 (Just ty)
 242               = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
 243                 (s1, Just new_ty) }
 244 -}
 245 \end{code}
 246
 247 \begin{code}
 248 ppIdInfo :: PprStyle
 249          -> Id          -- The Id for which we're printing this IdInfo
 250          -> Bool        -- True <=> print specialisations, please
 251          -> (Id -> Id)  -- to look up "better Ids" w/ better IdInfos;
 252          -> IdEnv Unfolding
 253                         -- inlining info for top-level fns in this module
 254          -> IdInfo      -- see MkIface notes
 255          -> Pretty
 256
 257 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 258     i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
 259   | boringIdInfo i
 260   = ppPStr SLIT("_NI_")
 261
 262   | otherwise
 263   = let
 264         stuff = ppCat [
 265                     -- order is important!:
 266                     ppInfo sty better_id_fn arity,
 267                     ppInfo sty better_id_fn update,
 268                     ppInfo sty better_id_fn deforest,
 269
 270                     pp_strictness sty (Just for_this_id)
 271                                                   better_id_fn inline_env strictness,
 272
 273                     if bottomIsGuaranteed strictness
 274                     then pp_NONE
 275                     else pp_unfolding sty for_this_id inline_env unfold,
 276
 277                     if specs_please
 278                     then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
 279                                          -- better_id_fn inline_env (mEnvToList specenv)
 280                     else pp_NONE,
 281
 282                     -- DemandInfo needn't be printed since it has no effect on interfaces
 283                     ppInfo sty better_id_fn demand,
 284                     ppInfo sty better_id_fn fbtype
 285                 ]
 286     in
 287     case sty of
 288       PprInterface -> if opt_OmitInterfacePragmas
 289                       then ppNil
 290                       else stuff
 291       _            -> stuff
 292 \end{code}
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 \begin{code}
 301 class OptIdInfo a where
 302     noInfo      :: a
 303     getInfo     :: IdInfo -> a
 304     addInfo     :: IdInfo -> a -> IdInfo
 305                 -- By default, "addInfo" will not overwrite
 306                 -- "info" with "non-info"; look at any instance
 307                 -- to see an example.
 308     ppInfo      :: PprStyle -> (Id -> Id) -> a -> Pretty
 309 \end{code}
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 Not used much, but...
 318 \begin{code}
 319 getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
 320 \end{code}
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection[arity-IdInfo]{Arity info about an @Id@}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 \begin{code}
 329 data ArityInfo
 330   = UnknownArity        -- no idea
 331   | ArityExactly Int    -- arity is exactly this
 332 \end{code}
 333
 334 \begin{code}
 335 mkArityInfo  = ArityExactly
 336 unknownArity = UnknownArity
 337
 338 arityMaybe :: ArityInfo -> Maybe Int
 339
 340 arityMaybe UnknownArity     = Nothing
 341 arityMaybe (ArityExactly i) = Just i
 342 \end{code}
 343
 344 \begin{code}
 345 instance OptIdInfo ArityInfo where
 346     noInfo = UnknownArity
 347
 348     getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
 349
 350     addInfo id_info UnknownArity = id_info
 351     addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
 352
 353     ppInfo sty _ UnknownArity         = ifPprInterface sty pp_NONE
 354     ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
 355 \end{code}
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsection[demand-IdInfo]{Demand info about an @Id@}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 Whether a value is certain to be demanded or not.  (This is the
 364 information that is computed by the ``front-end'' of the strictness
 365 analyser.)
 366
 367 This information is only used within a module, it is not exported
 368 (obviously).
 369
 370 \begin{code}
 371 data DemandInfo
 372   = UnknownDemand
 373   | DemandedAsPer Demand
 374 \end{code}
 375
 376 \begin{code}
 377 mkDemandInfo :: Demand -> DemandInfo
 378 mkDemandInfo demand = DemandedAsPer demand
 379
 380 willBeDemanded :: DemandInfo -> Bool
 381 willBeDemanded (DemandedAsPer demand) = isStrict demand
 382 willBeDemanded _                      = False
 383 \end{code}
 384
 385 \begin{code}
 386 instance OptIdInfo DemandInfo where
 387     noInfo = UnknownDemand
 388
 389     getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
 390
 391 {-      DELETED!  If this line is in, there is no way to
 392         nuke a DemandInfo, and we have to be able to do that
 393         when floating let-bindings around
 394     addInfo id_info UnknownDemand = id_info
 395 -}
 396     addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
 397
 398     ppInfo PprInterface _ _           = ppNil
 399     ppInfo sty _ UnknownDemand        = ppStr "{-# L #-}"
 400     ppInfo sty _ (DemandedAsPer info)
 401       = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 See SpecEnv.lhs
 411
 412 \begin{code}
 413 instance OptIdInfo SpecEnv where
 414     noInfo = nullSpecEnv
 415
 416     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 417
 418     addInfo id_info spec | isNullSpecEnv spec = id_info
 419     addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
 420
 421     ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
 422 --      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 423 \end{code}
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 We specify the strictness of a function by giving information about
 432 each of the ``wrapper's'' arguments (see the description about
 433 worker/wrapper-style transformations in the PJ/Launchbury paper on
 434 unboxed types).
 435
 436 The list of @Demands@ specifies: (a)~the strictness properties
 437 of a function's arguments; (b)~the {\em existence} of a ``worker''
 438 version of the function; and (c)~the type signature of that worker (if
 439 it exists); i.e. its calling convention.
 440
 441 \begin{code}
 442 data StrictnessInfo
 443   = NoStrictnessInfo
 444
 445   | BottomGuaranteed    -- This Id guarantees never to return;
 446                         -- it is bottom regardless of its arguments.
 447                         -- Useful for "error" and other disguised
 448                         -- variants thereof.
 449
 450   | StrictnessInfo      [Demand]        -- the main stuff; see below.
 451                         (Maybe Id)      -- worker's Id, if applicable.
 452 \end{code}
 453
 454 This type is also actually used in the strictness analyser:
 455 \begin{code}
 456 data Demand
 457   = WwLazy              -- Argument is lazy as far as we know
 458         MaybeAbsent     -- (does not imply worker's existence [etc]).
 459                         -- If MaybeAbsent == True, then it is
 460                         -- *definitely* lazy.  (NB: Absence implies
 461                         -- a worker...)
 462
 463   | WwStrict            -- Argument is strict but that's all we know
 464                         -- (does not imply worker's existence or any
 465                         -- calling-convention magic)
 466
 467   | WwUnpack            -- Argument is strict & a single-constructor
 468         [Demand]        -- type; its constituent parts (whose StrictInfos
 469                         -- are in the list) should be passed
 470                         -- as arguments to the worker.
 471
 472   | WwPrim              -- Argument is of primitive type, therefore
 473                         -- strict; doesn't imply existence of a worker;
 474                         -- argument should be passed as is to worker.
 475
 476   | WwEnum              -- Argument is strict & an enumeration type;
 477                         -- an Int# representing the tag (start counting
 478                         -- at zero) should be passed to the worker.
 479   deriving (Eq, Ord)
 480       -- we need Eq/Ord to cross-chk update infos in interfaces
 481
 482 type MaybeAbsent = Bool -- True <=> not even used
 483
 484 -- versions that don't worry about Absence:
 485 wwLazy      = WwLazy      False
 486 wwStrict    = WwStrict
 487 wwUnpack xs = WwUnpack xs
 488 wwPrim      = WwPrim
 489 wwEnum      = WwEnum
 490 \end{code}
 491
 492 \begin{code}
 493 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
 494
 495 mkStrictnessInfo [] _    = NoStrictnessInfo
 496 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
 497
 498 mkBottomStrictnessInfo = BottomGuaranteed
 499
 500 bottomIsGuaranteed BottomGuaranteed = True
 501 bottomIsGuaranteed other            = False
 502
 503 getWrapperArgTypeCategories
 504         :: Type         -- wrapper's type
 505         -> StrictnessInfo       -- strictness info about its args
 506         -> Maybe String
 507
 508 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 509 getWrapperArgTypeCategories _ BottomGuaranteed
 510   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 511 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 512
 513 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 514   = Just (mkWrapperArgTypeCategories ty arg_info)
 515
 516 workerExists :: StrictnessInfo -> Bool
 517 workerExists (StrictnessInfo _ (Just worker_id)) = True
 518 workerExists other                               = False
 519
 520 getWorkerId :: StrictnessInfo -> Id
 521
 522 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
 523 #ifdef DEBUG
 524 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
 525 #endif
 526 \end{code}
 527
 528 \begin{code}
 529 isStrict :: Demand -> Bool
 530
 531 isStrict WwStrict       = True
 532 isStrict (WwUnpack _)   = True
 533 isStrict WwPrim         = True
 534 isStrict WwEnum         = True
 535 isStrict _              = False
 536
 537 nonAbsentArgs :: [Demand] -> Int
 538
 539 nonAbsentArgs cmpts
 540   = foldr tick_non 0 cmpts
 541   where
 542     tick_non (WwLazy True) acc = acc
 543     tick_non other         acc = acc + 1
 544
 545 all_present_WwLazies :: [Demand] -> Bool
 546 all_present_WwLazies infos
 547   = and (map is_L infos)
 548   where
 549     is_L (WwLazy False) = True  -- False <=> "Absent" args do *not* count!
 550     is_L _              = False -- (as they imply a worker)
 551 \end{code}
 552
 553 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
 554 an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
 555 check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
 556 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
 557 in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
 558 or an Absent {\em that we accept}.
 559 \begin{code}
 560 indicatesWorker :: [Demand] -> Bool
 561
 562 indicatesWorker dems
 563   = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
 564   where
 565     fake_mk_ww _ [] = False
 566     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
 567     fake_mk_ww extra_args (WwUnpack cmpnts : dems)
 568       | extra_args_now > 0 = True -- we accepted an Unpack
 569       where
 570         extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
 571
 572     fake_mk_ww extra_args (_ : dems)
 573       = fake_mk_ww extra_args dems
 574 \end{code}
 575
 576 \begin{code}
 577 mkWrapperArgTypeCategories
 578         :: Type         -- wrapper's type
 579         -> [Demand]     -- info about its arguments
 580         -> String       -- a string saying lots about the args
 581
 582 mkWrapperArgTypeCategories wrapper_ty wrap_info
 583   = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
 584     map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
 585   where
 586     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 587     do_one (WwPrim, _) = 'P'
 588     do_one (WwEnum, _) = 'E'
 589     do_one (WwStrict, arg_ty_char) = arg_ty_char
 590     do_one (WwUnpack _, arg_ty_char)
 591       = if arg_ty_char `elem` "CIJFDTS"
 592         then toLower arg_ty_char
 593         else if arg_ty_char == '+' then 't'
 594         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 595     do_one (other_wrap_info, _) = '-'
 596 \end{code}
 597
 598 Whether a worker exists depends on whether the worker has an
 599 absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
 600
 601 If a @WwUnpack@ argument is for an {\em abstract} type (or one that
 602 will be abstract outside this module), which might happen for an
 603 imported function, then we can't (or don't want to...) unpack the arg
 604 as the worker requires.  Hence we have to give up altogether, and call
 605 the wrapper only; so under these circumstances we return \tr{False}.
 606
 607 \begin{code}
 608 #ifdef REALLY_HASKELL_1_3
 609 instance Read Demand where
 610 #else
 611 instance Text Demand where
 612 #endif
 613     readList str = read_em [{-acc-}] str
 614       where
 615         read_em acc []          = [(reverse acc, "")]
 616         -- lower case indicates absence...
 617         read_em acc ('L' : xs)  = read_em (WwLazy   False : acc) xs
 618         read_em acc ('A' : xs)  = read_em (WwLazy   True  : acc) xs
 619         read_em acc ('S' : xs)  = read_em (WwStrict : acc) xs
 620         read_em acc ('P' : xs)  = read_em (WwPrim : acc) xs
 621         read_em acc ('E' : xs)  = read_em (WwEnum : acc) xs
 622
 623         read_em acc (')' : xs)  = [(reverse acc, xs)]
 624         read_em acc ( 'U'  : '(' : xs)
 625           = case (read_em [] xs) of
 626               [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
 627               _ -> panic ("Text.Demand:"++str++"::"++xs)
 628
 629         read_em acc other = panic ("IdInfo.readem:"++other)
 630
 631 #ifdef REALLY_HASKELL_1_3
 632 instance Show Demand where
 633 #endif
 634     showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
 635       where
 636         show1 (WwLazy False) = "L"
 637         show1 (WwLazy True)  = "A"
 638         show1 WwStrict       = "S"
 639         show1 WwPrim         = "P"
 640         show1 WwEnum         = "E"
 641         show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
 642
 643 instance Outputable Demand where
 644     ppr sty si = ppStr (showList [si] "")
 645
 646 instance OptIdInfo StrictnessInfo where
 647     noInfo = NoStrictnessInfo
 648
 649     getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
 650
 651     addInfo id_info NoStrictnessInfo = id_info
 652     addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
 653
 654     ppInfo sty better_id_fn strictness_info
 655       = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
 656 \end{code}
 657
 658 We'll omit the worker info if the thing has an explicit unfolding
 659 already.
 660 \begin{code}
 661 pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
 662
 663 pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
 664
 665 pp_strictness sty for_this_id_maybe better_id_fn inline_env
 666     info@(StrictnessInfo wrapper_args wrkr_maybe)
 667   = let
 668         (have_wrkr, wrkr_id) = case wrkr_maybe of
 669                                  Nothing -> (False, panic "ppInfo(Strictness)")
 670                                  Just xx -> (True,  xx)
 671
 672         wrkr_to_print   = better_id_fn wrkr_id
 673         wrkr_info       = getIdInfo   wrkr_to_print
 674
 675         -- if we aren't going to be able to *read* the strictness info
 676         -- in TcPragmas, we need not even print it.
 677         wrapper_args_to_use
 678           = if not (indicatesWorker wrapper_args) then
 679                 wrapper_args -- no worker/wrappering in any case
 680             else
 681                 case for_this_id_maybe of
 682                   Nothing -> wrapper_args
 683                   Just id -> if externallyVisibleId id
 684                              && (unfoldingUnfriendlyId id || not have_wrkr) then
 685                                 -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
 686                                 map un_workerise wrapper_args
 687                              else
 688                                 wrapper_args
 689
 690         id_is_worker
 691           = case for_this_id_maybe of
 692               Nothing -> False
 693               Just id -> isWorkerId id
 694
 695         am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
 696
 697         pp_basic_info
 698           = ppBesides [ppStr "_S_ \"",
 699                 ppStr (showList wrapper_args_to_use ""), ppStr "\""]
 700
 701         pp_with_worker
 702           = ppBesides [ ppSP, ppChar '{',
 703                         ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
 704                         ppChar '}' ]
 705     in
 706     if all_present_WwLazies wrapper_args_to_use then -- too boring
 707         ifPprInterface sty pp_NONE
 708
 709     else if id_is_worker && am_printing_iface then
 710         pp_NONE -- we don't put worker strictness in interfaces
 711                 -- (it can be deduced)
 712
 713     else if not (indicatesWorker wrapper_args_to_use)
 714          || not have_wrkr
 715          || boringIdInfo wrkr_info then
 716         ppBeside pp_basic_info ppNil
 717     else
 718         ppBeside pp_basic_info pp_with_worker
 719   where
 720     un_workerise (WwLazy   _) = WwLazy False -- avoid absence
 721     un_workerise (WwUnpack _) = WwStrict
 722     un_workerise other        = other
 723 \end{code}
 724
 725 %************************************************************************
 726 %*                                                                      *
 727 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
 728 %*                                                                      *
 729 %************************************************************************
 730
 731 \begin{code}
 732 mkUnfolding guide expr
 733   = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
 734                                    guide
 735                                    (occurAnalyseGlobalExpr expr))
 736 \end{code}
 737
 738 \begin{code}
 739 noInfo_UF = NoUnfolding
 740
 741 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
 742
 743 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
 744 addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
 745 \end{code}
 746
 747 \begin{code}
 748 pp_unfolding sty for_this_id inline_env uf_details
 749   = case (lookupIdEnv inline_env for_this_id) of
 750       Nothing -> pp uf_details
 751       Just dt -> pp dt
 752   where
 753     pp NoUnfolding = pp_NONE
 754
 755     pp (MagicUnfolding tag _)
 756       = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
 757
 758     pp (CoreUnfolding (SimpleUnfolding _ guide template))
 759       = let
 760             untagged = unTagBinders template
 761         in
 762         if untagged `isWrapperFor` for_this_id
 763         then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
 764              pp_NONE
 765         else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
 766
 767 \end{code}
 768
 769 %************************************************************************
 770 %*                                                                      *
 771 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
 772 %*                                                                      *
 773 %************************************************************************
 774
 775 \begin{code}
 776 data UpdateInfo
 777   = NoUpdateInfo
 778   | SomeUpdateInfo UpdateSpec
 779   deriving (Eq, Ord)
 780       -- we need Eq/Ord to cross-chk update infos in interfaces
 781
 782 -- the form in which we pass update-analysis info between modules:
 783 type UpdateSpec = [Int]
 784 \end{code}
 785
 786 \begin{code}
 787 mkUpdateInfo = SomeUpdateInfo
 788
 789 updateInfoMaybe NoUpdateInfo        = Nothing
 790 updateInfoMaybe (SomeUpdateInfo []) = Nothing
 791 updateInfoMaybe (SomeUpdateInfo  u) = Just u
 792 \end{code}
 793
 794 Text instance so that the update annotations can be read in.
 795
 796 \begin{code}
 797 #ifdef REALLY_HASKELL_1_3
 798 instance Read UpdateInfo where
 799 #else
 800 instance Text UpdateInfo where
 801 #endif
 802     readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
 803                   | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
 804       where
 805         ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
 806                    | otherwise = panic "IdInfo: not a digit while reading update pragma"
 807
 808 instance OptIdInfo UpdateInfo where
 809     noInfo = NoUpdateInfo
 810
 811     getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
 812
 813     addInfo id_info NoUpdateInfo = id_info
 814     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
 815
 816     ppInfo sty better_id_fn NoUpdateInfo        = ifPprInterface sty pp_NONE
 817     ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
 818     ppInfo sty better_id_fn (SomeUpdateInfo spec)
 819       = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
 820 \end{code}
 821
 822 %************************************************************************
 823 %*                                                                    *
 824 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
 825 %*                                                                    *
 826 %************************************************************************
 827
 828 The deforest info says whether this Id is to be unfolded during
 829 deforestation.  Therefore, when the deforest pragma is true, we must
 830 also have the unfolding information available for this Id.
 831
 832 \begin{code}
 833 data DeforestInfo
 834   = Don'tDeforest                     -- just a bool, might extend this
 835   | DoDeforest                                -- later.
 836   -- deriving (Eq, Ord)
 837 \end{code}
 838
 839 \begin{code}
 840 instance OptIdInfo DeforestInfo where
 841     noInfo = Don'tDeforest
 842
 843     getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
 844
 845     addInfo id_info Don'tDeforest = id_info
 846     addInfo (IdInfo a b d e f g _ h i j) deforest =
 847         IdInfo a b d e f g deforest h i j
 848
 849     ppInfo sty better_id_fn Don'tDeforest
 850       = ifPprInterface sty pp_NONE
 851     ppInfo sty better_id_fn DoDeforest
 852       = ppPStr SLIT("_DEFOREST_")
 853 \end{code}
 854
 855 %************************************************************************
 856 %*                                                                      *
 857 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
 858 %*                                                                      *
 859 %************************************************************************
 860
 861 \begin{code}
 862 data ArgUsageInfo
 863   = NoArgUsageInfo
 864   | SomeArgUsageInfo ArgUsageType
 865   -- ??? deriving (Eq, Ord)
 866
 867 data ArgUsage = ArgUsage Int    -- number of arguments (is linear!)
 868               | UnknownArgUsage
 869 type ArgUsageType  = [ArgUsage]         -- c_1 -> ... -> BLOB
 870 \end{code}
 871
 872 \begin{code}
 873 mkArgUsageInfo = SomeArgUsageInfo
 874
 875 getArgUsage :: ArgUsageInfo -> ArgUsageType
 876 getArgUsage NoArgUsageInfo          = []
 877 getArgUsage (SomeArgUsageInfo u)  = u
 878 \end{code}
 879
 880 \begin{code}
 881 instance OptIdInfo ArgUsageInfo where
 882     noInfo = NoArgUsageInfo
 883
 884     getInfo (IdInfo _ _ _ _ _  _ _ au _ _) = au
 885
 886     addInfo id_info NoArgUsageInfo = id_info
 887     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
 888
 889     ppInfo sty better_id_fn NoArgUsageInfo              = ifPprInterface sty pp_NONE
 890     ppInfo sty better_id_fn (SomeArgUsageInfo [])       = ifPprInterface sty pp_NONE
 891     ppInfo sty better_id_fn (SomeArgUsageInfo aut)
 892       = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
 893
 894
 895 ppArgUsage (ArgUsage n)      = ppInt n
 896 ppArgUsage (UnknownArgUsage) = ppChar '-'
 897
 898 ppArgUsageType aut = ppBesides
 899         [ ppChar '"' ,
 900           ppIntersperse ppComma (map ppArgUsage aut),
 901           ppChar '"' ]
 902 \end{code}
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 \begin{code}
 910 data FBTypeInfo
 911   = NoFBTypeInfo
 912   | SomeFBTypeInfo FBType
 913   -- ??? deriving (Eq, Ord)
 914
 915 data FBType = FBType [FBConsum] FBProd deriving (Eq)
 916
 917 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
 918 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
 919 \end{code}
 920
 921 \begin{code}
 922 mkFBTypeInfo = SomeFBTypeInfo
 923
 924 getFBType :: FBTypeInfo -> Maybe FBType
 925 getFBType NoFBTypeInfo        = Nothing
 926 getFBType (SomeFBTypeInfo u)  = Just u
 927 \end{code}
 928
 929 \begin{code}
 930 instance OptIdInfo FBTypeInfo where
 931     noInfo = NoFBTypeInfo
 932
 933     getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
 934
 935     addInfo id_info NoFBTypeInfo = id_info
 936     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
 937
 938     ppInfo PprInterface _ NoFBTypeInfo = ppNil
 939     ppInfo sty          _ NoFBTypeInfo = ifPprInterface sty pp_NONE
 940     ppInfo sty          _ (SomeFBTypeInfo (FBType cons prod))
 941       = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
 942
 943 --ppFBType (FBType n)      = ppBesides [ppInt n]
 944 --ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
 945 --
 946
 947 ppFBType cons prod = ppBesides
 948         ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
 949   where
 950         ppCons FBGoodConsum = ppChar 'G'
 951         ppCons FBBadConsum  = ppChar 'B'
 952         ppProd FBGoodProd   = ppChar 'G'
 953         ppProd FBBadProd    = ppChar 'B'
 954 \end{code}