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