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, mEnvToList )
  80 import Outputable       ( ifPprInterface, Outputable(..){-instances-} )
  81 import PprStyle         ( PprStyle(..) )
  82 import Pretty
  83 import SrcLoc           ( mkUnknownSrcLoc )
  84 import Type             ( eqSimpleTy )
  85 import Util             ( mapAccumL, panic, assertPanic, pprPanic )
  86
  87 applySubstToTy = panic "IdInfo.applySubstToTy"
  88 isUnboxedDataType = panic "IdInfo.isUnboxedDataType"
  89 splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
  90 showTypeCategory = panic "IdInfo.showTypeCategory"
  91 mkFormSummary = panic "IdInfo.mkFormSummary"
  92 occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
  93 isWrapperFor = panic "IdInfo.isWrapperFor"
  94 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
  95 \end{code}
  96
  97 An @IdInfo@ gives {\em optional} information about an @Id@.  If
  98 present it never lies, but it may not be present, in which case there
  99 is always a conservative assumption which can be made.
 100
 101 Two @Id@s may have different info even though they have the same
 102 @Unique@ (and are hence the same @Id@); for example, one might lack
 103 the properties attached to the other.
 104
 105 The @IdInfo@ gives information about the value, or definition, of the
 106 @Id@.  It does {\em not} contain information about the @Id@'s usage
 107 (except for @DemandInfo@? ToDo).
 108
 109 \begin{code}
 110 data IdInfo
 111   = IdInfo
 112         ArityInfo               -- Its arity
 113
 114         DemandInfo              -- Whether or not it is definitely
 115                                 -- demanded
 116
 117         (MatchEnv [Type] CoreExpr)
 118                                 -- Specialisations of this function which exist
 119                                 -- This corresponds to a SpecEnv which we do
 120                                 -- not import directly to avoid loop
 121
 122         StrictnessInfo          -- Strictness properties, notably
 123                                 -- how to conjure up "worker" functions
 124
 125         UnfoldingDetails        -- Its unfolding; for locally-defined
 126                                 -- things, this can *only* be NoUnfoldingDetails
 127
 128         UpdateInfo              -- Which args should be updated
 129
 130         DeforestInfo            -- Whether its definition should be
 131                                 -- unfolded during deforestation
 132
 133         ArgUsageInfo            -- how this Id uses its arguments
 134
 135         FBTypeInfo              -- the Foldr/Build W/W property of this function.
 136
 137         SrcLoc                  -- Source location of definition
 138
 139         -- ToDo: SrcLoc is in FullNames too (could rm?)  but it
 140         -- is needed here too for things like ConstMethodIds and the
 141         -- like, which don't have full-names of their own Mind you,
 142         -- perhaps the FullName for a constant method could give the
 143         -- class/type involved?
 144 \end{code}
 145
 146 \begin{code}
 147 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
 148                   noInfo noInfo noInfo noInfo mkUnknownSrcLoc
 149
 150 -- "boring" means: nothing to put in interface
 151 boringIdInfo (IdInfo UnknownArity
 152                      UnknownDemand
 153                      specenv
 154                      strictness
 155                      unfolding
 156                      NoUpdateInfo
 157                      Don'tDeforest
 158                      _ {- arg_usage: currently no interface effect -}
 159                      _ {- no f/b w/w -}
 160                      _ {- src_loc: no effect on interfaces-}
 161               )
 162               |  null (mEnvToList specenv)
 163               && boring_strictness strictness
 164               && boring_unfolding unfolding
 165   = True
 166   where
 167     boring_strictness NoStrictnessInfo = True
 168     boring_strictness BottomGuaranteed = False
 169     boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
 170
 171     boring_unfolding NoUnfoldingDetails = True
 172     boring_unfolding _                  = False
 173
 174 boringIdInfo _ = False
 175
 176 pp_NONE = ppPStr SLIT("_N_")
 177 \end{code}
 178
 179 Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
 180 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 181 nasty loop, friends...)
 182 \begin{code}
 183 apply_to_IdInfo ty_fn (IdInfo arity demand spec strictness unfold
 184                               update deforest arg_usage fb_ww srcloc)
 185   = panic "IdInfo:apply_to_IdInfo"
 186 {- LATER:
 187     let
 188         new_spec = apply_spec spec
 189
 190         -- NOT a good idea:
 191         --   apply_strict strictness    `thenLft` \ new_strict ->
 192         --   apply_wrap wrap            `thenLft` \ new_wrap ->
 193     in
 194     IdInfo arity demand new_spec strictness unfold
 195            update deforest arg_usage fb_ww srcloc
 196   where
 197     apply_spec (SpecEnv is)
 198       = SpecEnv (map do_one is)
 199       where
 200         do_one (SpecInfo ty_maybes ds spec_id)
 201           = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
 202             SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
 203           where
 204             apply_to_maybe Nothing   = Nothing
 205             apply_to_maybe (Just ty) = Just (ty_fn ty)
 206 -}
 207
 208 {- NOT a good idea;
 209     apply_strict info@NoStrictnessInfo = returnLft info
 210     apply_strict BottomGuaranteed = ???
 211     apply_strict (StrictnessInfo wrap_arg_info id_maybe)
 212       = (case id_maybe of
 213            Nothing -> returnLft Nothing
 214            Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
 215                       returnLft (Just new_xx)
 216         ) `thenLft` \ new_id_maybe ->
 217         returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
 218 -}
 219 \end{code}
 220
 221 Variant of the same thing for the typechecker.
 222 \begin{code}
 223 applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
 224                               update deforest arg_usage fb_ww srcloc)
 225   = panic "IdInfo:applySubstToIdInfo"
 226 {- LATER:
 227     case (apply_spec s0 spec) of { (s1, new_spec) ->
 228     (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
 229   where
 230     apply_spec s0 (SpecEnv is)
 231       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
 232         (s1, SpecEnv new_is) }
 233       where
 234         do_one s0 (SpecInfo ty_maybes ds spec_id)
 235           = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
 236             (s1, SpecInfo new_maybes ds spec_id) }
 237           where
 238             apply_to_maybe s0 Nothing   = (s0, Nothing)
 239             apply_to_maybe s0 (Just ty)
 240               = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
 241                 (s1, Just new_ty) }
 242 -}
 243 \end{code}
 244
 245 \begin{code}
 246 ppIdInfo :: PprStyle
 247          -> Id          -- The Id for which we're printing this IdInfo
 248          -> Bool        -- True <=> print specialisations, please
 249          -> (Id -> Id)  -- to look up "better Ids" w/ better IdInfos;
 250          -> IdEnv UnfoldingDetails
 251                         -- inlining info for top-level fns in this module
 252          -> IdInfo      -- see MkIface notes
 253          -> Pretty
 254
 255 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 256     i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
 257   | boringIdInfo i
 258   = ppPStr SLIT("_NI_")
 259
 260   | otherwise
 261   = let
 262         stuff = ppCat [
 263                     -- order is important!:
 264                     ppInfo sty better_id_fn arity,
 265                     ppInfo sty better_id_fn update,
 266                     ppInfo sty better_id_fn deforest,
 267
 268                     pp_strictness sty (Just for_this_id)
 269                                                   better_id_fn inline_env strictness,
 270
 271                     if bottomIsGuaranteed strictness
 272                     then pp_NONE
 273                     else pp_unfolding sty for_this_id inline_env unfold,
 274
 275                     if specs_please
 276                     then ppSpecs sty (not (isDataCon for_this_id))
 277                                  better_id_fn inline_env (mEnvToList specenv)
 278                     else pp_NONE,
 279
 280                     -- DemandInfo needn't be printed since it has no effect on interfaces
 281                     ppInfo sty better_id_fn demand,
 282                     ppInfo sty better_id_fn fbtype
 283                 ]
 284     in
 285     case sty of
 286       PprInterface -> if opt_OmitInterfacePragmas
 287                       then ppNil
 288                       else stuff
 289       _            -> stuff
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 class OptIdInfo a where
 300     noInfo      :: a
 301     getInfo     :: IdInfo -> a
 302     addInfo     :: IdInfo -> a -> IdInfo
 303                 -- By default, "addInfo" will not overwrite
 304                 -- "info" with "non-info"; look at any instance
 305                 -- to see an example.
 306     ppInfo      :: PprStyle -> (Id -> Id) -> a -> Pretty
 307 \end{code}
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 Not used much, but...
 316 \begin{code}
 317 getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
 318 \end{code}
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection[arity-IdInfo]{Arity info about an @Id@}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 \begin{code}
 327 data ArityInfo
 328   = UnknownArity        -- no idea
 329   | ArityExactly Int    -- arity is exactly this
 330 \end{code}
 331
 332 \begin{code}
 333 mkArityInfo  = ArityExactly
 334 unknownArity = UnknownArity
 335
 336 arityMaybe :: ArityInfo -> Maybe Int
 337
 338 arityMaybe UnknownArity     = Nothing
 339 arityMaybe (ArityExactly i) = Just i
 340 \end{code}
 341
 342 \begin{code}
 343 instance OptIdInfo ArityInfo where
 344     noInfo = UnknownArity
 345
 346     getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
 347
 348     addInfo id_info UnknownArity = id_info
 349     addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
 350
 351     ppInfo sty _ UnknownArity         = ifPprInterface sty pp_NONE
 352     ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
 353 \end{code}
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsection[demand-IdInfo]{Demand info about an @Id@}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 Whether a value is certain to be demanded or not.  (This is the
 362 information that is computed by the ``front-end'' of the strictness
 363 analyser.)
 364
 365 This information is only used within a module, it is not exported
 366 (obviously).
 367
 368 \begin{code}
 369 data DemandInfo
 370   = UnknownDemand
 371   | DemandedAsPer Demand
 372 \end{code}
 373
 374 \begin{code}
 375 mkDemandInfo :: Demand -> DemandInfo
 376 mkDemandInfo demand = DemandedAsPer demand
 377
 378 willBeDemanded :: DemandInfo -> Bool
 379 willBeDemanded (DemandedAsPer demand) = isStrict demand
 380 willBeDemanded _                      = False
 381 \end{code}
 382
 383 \begin{code}
 384 instance OptIdInfo DemandInfo where
 385     noInfo = UnknownDemand
 386
 387     getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
 388
 389 {-      DELETED!  If this line is in, there is no way to
 390         nuke a DemandInfo, and we have to be able to do that
 391         when floating let-bindings around
 392     addInfo id_info UnknownDemand = id_info
 393 -}
 394     addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
 395
 396     ppInfo PprInterface _ _           = ppNil
 397     ppInfo sty _ UnknownDemand        = ppStr "{-# L #-}"
 398     ppInfo sty _ (DemandedAsPer info)
 399       = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
 400 \end{code}
 401
 402 %************************************************************************
 403 %*                                                                      *
 404 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 405 %*                                                                      *
 406 %************************************************************************
 407
 408 See SpecEnv.lhs
 409
 410 \begin{code}
 411 instance OptIdInfo (MatchEnv [Type] CoreExpr) where
 412     noInfo = nullMEnv
 413
 414     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 415
 416     addInfo id_info spec | null (mEnvToList spec) = id_info
 417     addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
 418
 419     ppInfo sty better_id_fn spec
 420       = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 421
 422 ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
 423   = panic "IdInfo:ppSpecs"
 424 \end{code}
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
 429 %*                                                                      *
 430 %************************************************************************
 431
 432 We specify the strictness of a function by giving information about
 433 each of the ``wrapper's'' arguments (see the description about
 434 worker/wrapper-style transformations in the PJ/Launchbury paper on
 435 unboxed types).
 436
 437 The list of @Demands@ specifies: (a)~the strictness properties
 438 of a function's arguments; (b)~the {\em existence} of a ``worker''
 439 version of the function; and (c)~the type signature of that worker (if
 440 it exists); i.e. its calling convention.
 441
 442 \begin{code}
 443 data StrictnessInfo
 444   = NoStrictnessInfo
 445
 446   | BottomGuaranteed    -- This Id guarantees never to return;
 447                         -- it is bottom regardless of its arguments.
 448                         -- Useful for "error" and other disguised
 449                         -- variants thereof.
 450
 451   | StrictnessInfo      [Demand]        -- the main stuff; see below.
 452                         (Maybe Id)      -- worker's Id, if applicable.
 453 \end{code}
 454
 455 This type is also actually used in the strictness analyser:
 456 \begin{code}
 457 data Demand
 458   = WwLazy              -- Argument is lazy as far as we know
 459         MaybeAbsent     -- (does not imply worker's existence [etc]).
 460                         -- If MaybeAbsent == True, then it is
 461                         -- *definitely* lazy.  (NB: Absence implies
 462                         -- a worker...)
 463
 464   | WwStrict            -- Argument is strict but that's all we know
 465                         -- (does not imply worker's existence or any
 466                         -- calling-convention magic)
 467
 468   | WwUnpack            -- Argument is strict & a single-constructor
 469         [Demand]        -- type; its constituent parts (whose StrictInfos
 470                         -- are in the list) should be passed
 471                         -- as arguments to the worker.
 472
 473   | WwPrim              -- Argument is of primitive type, therefore
 474                         -- strict; doesn't imply existence of a worker;
 475                         -- argument should be passed as is to worker.
 476
 477   | WwEnum              -- Argument is strict & an enumeration type;
 478                         -- an Int# representing the tag (start counting
 479                         -- at zero) should be passed to the worker.
 480   deriving (Eq, Ord)
 481       -- we need Eq/Ord to cross-chk update infos in interfaces
 482
 483 type MaybeAbsent = Bool -- True <=> not even used
 484
 485 -- versions that don't worry about Absence:
 486 wwLazy      = WwLazy      False
 487 wwStrict    = WwStrict
 488 wwUnpack xs = WwUnpack xs
 489 wwPrim      = WwPrim
 490 wwEnum      = WwEnum
 491 \end{code}
 492
 493 \begin{code}
 494 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
 495
 496 mkStrictnessInfo [] _    = NoStrictnessInfo
 497 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
 498
 499 mkBottomStrictnessInfo = BottomGuaranteed
 500
 501 bottomIsGuaranteed BottomGuaranteed = True
 502 bottomIsGuaranteed other            = False
 503
 504 getWrapperArgTypeCategories
 505         :: Type         -- wrapper's type
 506         -> StrictnessInfo       -- strictness info about its args
 507         -> Maybe String
 508
 509 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 510 getWrapperArgTypeCategories _ BottomGuaranteed
 511   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 512 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 513
 514 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 515   = Just (mkWrapperArgTypeCategories ty arg_info)
 516
 517 workerExists :: StrictnessInfo -> Bool
 518 workerExists (StrictnessInfo _ (Just worker_id)) = True
 519 workerExists other                               = False
 520
 521 getWorkerId :: StrictnessInfo -> Id
 522
 523 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
 524 #ifdef DEBUG
 525 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
 526 #endif
 527 \end{code}
 528
 529 \begin{code}
 530 isStrict :: Demand -> Bool
 531
 532 isStrict WwStrict       = True
 533 isStrict (WwUnpack _)   = True
 534 isStrict WwPrim         = True
 535 isStrict WwEnum         = True
 536 isStrict _              = False
 537
 538 nonAbsentArgs :: [Demand] -> Int
 539
 540 nonAbsentArgs cmpts
 541   = foldr tick_non 0 cmpts
 542   where
 543     tick_non (WwLazy True) acc = acc
 544     tick_non other         acc = acc + 1
 545
 546 all_present_WwLazies :: [Demand] -> Bool
 547 all_present_WwLazies infos
 548   = and (map is_L infos)
 549   where
 550     is_L (WwLazy False) = True  -- False <=> "Absent" args do *not* count!
 551     is_L _              = False -- (as they imply a worker)
 552 \end{code}
 553
 554 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
 555 an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
 556 check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
 557 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
 558 in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
 559 or an Absent {\em that we accept}.
 560 \begin{code}
 561 indicatesWorker :: [Demand] -> Bool
 562
 563 indicatesWorker dems
 564   = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
 565   where
 566     fake_mk_ww _ [] = False
 567     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
 568     fake_mk_ww extra_args (WwUnpack cmpnts : dems)
 569       | extra_args_now > 0 = True -- we accepted an Unpack
 570       where
 571         extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
 572
 573     fake_mk_ww extra_args (_ : dems)
 574       = fake_mk_ww extra_args dems
 575 \end{code}
 576
 577 \begin{code}
 578 mkWrapperArgTypeCategories
 579         :: Type         -- wrapper's type
 580         -> [Demand]     -- info about its arguments
 581         -> String       -- a string saying lots about the args
 582
 583 mkWrapperArgTypeCategories wrapper_ty wrap_info
 584   = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
 585     map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
 586     }
 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         (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
 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}