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 )
  85 import Util             ( mapAccumL, panic, assertPanic, pprPanic )
  86
  87 applySubstToTy = panic "IdInfo.applySubstToTy"
  88 splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
  89 showTypeCategory = panic "IdInfo.showTypeCategory"
  90 mkFormSummary = panic "IdInfo.mkFormSummary"
  91 occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
  92 isWrapperFor = panic "IdInfo.isWrapperFor"
  93 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
  94 \end{code}
  95
  96 An @IdInfo@ gives {\em optional} information about an @Id@.  If
  97 present it never lies, but it may not be present, in which case there
  98 is always a conservative assumption which can be made.
  99
 100 Two @Id@s may have different info even though they have the same
 101 @Unique@ (and are hence the same @Id@); for example, one might lack
 102 the properties attached to the other.
 103
 104 The @IdInfo@ gives information about the value, or definition, of the
 105 @Id@.  It does {\em not} contain information about the @Id@'s usage
 106 (except for @DemandInfo@? ToDo).
 107
 108 \begin{code}
 109 data IdInfo
 110   = IdInfo
 111         ArityInfo               -- Its arity
 112
 113         DemandInfo              -- Whether or not it is definitely
 114                                 -- demanded
 115
 116         (MatchEnv [Type] CoreExpr)
 117                                 -- Specialisations of this function which exist
 118                                 -- This corresponds to a SpecEnv which we do
 119                                 -- not import directly to avoid loop
 120
 121         StrictnessInfo          -- Strictness properties, notably
 122                                 -- how to conjure up "worker" functions
 123
 124         UnfoldingDetails        -- Its unfolding; for locally-defined
 125                                 -- things, this can *only* be NoUnfoldingDetails
 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 FullName 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               |  null (mEnvToList 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 NoUnfoldingDetails = 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   | isEmptyMEnv 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 UnfoldingDetails
 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 ppSpecs 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 (MatchEnv [Type] CoreExpr) where
 414     noInfo = nullMEnv
 415
 416     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 417
 418     addInfo id_info spec | null (mEnvToList 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
 422       = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 423
 424 ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
 425   = panic "IdInfo:ppSpecs"
 426 \end{code}
 427
 428 %************************************************************************
 429 %*                                                                      *
 430 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
 431 %*                                                                      *
 432 %************************************************************************
 433
 434 We specify the strictness of a function by giving information about
 435 each of the ``wrapper's'' arguments (see the description about
 436 worker/wrapper-style transformations in the PJ/Launchbury paper on
 437 unboxed types).
 438
 439 The list of @Demands@ specifies: (a)~the strictness properties
 440 of a function's arguments; (b)~the {\em existence} of a ``worker''
 441 version of the function; and (c)~the type signature of that worker (if
 442 it exists); i.e. its calling convention.
 443
 444 \begin{code}
 445 data StrictnessInfo
 446   = NoStrictnessInfo
 447
 448   | BottomGuaranteed    -- This Id guarantees never to return;
 449                         -- it is bottom regardless of its arguments.
 450                         -- Useful for "error" and other disguised
 451                         -- variants thereof.
 452
 453   | StrictnessInfo      [Demand]        -- the main stuff; see below.
 454                         (Maybe Id)      -- worker's Id, if applicable.
 455 \end{code}
 456
 457 This type is also actually used in the strictness analyser:
 458 \begin{code}
 459 data Demand
 460   = WwLazy              -- Argument is lazy as far as we know
 461         MaybeAbsent     -- (does not imply worker's existence [etc]).
 462                         -- If MaybeAbsent == True, then it is
 463                         -- *definitely* lazy.  (NB: Absence implies
 464                         -- a worker...)
 465
 466   | WwStrict            -- Argument is strict but that's all we know
 467                         -- (does not imply worker's existence or any
 468                         -- calling-convention magic)
 469
 470   | WwUnpack            -- Argument is strict & a single-constructor
 471         [Demand]        -- type; its constituent parts (whose StrictInfos
 472                         -- are in the list) should be passed
 473                         -- as arguments to the worker.
 474
 475   | WwPrim              -- Argument is of primitive type, therefore
 476                         -- strict; doesn't imply existence of a worker;
 477                         -- argument should be passed as is to worker.
 478
 479   | WwEnum              -- Argument is strict & an enumeration type;
 480                         -- an Int# representing the tag (start counting
 481                         -- at zero) should be passed to the worker.
 482   deriving (Eq, Ord)
 483       -- we need Eq/Ord to cross-chk update infos in interfaces
 484
 485 type MaybeAbsent = Bool -- True <=> not even used
 486
 487 -- versions that don't worry about Absence:
 488 wwLazy      = WwLazy      False
 489 wwStrict    = WwStrict
 490 wwUnpack xs = WwUnpack xs
 491 wwPrim      = WwPrim
 492 wwEnum      = WwEnum
 493 \end{code}
 494
 495 \begin{code}
 496 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
 497
 498 mkStrictnessInfo [] _    = NoStrictnessInfo
 499 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
 500
 501 mkBottomStrictnessInfo = BottomGuaranteed
 502
 503 bottomIsGuaranteed BottomGuaranteed = True
 504 bottomIsGuaranteed other            = False
 505
 506 getWrapperArgTypeCategories
 507         :: Type         -- wrapper's type
 508         -> StrictnessInfo       -- strictness info about its args
 509         -> Maybe String
 510
 511 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 512 getWrapperArgTypeCategories _ BottomGuaranteed
 513   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 514 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 515
 516 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 517   = Just (mkWrapperArgTypeCategories ty arg_info)
 518
 519 workerExists :: StrictnessInfo -> Bool
 520 workerExists (StrictnessInfo _ (Just worker_id)) = True
 521 workerExists other                               = False
 522
 523 getWorkerId :: StrictnessInfo -> Id
 524
 525 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
 526 #ifdef DEBUG
 527 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
 528 #endif
 529 \end{code}
 530
 531 \begin{code}
 532 isStrict :: Demand -> Bool
 533
 534 isStrict WwStrict       = True
 535 isStrict (WwUnpack _)   = True
 536 isStrict WwPrim         = True
 537 isStrict WwEnum         = True
 538 isStrict _              = False
 539
 540 nonAbsentArgs :: [Demand] -> Int
 541
 542 nonAbsentArgs cmpts
 543   = foldr tick_non 0 cmpts
 544   where
 545     tick_non (WwLazy True) acc = acc
 546     tick_non other         acc = acc + 1
 547
 548 all_present_WwLazies :: [Demand] -> Bool
 549 all_present_WwLazies infos
 550   = and (map is_L infos)
 551   where
 552     is_L (WwLazy False) = True  -- False <=> "Absent" args do *not* count!
 553     is_L _              = False -- (as they imply a worker)
 554 \end{code}
 555
 556 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
 557 an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
 558 check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
 559 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
 560 in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
 561 or an Absent {\em that we accept}.
 562 \begin{code}
 563 indicatesWorker :: [Demand] -> Bool
 564
 565 indicatesWorker dems
 566   = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
 567   where
 568     fake_mk_ww _ [] = False
 569     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
 570     fake_mk_ww extra_args (WwUnpack cmpnts : dems)
 571       | extra_args_now > 0 = True -- we accepted an Unpack
 572       where
 573         extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
 574
 575     fake_mk_ww extra_args (_ : dems)
 576       = fake_mk_ww extra_args dems
 577 \end{code}
 578
 579 \begin{code}
 580 mkWrapperArgTypeCategories
 581         :: Type         -- wrapper's type
 582         -> [Demand]     -- info about its arguments
 583         -> String       -- a string saying lots about the args
 584
 585 mkWrapperArgTypeCategories wrapper_ty wrap_info
 586   = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
 587     map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
 588     }
 589   where
 590     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 591     do_one (WwPrim, _) = 'P'
 592     do_one (WwEnum, _) = 'E'
 593     do_one (WwStrict, arg_ty_char) = arg_ty_char
 594     do_one (WwUnpack _, arg_ty_char)
 595       = if arg_ty_char `elem` "CIJFDTS"
 596         then toLower arg_ty_char
 597         else if arg_ty_char == '+' then 't'
 598         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 599     do_one (other_wrap_info, _) = '-'
 600 \end{code}
 601
 602 Whether a worker exists depends on whether the worker has an
 603 absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
 604
 605 If a @WwUnpack@ argument is for an {\em abstract} type (or one that
 606 will be abstract outside this module), which might happen for an
 607 imported function, then we can't (or don't want to...) unpack the arg
 608 as the worker requires.  Hence we have to give up altogether, and call
 609 the wrapper only; so under these circumstances we return \tr{False}.
 610
 611 \begin{code}
 612 instance Text Demand where
 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     showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
 632       where
 633         show1 (WwLazy False) = "L"
 634         show1 (WwLazy True)  = "A"
 635         show1 WwStrict       = "S"
 636         show1 WwPrim         = "P"
 637         show1 WwEnum         = "E"
 638         show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
 639
 640 instance Outputable Demand where
 641     ppr sty si = ppStr (showList [si] "")
 642
 643 instance OptIdInfo StrictnessInfo where
 644     noInfo = NoStrictnessInfo
 645
 646     getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
 647
 648     addInfo id_info NoStrictnessInfo = id_info
 649     addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
 650
 651     ppInfo sty better_id_fn strictness_info
 652       = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
 653 \end{code}
 654
 655 We'll omit the worker info if the thing has an explicit unfolding
 656 already.
 657 \begin{code}
 658 pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
 659
 660 pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
 661
 662 pp_strictness sty for_this_id_maybe better_id_fn inline_env
 663     info@(StrictnessInfo wrapper_args wrkr_maybe)
 664   = let
 665         (have_wrkr, wrkr_id) = case wrkr_maybe of
 666                                  Nothing -> (False, panic "ppInfo(Strictness)")
 667                                  Just xx -> (True,  xx)
 668
 669         wrkr_to_print   = better_id_fn wrkr_id
 670         wrkr_info       = getIdInfo   wrkr_to_print
 671
 672         -- if we aren't going to be able to *read* the strictness info
 673         -- in TcPragmas, we need not even print it.
 674         wrapper_args_to_use
 675           = if not (indicatesWorker wrapper_args) then
 676                 wrapper_args -- no worker/wrappering in any case
 677             else
 678                 case for_this_id_maybe of
 679                   Nothing -> wrapper_args
 680                   Just id -> if externallyVisibleId id
 681                              && (unfoldingUnfriendlyId id || not have_wrkr) then
 682                                 -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
 683                                 map un_workerise wrapper_args
 684                              else
 685                                 wrapper_args
 686
 687         id_is_worker
 688           = case for_this_id_maybe of
 689               Nothing -> False
 690               Just id -> isWorkerId id
 691
 692         am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
 693
 694         pp_basic_info
 695           = ppBesides [ppStr "_S_ \"",
 696                 ppStr (showList wrapper_args_to_use ""), ppStr "\""]
 697
 698         pp_with_worker
 699           = ppBesides [ ppSP, ppChar '{',
 700                         ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
 701                         ppChar '}' ]
 702     in
 703     if all_present_WwLazies wrapper_args_to_use then -- too boring
 704         ifPprInterface sty pp_NONE
 705
 706     else if id_is_worker && am_printing_iface then
 707         pp_NONE -- we don't put worker strictness in interfaces
 708                 -- (it can be deduced)
 709
 710     else if not (indicatesWorker wrapper_args_to_use)
 711          || not have_wrkr
 712          || boringIdInfo wrkr_info then
 713         ppBeside pp_basic_info ppNil
 714     else
 715         ppBeside pp_basic_info pp_with_worker
 716   where
 717     un_workerise (WwLazy   _) = WwLazy False -- avoid absence
 718     un_workerise (WwUnpack _) = WwStrict
 719     un_workerise other        = other
 720 \end{code}
 721
 722 %************************************************************************
 723 %*                                                                      *
 724 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
 725 %*                                                                      *
 726 %************************************************************************
 727
 728 \begin{code}
 729 mkUnfolding guide expr
 730   = GenForm False (mkFormSummary NoStrictnessInfo expr)
 731         (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
 732         guide
 733 \end{code}
 734
 735 \begin{code}
 736 noInfo_UF = NoUnfoldingDetails
 737
 738 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
 739   = case unfolding of
 740       GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
 741       unfolding_as_was               -> unfolding_as_was
 742
 743 -- getInfo_UF ensures that any BadUnfoldings are never returned
 744 -- We had to delay the test required in TcPragmas until now due
 745 -- to strictness constraints in TcPragmas
 746
 747 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
 748 addInfo_UF   (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
 749 \end{code}
 750
 751 \begin{code}
 752 pp_unfolding sty for_this_id inline_env uf_details
 753   = case (lookupIdEnv inline_env for_this_id) of
 754       Nothing -> pp uf_details
 755       Just dt -> pp dt
 756   where
 757     pp NoUnfoldingDetails = pp_NONE
 758
 759     pp (MagicForm tag _)
 760       = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
 761
 762     pp (GenForm _ _ _ BadUnfolding) = pp_NONE
 763
 764     pp (GenForm _ _ template guide)
 765       = let
 766             untagged = unTagBinders template
 767         in
 768         if untagged `isWrapperFor` for_this_id
 769         then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
 770              pp_NONE
 771         else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
 772
 773 \end{code}
 774
 775 %************************************************************************
 776 %*                                                                      *
 777 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
 778 %*                                                                      *
 779 %************************************************************************
 780
 781 \begin{code}
 782 data UpdateInfo
 783   = NoUpdateInfo
 784   | SomeUpdateInfo UpdateSpec
 785   deriving (Eq, Ord)
 786       -- we need Eq/Ord to cross-chk update infos in interfaces
 787
 788 -- the form in which we pass update-analysis info between modules:
 789 type UpdateSpec = [Int]
 790 \end{code}
 791
 792 \begin{code}
 793 mkUpdateInfo = SomeUpdateInfo
 794
 795 updateInfoMaybe NoUpdateInfo        = Nothing
 796 updateInfoMaybe (SomeUpdateInfo []) = Nothing
 797 updateInfoMaybe (SomeUpdateInfo  u) = Just u
 798 \end{code}
 799
 800 Text instance so that the update annotations can be read in.
 801
 802 \begin{code}
 803 instance Text UpdateInfo where
 804     readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
 805                   | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
 806       where
 807         ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
 808                    | otherwise = panic "IdInfo: not a digit while reading update pragma"
 809
 810 instance OptIdInfo UpdateInfo where
 811     noInfo = NoUpdateInfo
 812
 813     getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
 814
 815     addInfo id_info NoUpdateInfo = id_info
 816     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
 817
 818     ppInfo sty better_id_fn NoUpdateInfo        = ifPprInterface sty pp_NONE
 819     ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
 820     ppInfo sty better_id_fn (SomeUpdateInfo spec)
 821       = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
 822 \end{code}
 823
 824 %************************************************************************
 825 %*                                                                    *
 826 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
 827 %*                                                                    *
 828 %************************************************************************
 829
 830 The deforest info says whether this Id is to be unfolded during
 831 deforestation.  Therefore, when the deforest pragma is true, we must
 832 also have the unfolding information available for this Id.
 833
 834 \begin{code}
 835 data DeforestInfo
 836   = Don'tDeforest                     -- just a bool, might extend this
 837   | DoDeforest                                -- later.
 838   -- deriving (Eq, Ord)
 839 \end{code}
 840
 841 \begin{code}
 842 instance OptIdInfo DeforestInfo where
 843     noInfo = Don'tDeforest
 844
 845     getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
 846
 847     addInfo id_info Don'tDeforest = id_info
 848     addInfo (IdInfo a b d e f g _ h i j) deforest =
 849         IdInfo a b d e f g deforest h i j
 850
 851     ppInfo sty better_id_fn Don'tDeforest
 852       = ifPprInterface sty pp_NONE
 853     ppInfo sty better_id_fn DoDeforest
 854       = ppPStr SLIT("_DEFOREST_")
 855 \end{code}
 856
 857 %************************************************************************
 858 %*                                                                      *
 859 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
 860 %*                                                                      *
 861 %************************************************************************
 862
 863 \begin{code}
 864 data ArgUsageInfo
 865   = NoArgUsageInfo
 866   | SomeArgUsageInfo ArgUsageType
 867   -- ??? deriving (Eq, Ord)
 868
 869 data ArgUsage = ArgUsage Int    -- number of arguments (is linear!)
 870               | UnknownArgUsage
 871 type ArgUsageType  = [ArgUsage]         -- c_1 -> ... -> BLOB
 872 \end{code}
 873
 874 \begin{code}
 875 mkArgUsageInfo = SomeArgUsageInfo
 876
 877 getArgUsage :: ArgUsageInfo -> ArgUsageType
 878 getArgUsage NoArgUsageInfo          = []
 879 getArgUsage (SomeArgUsageInfo u)  = u
 880 \end{code}
 881
 882 \begin{code}
 883 instance OptIdInfo ArgUsageInfo where
 884     noInfo = NoArgUsageInfo
 885
 886     getInfo (IdInfo _ _ _ _ _  _ _ au _ _) = au
 887
 888     addInfo id_info NoArgUsageInfo = id_info
 889     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
 890
 891     ppInfo sty better_id_fn NoArgUsageInfo              = ifPprInterface sty pp_NONE
 892     ppInfo sty better_id_fn (SomeArgUsageInfo [])       = ifPprInterface sty pp_NONE
 893     ppInfo sty better_id_fn (SomeArgUsageInfo aut)
 894       = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
 895
 896
 897 ppArgUsage (ArgUsage n)      = ppInt n
 898 ppArgUsage (UnknownArgUsage) = ppChar '-'
 899
 900 ppArgUsageType aut = ppBesides
 901         [ ppChar '"' ,
 902           ppIntersperse ppComma (map ppArgUsage aut),
 903           ppChar '"' ]
 904 \end{code}
 905 %************************************************************************
 906 %*                                                                      *
 907 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
 908 %*                                                                      *
 909 %************************************************************************
 910
 911 \begin{code}
 912 data FBTypeInfo
 913   = NoFBTypeInfo
 914   | SomeFBTypeInfo FBType
 915   -- ??? deriving (Eq, Ord)
 916
 917 data FBType = FBType [FBConsum] FBProd deriving (Eq)
 918
 919 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
 920 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
 921 \end{code}
 922
 923 \begin{code}
 924 mkFBTypeInfo = SomeFBTypeInfo
 925
 926 getFBType :: FBTypeInfo -> Maybe FBType
 927 getFBType NoFBTypeInfo        = Nothing
 928 getFBType (SomeFBTypeInfo u)  = Just u
 929 \end{code}
 930
 931 \begin{code}
 932 instance OptIdInfo FBTypeInfo where
 933     noInfo = NoFBTypeInfo
 934
 935     getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
 936
 937     addInfo id_info NoFBTypeInfo = id_info
 938     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
 939
 940     ppInfo PprInterface _ NoFBTypeInfo = ppNil
 941     ppInfo sty          _ NoFBTypeInfo = ifPprInterface sty pp_NONE
 942     ppInfo sty          _ (SomeFBTypeInfo (FBType cons prod))
 943       = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
 944
 945 --ppFBType (FBType n)      = ppBesides [ppInt n]
 946 --ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
 947 --
 948
 949 ppFBType cons prod = ppBesides
 950         ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
 951   where
 952         ppCons FBGoodConsum = ppChar 'G'
 953         ppCons FBBadConsum  = ppChar 'B'
 954         ppProd FBGoodProd   = ppChar 'G'
 955         ppProd FBBadProd    = ppChar 'B'
 956 \end{code}