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