ghc/compiler/basicTypes/IdInfo.lhs

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