ghc/compiler/basicTypes/IdInfo.lhs

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