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