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
  15         noIdInfo,
  16         ppIdInfo,
  17         applySubstToIdInfo, apply_to_IdInfo,    -- not for general use, please
  18
  19         ArityInfo(..),
  20         exactArity, atLeastArity, unknownArity,
  21         arityInfo, addArityInfo, ppArityInfo,
  22
  23         DemandInfo,
  24         noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
  25
  26         StrictnessInfo(..),                             -- Non-abstract
  27         Demand(..), NewOrData,                          -- Non-abstract
  28
  29         getWorkerId_maybe,
  30         workerExists,
  31         mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
  32         strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
  33
  34         unfoldInfo, addUnfoldInfo,
  35
  36         specInfo, addSpecInfo,
  37
  38         UpdateInfo, SYN_IE(UpdateSpec),
  39         mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
  40
  41         DeforestInfo(..),
  42         deforestInfo, ppDeforestInfo, addDeforestInfo,
  43
  44         ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
  45         mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
  46
  47         FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
  48         fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
  49     ) where
  50
  51 IMP_Ubiq()
  52 IMPORT_1_3(Char(toLower))
  53
  54 IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
  55                         -- we break those loops by using IdLoop and
  56                         -- *not* importing much of anything else,
  57                         -- except from the very general "utils".
  58
  59 import Type             ( eqSimpleTy, splitFunTyExpandingDicts )
  60 import BasicTypes       ( NewOrData )
  61 import CmdLineOpts      ( opt_OmitInterfacePragmas )
  62
  63 import Demand
  64 import Maybes           ( firstJust )
  65 import Outputable       ( ifaceStyle, PprStyle(..), Outputable(..){-instances-} )
  66 import Pretty
  67 import PprType          ()
  68 import Unique           ( pprUnique )
  69 import Util             ( mapAccumL, panic, assertPanic, pprPanic )
  70
  71 #ifdef REALLY_HASKELL_1_3
  72 ord = fromEnum :: Char -> Int
  73 #endif
  74
  75 applySubstToTy = panic "IdInfo.applySubstToTy"
  76 showTypeCategory = panic "IdInfo.showTypeCategory"
  77 \end{code}
  78
  79 An @IdInfo@ gives {\em optional} information about an @Id@.  If
  80 present it never lies, but it may not be present, in which case there
  81 is always a conservative assumption which can be made.
  82
  83 Two @Id@s may have different info even though they have the same
  84 @Unique@ (and are hence the same @Id@); for example, one might lack
  85 the properties attached to the other.
  86
  87 The @IdInfo@ gives information about the value, or definition, of the
  88 @Id@.  It does {\em not} contain information about the @Id@'s usage
  89 (except for @DemandInfo@? ToDo).
  90
  91 \begin{code}
  92 data IdInfo
  93   = IdInfo
  94         ArityInfo               -- Its arity
  95
  96         DemandInfo              -- Whether or not it is definitely
  97                                 -- demanded
  98
  99         SpecEnv
 100                                 -- Specialisations of this function which exist
 101
 102         (StrictnessInfo Id)
 103                                 -- Strictness properties, notably
 104                                 -- how to conjure up "worker" functions
 105
 106         Unfolding
 107                                 -- Its unfolding; for locally-defined
 108                                 -- things, this can *only* be NoUnfolding
 109
 110         UpdateInfo              -- Which args should be updated
 111
 112         DeforestInfo            -- Whether its definition should be
 113                                 -- unfolded during deforestation
 114
 115         ArgUsageInfo            -- how this Id uses its arguments
 116
 117         FBTypeInfo              -- the Foldr/Build W/W property of this function.
 118 \end{code}
 119
 120 \begin{code}
 121 noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
 122                   NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo
 123 \end{code}
 124
 125 Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
 126 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
 127 nasty loop, friends...)
 128 \begin{code}
 129 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 130                               update deforest arg_usage fb_ww)
 131   | isNullSpecEnv spec
 132   = idinfo
 133   | otherwise
 134   = panic "IdInfo:apply_to_IdInfo"
 135 {- LATER:
 136     let
 137         new_spec = apply_spec spec
 138
 139         -- NOT a good idea:
 140         --   apply_strict strictness    `thenLft` \ new_strict ->
 141         --   apply_wrap wrap            `thenLft` \ new_wrap ->
 142     in
 143     IdInfo arity demand new_spec strictness unfold
 144            update deforest arg_usage fb_ww
 145   where
 146     apply_spec (SpecEnv is)
 147       = SpecEnv (map do_one is)
 148       where
 149         do_one (SpecInfo ty_maybes ds spec_id)
 150           = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
 151             SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
 152           where
 153             apply_to_maybe Nothing   = Nothing
 154             apply_to_maybe (Just ty) = Just (ty_fn ty)
 155 -}
 156
 157 {- NOT a good idea;
 158     apply_strict info@NoStrictnessInfo = returnLft info
 159     apply_strict BottomGuaranteed = ???
 160     apply_strict (StrictnessInfo wrap_arg_info id_maybe)
 161       = (case id_maybe of
 162            Nothing -> returnLft Nothing
 163            Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
 164                       returnLft (Just new_xx)
 165         ) `thenLft` \ new_id_maybe ->
 166         returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
 167 -}
 168 \end{code}
 169
 170 Variant of the same thing for the typechecker.
 171 \begin{code}
 172 applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
 173                               update deforest arg_usage fb_ww)
 174   = panic "IdInfo:applySubstToIdInfo"
 175 {- LATER:
 176     case (apply_spec s0 spec) of { (s1, new_spec) ->
 177     (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) }
 178   where
 179     apply_spec s0 (SpecEnv is)
 180       = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
 181         (s1, SpecEnv new_is) }
 182       where
 183         do_one s0 (SpecInfo ty_maybes ds spec_id)
 184           = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
 185             (s1, SpecInfo new_maybes ds spec_id) }
 186           where
 187             apply_to_maybe s0 Nothing   = (s0, Nothing)
 188             apply_to_maybe s0 (Just ty)
 189               = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
 190                 (s1, Just new_ty) }
 191 -}
 192 \end{code}
 193
 194 \begin{code}
 195 ppIdInfo :: PprStyle
 196          -> Bool        -- True <=> print specialisations, please
 197          -> IdInfo
 198          -> Doc
 199
 200 ppIdInfo sty specs_please
 201          (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
 202   = hsep [
 203                     -- order is important!:
 204                     ppArityInfo sty arity,
 205                     ppUpdateInfo sty update,
 206                     ppDeforestInfo sty deforest,
 207
 208                     ppStrictnessInfo sty strictness,
 209
 210                     if specs_please
 211                     then empty -- ToDo -- sty (not (isDataCon for_this_id))
 212                                          -- better_id_fn inline_env (mEnvToList specenv)
 213                     else empty,
 214
 215                     -- DemandInfo needn't be printed since it has no effect on interfaces
 216                     ppDemandInfo sty demand,
 217                     ppFBTypeInfo sty fbtype
 218         ]
 219 \end{code}
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsection[arity-IdInfo]{Arity info about an @Id@}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 \begin{code}
 228 data ArityInfo
 229   = UnknownArity        -- No idea
 230   | ArityExactly Int    -- Arity is exactly this
 231   | ArityAtLeast Int    -- Arity is this or greater
 232 \end{code}
 233
 234 \begin{code}
 235 exactArity   = ArityExactly
 236 atLeastArity = ArityAtLeast
 237 unknownArity = UnknownArity
 238
 239 arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
 240
 241 addArityInfo (IdInfo _ a c d e f g h i) arity        = IdInfo arity a c d e f g h i
 242
 243 ppArityInfo sty UnknownArity         = empty
 244 ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
 245 ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
 246 \end{code}
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[demand-IdInfo]{Demand info about an @Id@}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 Whether a value is certain to be demanded or not.  (This is the
 255 information that is computed by the ``front-end'' of the strictness
 256 analyser.)
 257
 258 This information is only used within a module, it is not exported
 259 (obviously).
 260
 261 \begin{code}
 262 data DemandInfo
 263   = UnknownDemand
 264   | DemandedAsPer Demand
 265 \end{code}
 266
 267 \begin{code}
 268 noDemandInfo = UnknownDemand
 269
 270 mkDemandInfo :: Demand -> DemandInfo
 271 mkDemandInfo demand = DemandedAsPer demand
 272
 273 willBeDemanded :: DemandInfo -> Bool
 274 willBeDemanded (DemandedAsPer demand) = isStrict demand
 275 willBeDemanded _                      = False
 276 \end{code}
 277
 278 \begin{code}
 279 demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand
 280
 281 addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
 282
 283 ppDemandInfo PprInterface _           = empty
 284 ppDemandInfo sty UnknownDemand        = text "{-# L #-}"
 285 ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
 286 \end{code}
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 See SpecEnv.lhs
 295
 296 \begin{code}
 297 specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec
 298
 299 addSpecInfo id_info spec | isNullSpecEnv spec = id_info
 300 addSpecInfo (IdInfo a b _ d e f g h i) spec   = IdInfo a b spec d e f g h i
 301 \end{code}
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 We specify the strictness of a function by giving information about
 310 each of the ``wrapper's'' arguments (see the description about
 311 worker/wrapper-style transformations in the PJ/Launchbury paper on
 312 unboxed types).
 313
 314 The list of @Demands@ specifies: (a)~the strictness properties
 315 of a function's arguments; (b)~the {\em existence} of a ``worker''
 316 version of the function; and (c)~the type signature of that worker (if
 317 it exists); i.e. its calling convention.
 318
 319 \begin{code}
 320 data StrictnessInfo bdee
 321   = NoStrictnessInfo
 322
 323   | BottomGuaranteed    -- This Id guarantees never to return;
 324                         -- it is bottom regardless of its arguments.
 325                         -- Useful for "error" and other disguised
 326                         -- variants thereof.
 327
 328   | StrictnessInfo      [Demand]        -- The main stuff; see below.
 329                         (Maybe (bdee,[bdee]))   -- Worker's Id, if applicable, and a list of the constructors
 330                                                 -- mentioned by the wrapper.  This is necessary so that the
 331                                                 -- renamer can slurp them in.  Without this info, the renamer doesn't
 332                                                 -- know which data types to slurp in concretely.  Remember, for
 333                                                 -- strict things we don't put the unfolding in the interface file, to save space.
 334                                                 -- This constructor list allows the renamer to behave much as if the
 335                                                 -- unfolding *was* in the interface file.
 336                                                 --
 337                                                 -- This field might be Nothing even for a strict fn  because the strictness info
 338                                                 -- might say just "SSS" or something; so there's no w/w split.
 339 \end{code}
 340
 341 \begin{code}
 342 mkStrictnessInfo :: [Demand] -> Maybe (bdee,[bdee]) -> StrictnessInfo bdee
 343
 344 mkStrictnessInfo xs wrkr
 345   | all is_lazy xs       = NoStrictnessInfo             -- Uninteresting
 346   | otherwise            = StrictnessInfo xs wrkr
 347   where
 348     is_lazy (WwLazy False) = True       -- NB "Absent" args do *not* count!
 349     is_lazy _              = False      -- (as they imply a worker)
 350
 351 noStrictnessInfo       = NoStrictnessInfo
 352 mkBottomStrictnessInfo = BottomGuaranteed
 353
 354 bottomIsGuaranteed BottomGuaranteed = True
 355 bottomIsGuaranteed other            = False
 356
 357 strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict
 358
 359 addStrictnessInfo id_info                    NoStrictnessInfo = id_info
 360 addStrictnessInfo (IdInfo a b d _ e f g h i) strict           = IdInfo a b d strict e f g h i
 361
 362 ppStrictnessInfo sty NoStrictnessInfo = empty
 363 ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_")
 364
 365 ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
 366   = hsep [ptext SLIT("_S_"), text (showList wrapper_args ""), pp_wrkr]
 367   where
 368     pp_wrkr = case wrkr_maybe of
 369                  Nothing       -> empty
 370                  Just (wrkr,cons) | ifaceStyle sty &&
 371                                     not (null cons) -> pprId sty wrkr <+> braces (hsep (map (pprId sty) cons))
 372                                   | otherwise       -> pprId sty wrkr
 373 \end{code}
 374
 375
 376 \begin{code}
 377 workerExists :: StrictnessInfo bdee -> Bool
 378 workerExists (StrictnessInfo _ (Just worker_id)) = True
 379 workerExists other                               = False
 380
 381 getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee
 382 getWorkerId_maybe (StrictnessInfo _ (Just (wrkr,_))) = Just wrkr
 383 getWorkerId_maybe other                              = Nothing
 384 \end{code}
 385
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding
 395
 396 addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405 \begin{code}
 406 data UpdateInfo
 407   = NoUpdateInfo
 408   | SomeUpdateInfo UpdateSpec
 409   deriving (Eq, Ord)
 410       -- we need Eq/Ord to cross-chk update infos in interfaces
 411
 412 -- the form in which we pass update-analysis info between modules:
 413 type UpdateSpec = [Int]
 414 \end{code}
 415
 416 \begin{code}
 417 mkUpdateInfo = SomeUpdateInfo
 418
 419 updateInfoMaybe NoUpdateInfo        = Nothing
 420 updateInfoMaybe (SomeUpdateInfo []) = Nothing
 421 updateInfoMaybe (SomeUpdateInfo  u) = Just u
 422 \end{code}
 423
 424 Text instance so that the update annotations can be read in.
 425
 426 \begin{code}
 427 #ifdef REALLY_HASKELL_1_3
 428 instance Read UpdateInfo where
 429 #else
 430 instance Text UpdateInfo where
 431 #endif
 432     readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
 433                   | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
 434       where
 435         ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
 436                    | otherwise = panic "IdInfo: not a digit while reading update pragma"
 437
 438 updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update
 439
 440 addUpdateInfo id_info                    NoUpdateInfo = id_info
 441 addUpdateInfo (IdInfo a b d e f _ g h i) upd_info     = IdInfo a b d e f upd_info g h i
 442
 443 ppUpdateInfo sty NoUpdateInfo          = empty
 444 ppUpdateInfo sty (SomeUpdateInfo [])   = empty
 445 ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
 446 \end{code}
 447
 448 %************************************************************************
 449 %*                                                                    *
 450 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
 451 %*                                                                    *
 452 %************************************************************************
 453
 454 The deforest info says whether this Id is to be unfolded during
 455 deforestation.  Therefore, when the deforest pragma is true, we must
 456 also have the unfolding information available for this Id.
 457
 458 \begin{code}
 459 data DeforestInfo
 460   = Don'tDeforest                     -- just a bool, might extend this
 461   | DoDeforest                                -- later.
 462   -- deriving (Eq, Ord)
 463 \end{code}
 464
 465 \begin{code}
 466 deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest
 467
 468 addDeforestInfo id_info                    Don'tDeforest = id_info
 469 addDeforestInfo (IdInfo a b d e f g _ h i) deforest      = IdInfo a b d e f g deforest h i
 470
 471 ppDeforestInfo sty Don'tDeforest = empty
 472 ppDeforestInfo sty DoDeforest    = ptext SLIT("_DEFOREST_")
 473 \end{code}
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 data ArgUsageInfo
 483   = NoArgUsageInfo
 484   | SomeArgUsageInfo ArgUsageType
 485   -- ??? deriving (Eq, Ord)
 486
 487 data ArgUsage = ArgUsage Int    -- number of arguments (is linear!)
 488               | UnknownArgUsage
 489 type ArgUsageType  = [ArgUsage]         -- c_1 -> ... -> BLOB
 490 \end{code}
 491
 492 \begin{code}
 493 mkArgUsageInfo [] = NoArgUsageInfo
 494 mkArgUsageInfo au = SomeArgUsageInfo au
 495
 496 getArgUsage :: ArgUsageInfo -> ArgUsageType
 497 getArgUsage NoArgUsageInfo        = []
 498 getArgUsage (SomeArgUsageInfo u)  = u
 499 \end{code}
 500
 501 \begin{code}
 502 argUsageInfo (IdInfo _ _ _ _ _  _ _ au _) = au
 503
 504 addArgUsageInfo id_info                    NoArgUsageInfo = id_info
 505 addArgUsageInfo (IdInfo a b d e f g h _ i) au_info        = IdInfo a b d e f g h au_info i
 506
 507 ppArgUsageInfo sty NoArgUsageInfo         = empty
 508 ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
 509
 510 ppArgUsage (ArgUsage n)      = int n
 511 ppArgUsage (UnknownArgUsage) = char '-'
 512
 513 ppArgUsageType aut = hcat
 514         [ char '"' ,
 515           hcat (punctuate comma (map ppArgUsage aut)),
 516           char '"' ]
 517 \end{code}
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525 \begin{code}
 526 data FBTypeInfo
 527   = NoFBTypeInfo
 528   | SomeFBTypeInfo FBType
 529
 530 data FBType = FBType [FBConsum] FBProd deriving (Eq)
 531
 532 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
 533 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
 534 \end{code}
 535
 536 \begin{code}
 537 mkFBTypeInfo = SomeFBTypeInfo
 538
 539 getFBType :: FBTypeInfo -> Maybe FBType
 540 getFBType NoFBTypeInfo        = Nothing
 541 getFBType (SomeFBTypeInfo u)  = Just u
 542 \end{code}
 543
 544 \begin{code}
 545 fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb
 546
 547 addFBTypeInfo id_info NoFBTypeInfo = id_info
 548 addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
 549
 550 ppFBTypeInfo sty NoFBTypeInfo = empty
 551 ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
 552       = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
 553
 554 ppFBType cons prod = hcat
 555         ([ char '"' ] ++ map ppCons cons ++ [ char '-', ppProd prod, char '"' ])
 556   where
 557         ppCons FBGoodConsum = char 'G'
 558         ppCons FBBadConsum  = char 'B'
 559         ppProd FBGoodProd   = char 'G'
 560         ppProd FBBadProd    = char 'B'
 561 \end{code}