IdInfo.lhs 29 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
%
\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}

(And a pretty good illustration of quite a few things wrong with
Haskell. [WDP 94/11])

\begin{code}
#include "HsVersions.h"

module IdInfo (
	IdInfo,		-- abstract
	noIdInfo,
	boringIdInfo,
	ppIdInfo,
	applySubstToIdInfo, apply_to_IdInfo,    -- not for general use, please

19
20
	OptIdInfo(..),	-- class; for convenience only
			-- all the *Infos herein are instances of it
21
22

	-- component "id infos"; also abstract:
23
24
25
	SrcLoc,
	getSrcLocIdInfo,

26
27
28
29
30
31
32
	ArityInfo,
	mkArityInfo, unknownArity, arityMaybe,

	DemandInfo,
	mkDemandInfo,
	willBeDemanded,

33
	MatchEnv,		-- the SpecEnv (why is this exported???)
34
35
	StrictnessInfo(..), 	-- non-abstract
	Demand(..),	    	-- non-abstract
36
37
38
39
40
41
42
43
44
45
46
47
48
49

	wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
	indicatesWorker, nonAbsentArgs,
	mkStrictnessInfo, mkBottomStrictnessInfo,
	getWrapperArgTypeCategories,
	getWorkerId,
	workerExists,
	bottomIsGuaranteed,

	mkUnfolding,
	noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus

	UpdateInfo,
	mkUpdateInfo,
50
	SYN_IE(UpdateSpec),
51
52
53
54
	updateInfoMaybe,

	DeforestInfo(..),

55
	ArgUsageInfo,
56
	ArgUsage(..),
57
	SYN_IE(ArgUsageType),
58
59
60
61
62
63
64
65
	mkArgUsageInfo,
	getArgUsage,

	FBTypeInfo,
	FBType(..),
	FBConsum(..),
	FBProd(..),
	mkFBTypeInfo,
66
67
	getFBType

68
69
    ) where

70
IMP_Ubiq()
71
IMPORT_1_3(Char(toLower))
72

73
IMPORT_DELOOPER(IdLoop)	-- IdInfo is a dependency-loop ranch, and
74
75
76
77
78
79
			-- we break those loops by using IdLoop and
			-- *not* importing much of anything else,
			-- except from the very general "utils".

import CmdLineOpts	( opt_OmitInterfacePragmas )
import Maybes		( firstJust )
80
import MatchEnv		( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
81
82
import Outputable	( ifPprInterface, Outputable(..){-instances-} )
import PprStyle		( PprStyle(..) )
83
import Pretty
84
import SrcLoc		( mkUnknownSrcLoc )
85
import Type		( eqSimpleTy, splitFunTyExpandingDicts )
86
import Unique		( pprUnique )
87
88
import Util		( mapAccumL, panic, assertPanic, pprPanic )

89
90
91
92
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
#endif

93
94
95
96
97
applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
mkFormSummary = panic "IdInfo.mkFormSummary"
isWrapperFor = panic "IdInfo.isWrapperFor"
pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
\end{code}

An @IdInfo@ gives {\em optional} information about an @Id@.  If
present it never lies, but it may not be present, in which case there
is always a conservative assumption which can be made.

Two @Id@s may have different info even though they have the same
@Unique@ (and are hence the same @Id@); for example, one might lack
the properties attached to the other.

The @IdInfo@ gives information about the value, or definition, of the
@Id@.  It does {\em not} contain information about the @Id@'s usage
(except for @DemandInfo@? ToDo).

\begin{code}
data IdInfo
  = IdInfo
	ArityInfo		-- Its arity

	DemandInfo		-- Whether or not it is definitely
				-- demanded

120
121
122
123
	(MatchEnv [Type] CoreExpr)
				-- Specialisations of this function which exist
				-- This corresponds to a SpecEnv which we do
				-- not import directly to avoid loop
124
125
126
127
128
129
130
131
132

	StrictnessInfo		-- Strictness properties, notably
				-- how to conjure up "worker" functions

	UnfoldingDetails	-- Its unfolding; for locally-defined
				-- things, this can *only* be NoUnfoldingDetails

	UpdateInfo		-- Which args should be updated

133
134
	DeforestInfo            -- Whether its definition should be
				-- unfolded during deforestation
135
136
137
138
139
140
141
142
143
144

	ArgUsageInfo		-- how this Id uses its arguments

	FBTypeInfo		-- the Foldr/Build W/W property of this function.

	SrcLoc			-- Source location of definition

	-- ToDo: SrcLoc is in FullNames too (could rm?)  but it
	-- is needed here too for things like ConstMethodIds and the
	-- like, which don't have full-names of their own Mind you,
145
	-- perhaps the Name for a constant method could give the
146
147
148
149
150
151
152
	-- class/type involved?
\end{code}

\begin{code}
noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
		  noInfo noInfo noInfo noInfo mkUnknownSrcLoc

153
-- "boring" means: nothing to put in interface
154
155
boringIdInfo (IdInfo UnknownArity
		     UnknownDemand
156
		     specenv
157
158
159
160
161
162
		     strictness
		     unfolding
		     NoUpdateInfo
		     Don'tDeforest
		     _ {- arg_usage: currently no interface effect -}
		     _ {- no f/b w/w -}
163
164
165
166
167
		     _ {- src_loc: no effect on interfaces-}
	      )
	      |  null (mEnvToList specenv)
	      && boring_strictness strictness
	      && boring_unfolding unfolding
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
  = True
  where
    boring_strictness NoStrictnessInfo = True
    boring_strictness BottomGuaranteed = False
    boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args

    boring_unfolding NoUnfoldingDetails = True
    boring_unfolding _	    	    	= False

boringIdInfo _ = False

pp_NONE = ppPStr SLIT("_N_")
\end{code}

Simply turgid.  But BE CAREFUL: don't @apply_to_Id@ if that @Id@
will in turn @apply_to_IdInfo@ of the self-same @IdInfo@.  (A very
nasty loop, friends...)
\begin{code}
186
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
187
			      update deforest arg_usage fb_ww srcloc)
188
189
190
  | isEmptyMEnv spec
  = idinfo
  | otherwise
191
192
193
  = panic "IdInfo:apply_to_IdInfo"
{- LATER:
    let
194
195
	new_spec = apply_spec spec

196
	-- NOT a good idea:
197
198
199
	--   apply_strict strictness 	`thenLft` \ new_strict ->
	--   apply_wrap wrap 		`thenLft` \ new_wrap ->
    in
200
    IdInfo arity demand new_spec strictness unfold
201
202
203
204
205
206
207
208
209
210
211
	   update deforest arg_usage fb_ww srcloc
  where
    apply_spec (SpecEnv is)
      = SpecEnv (map do_one is)
      where
    	do_one (SpecInfo ty_maybes ds spec_id)
	  = --apply_to_Id ty_fn spec_id	`thenLft` \ new_spec_id ->
	    SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
	  where
	    apply_to_maybe Nothing   = Nothing
	    apply_to_maybe (Just ty) = Just (ty_fn ty)
212
-}
213
214
215
216
217
218
219
220
221
222

{- NOT a good idea;
    apply_strict info@NoStrictnessInfo = returnLft info
    apply_strict BottomGuaranteed = ???
    apply_strict (StrictnessInfo wrap_arg_info id_maybe)
      = (case id_maybe of
	   Nothing -> returnLft Nothing
	   Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
		      returnLft (Just new_xx)
	) `thenLft` \ new_id_maybe ->
223
	returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
224
225
226
227
228
-}
\end{code}

Variant of the same thing for the typechecker.
\begin{code}
229
230
231
232
233
applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
			      update deforest arg_usage fb_ww srcloc)
  = panic "IdInfo:applySubstToIdInfo"
{- LATER:
    case (apply_spec s0 spec) of { (s1, new_spec) ->
234
235
236
237
    (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
  where
    apply_spec s0 (SpecEnv is)
      = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
238
	(s1, SpecEnv new_is) }
239
240
241
242
243
244
245
246
247
      where
    	do_one s0 (SpecInfo ty_maybes ds spec_id)
	  = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
	    (s1, SpecInfo new_maybes ds spec_id) }
	  where
	    apply_to_maybe s0 Nothing   = (s0, Nothing)
	    apply_to_maybe s0 (Just ty)
	      = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
		(s1, Just new_ty) }
248
-}
249
250
251
252
253
254
255
256
257
258
259
260
261
\end{code}

\begin{code}
ppIdInfo :: PprStyle
	 -> Id		-- The Id for which we're printing this IdInfo
	 -> Bool	-- True <=> print specialisations, please
	 -> (Id -> Id)	-- to look up "better Ids" w/ better IdInfos;
	 -> IdEnv UnfoldingDetails
			-- inlining info for top-level fns in this module
	 -> IdInfo	-- see MkIface notes
	 -> Pretty

ppIdInfo sty for_this_id specs_please better_id_fn inline_env
262
    i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
263
264
265
266
267
268
269
270
271
272
  | boringIdInfo i
  = ppPStr SLIT("_NI_")

  | otherwise
  = let
	stuff = ppCat [
		    -- order is important!:
		    ppInfo sty better_id_fn arity,
		    ppInfo sty better_id_fn update,
		    ppInfo sty better_id_fn deforest,
273

274
		    pp_strictness sty (Just for_this_id)
275
						  better_id_fn inline_env strictness,
276
277
278
279
280

		    if bottomIsGuaranteed strictness
		    then pp_NONE
		    else pp_unfolding sty for_this_id inline_env unfold,

281
		    if specs_please
282
283
		    then ppSpecs sty (not (isDataCon for_this_id))
				 better_id_fn inline_env (mEnvToList specenv)
284
285
286
287
288
289
290
291
		    else pp_NONE,

		    -- DemandInfo needn't be printed since it has no effect on interfaces
		    ppInfo sty better_id_fn demand,
		    ppInfo sty better_id_fn fbtype
		]
    in
    case sty of
292
293
294
295
      PprInterface -> if opt_OmitInterfacePragmas
		      then ppNil
		      else stuff
      _		   -> stuff
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
\end{code}

%************************************************************************
%*									*
\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
%*									*
%************************************************************************

\begin{code}
class OptIdInfo a where
    noInfo	:: a
    getInfo	:: IdInfo -> a
    addInfo	:: IdInfo -> a -> IdInfo
		-- By default, "addInfo" will not overwrite
		-- "info" with "non-info"; look at any instance
		-- to see an example.
    ppInfo	:: PprStyle -> (Id -> Id) -> a -> Pretty
\end{code}

%************************************************************************
%*									*
\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
%*									*
%************************************************************************

Not used much, but...
\begin{code}
getSrcLocIdInfo  (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
\end{code}

%************************************************************************
%*									*
\subsection[arity-IdInfo]{Arity info about an @Id@}
%*									*
%************************************************************************

\begin{code}
data ArityInfo
  = UnknownArity	-- no idea
  | ArityExactly Int	-- arity is exactly this
\end{code}

\begin{code}
mkArityInfo  = ArityExactly
unknownArity = UnknownArity

arityMaybe :: ArityInfo -> Maybe Int

arityMaybe UnknownArity	    = Nothing
arityMaybe (ArityExactly i) = Just i
\end{code}

\begin{code}
instance OptIdInfo ArityInfo where
    noInfo = UnknownArity

    getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity

    addInfo id_info UnknownArity = id_info
    addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j

    ppInfo sty _ UnknownArity	      = ifPprInterface sty pp_NONE
    ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
\end{code}

%************************************************************************
%*									*
\subsection[demand-IdInfo]{Demand info about an @Id@}
%*									*
%************************************************************************

Whether a value is certain to be demanded or not.  (This is the
information that is computed by the ``front-end'' of the strictness
analyser.)

This information is only used within a module, it is not exported
(obviously).

\begin{code}
data DemandInfo
  = UnknownDemand
  | DemandedAsPer Demand
\end{code}

\begin{code}
mkDemandInfo :: Demand -> DemandInfo
mkDemandInfo demand = DemandedAsPer demand

willBeDemanded :: DemandInfo -> Bool
385
willBeDemanded (DemandedAsPer demand) = isStrict demand
386
387
388
389
390
391
392
393
394
395
396
willBeDemanded _		      = False
\end{code}

\begin{code}
instance OptIdInfo DemandInfo where
    noInfo = UnknownDemand

    getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand

{-	DELETED!  If this line is in, there is no way to
	nuke a DemandInfo, and we have to be able to do that
397
	when floating let-bindings around
398
399
400
401
    addInfo id_info UnknownDemand = id_info
-}
    addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j

402
    ppInfo PprInterface _ _	      = ppNil
403
404
405
406
407
408
409
410
411
412
413
    ppInfo sty _ UnknownDemand	      = ppStr "{-# L #-}"
    ppInfo sty _ (DemandedAsPer info)
      = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
\end{code}

%************************************************************************
%*									*
\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
%*									*
%************************************************************************

414
See SpecEnv.lhs
415
416

\begin{code}
417
418
instance OptIdInfo (MatchEnv [Type] CoreExpr) where
    noInfo = nullMEnv
419
420
421

    getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec

422
423
    addInfo id_info spec | null (mEnvToList spec) = id_info
    addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
424

425
426
427
428
    ppInfo sty better_id_fn spec
      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)

ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
429
  = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
\end{code}

%************************************************************************
%*									*
\subsection[strictness-IdInfo]{Strictness info about an @Id@}
%*									*
%************************************************************************

We specify the strictness of a function by giving information about
each of the ``wrapper's'' arguments (see the description about
worker/wrapper-style transformations in the PJ/Launchbury paper on
unboxed types).

The list of @Demands@ specifies: (a)~the strictness properties
of a function's arguments; (b)~the {\em existence} of a ``worker''
version of the function; and (c)~the type signature of that worker (if
it exists); i.e. its calling convention.

\begin{code}
data StrictnessInfo
  = NoStrictnessInfo

  | BottomGuaranteed	-- This Id guarantees never to return;
			-- it is bottom regardless of its arguments.
			-- Useful for "error" and other disguised
			-- variants thereof.

  | StrictnessInfo	[Demand]	-- the main stuff; see below.
			(Maybe Id)	-- worker's Id, if applicable.
\end{code}

This type is also actually used in the strictness analyser:
\begin{code}
data Demand
  = WwLazy		-- Argument is lazy as far as we know
	MaybeAbsent	-- (does not imply worker's existence [etc]).
			-- If MaybeAbsent == True, then it is
			-- *definitely* lazy.  (NB: Absence implies
			-- a worker...)

  | WwStrict		-- Argument is strict but that's all we know
			-- (does not imply worker's existence or any
			-- calling-convention magic)

  | WwUnpack		-- Argument is strict & a single-constructor
	[Demand]	-- type; its constituent parts (whose StrictInfos
			-- are in the list) should be passed
			-- as arguments to the worker.

  | WwPrim		-- Argument is of primitive type, therefore
			-- strict; doesn't imply existence of a worker;
			-- argument should be passed as is to worker.

  | WwEnum		-- Argument is strict & an enumeration type;
			-- an Int# representing the tag (start counting
			-- at zero) should be passed to the worker.
  deriving (Eq, Ord)
      -- we need Eq/Ord to cross-chk update infos in interfaces

type MaybeAbsent = Bool -- True <=> not even used

-- versions that don't worry about Absence:
wwLazy	    = WwLazy 	  False
wwStrict    = WwStrict
wwUnpack xs = WwUnpack xs
wwPrim	    = WwPrim
wwEnum	    = WwEnum
\end{code}

\begin{code}
mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo

mkStrictnessInfo [] _    = NoStrictnessInfo
mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr

mkBottomStrictnessInfo = BottomGuaranteed

bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other    	    = False

getWrapperArgTypeCategories
511
	:: Type		-- wrapper's type
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
	-> StrictnessInfo	-- strictness info about its args
	-> Maybe String

getWrapperArgTypeCategories _ NoStrictnessInfo	    = Nothing
getWrapperArgTypeCategories _ BottomGuaranteed
  = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing

getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
  = Just (mkWrapperArgTypeCategories ty arg_info)

workerExists :: StrictnessInfo -> Bool
workerExists (StrictnessInfo _ (Just worker_id)) = True
workerExists other				 = False

getWorkerId :: StrictnessInfo -> Id

getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
#ifdef DEBUG
531
getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
#endif
\end{code}

\begin{code}
isStrict :: Demand -> Bool

isStrict WwStrict	= True
isStrict (WwUnpack _)	= True
isStrict WwPrim		= True
isStrict WwEnum		= True
isStrict _		= False

nonAbsentArgs :: [Demand] -> Int

nonAbsentArgs cmpts
  = foldr tick_non 0 cmpts
  where
    tick_non (WwLazy True) acc = acc
    tick_non other	   acc = acc + 1

all_present_WwLazies :: [Demand] -> Bool
all_present_WwLazies infos
554
  = and (map is_L infos)
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
  where
    is_L (WwLazy False) = True	-- False <=> "Absent" args do *not* count!
    is_L _	        = False	-- (as they imply a worker)
\end{code}

WDP 95/04: It is no longer enough to look at a list of @Demands@ for
an ``Unpack'' or an ``Absent'' and declare a worker.  We also have to
check that @mAX_WORKER_ARGS@ hasn't been exceeded.  Therefore,
@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
in \tr{WwLib.lhs}.  A worker is ``indicated'' when we hit an Unpack
or an Absent {\em that we accept}.
\begin{code}
indicatesWorker :: [Demand] -> Bool

indicatesWorker dems
570
  = fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
571
572
573
574
575
576
577
578
579
580
581
582
583
584
  where
    fake_mk_ww _ [] = False
    fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
    fake_mk_ww extra_args (WwUnpack cmpnts : dems)
      | extra_args_now > 0 = True -- we accepted an Unpack
      where
	extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts

    fake_mk_ww extra_args (_ : dems)
      = fake_mk_ww extra_args dems
\end{code}

\begin{code}
mkWrapperArgTypeCategories
585
	:: Type		-- wrapper's type
586
	-> [Demand]	-- info about its arguments
587
	-> String	-- a string saying lots about the args
588
589

mkWrapperArgTypeCategories wrapper_ty wrap_info
590
591
  = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
    map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
  where
    -- ToDo: this needs FIXING UP (it was a hack anyway...)
    do_one (WwPrim, _) = 'P'
    do_one (WwEnum, _) = 'E'
    do_one (WwStrict, arg_ty_char) = arg_ty_char
    do_one (WwUnpack _, arg_ty_char)
      = if arg_ty_char `elem` "CIJFDTS"
	then toLower arg_ty_char
	else if arg_ty_char == '+' then 't'
	else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
    do_one (other_wrap_info, _) = '-'
\end{code}

Whether a worker exists depends on whether the worker has an
absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.

If a @WwUnpack@ argument is for an {\em abstract} type (or one that
will be abstract outside this module), which might happen for an
imported function, then we can't (or don't want to...) unpack the arg
as the worker requires.  Hence we have to give up altogether, and call
the wrapper only; so under these circumstances we return \tr{False}.

\begin{code}
615
616
617
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
#else
618
instance Text Demand where
619
#endif
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
    readList str = read_em [{-acc-}] str
      where
	read_em acc []		= [(reverse acc, "")]
	-- lower case indicates absence...
	read_em acc ('L' : xs)	= read_em (WwLazy   False : acc) xs
	read_em acc ('A' : xs)	= read_em (WwLazy   True  : acc) xs
	read_em acc ('S' : xs)	= read_em (WwStrict : acc) xs
	read_em acc ('P' : xs)	= read_em (WwPrim : acc) xs
	read_em acc ('E' : xs)	= read_em (WwEnum : acc) xs

	read_em acc (')' : xs)	= [(reverse acc, xs)]
	read_em acc ( 'U'  : '(' : xs)
	  = case (read_em [] xs) of
	      [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
	      _ -> panic ("Text.Demand:"++str++"::"++xs)

	read_em acc other = panic ("IdInfo.readem:"++other)

638
639
640
#ifdef REALLY_HASKELL_1_3
instance Show Demand where
#endif
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
    showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
      where
	show1 (WwLazy False) = "L"
	show1 (WwLazy True)  = "A"
	show1 WwStrict	     = "S"
	show1 WwPrim	     = "P"
	show1 WwEnum	     = "E"
	show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"

instance Outputable Demand where
    ppr sty si = ppStr (showList [si] "")

instance OptIdInfo StrictnessInfo where
    noInfo = NoStrictnessInfo

    getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict

    addInfo id_info NoStrictnessInfo = id_info
    addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j

    ppInfo sty better_id_fn strictness_info
      = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
\end{code}

We'll omit the worker info if the thing has an explicit unfolding
already.
\begin{code}
pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE

pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")

pp_strictness sty for_this_id_maybe better_id_fn inline_env
    info@(StrictnessInfo wrapper_args wrkr_maybe)
  = let
	(have_wrkr, wrkr_id) = case wrkr_maybe of
				 Nothing -> (False, panic "ppInfo(Strictness)")
				 Just xx -> (True,  xx)

	wrkr_to_print   = better_id_fn wrkr_id
	wrkr_info	= getIdInfo   wrkr_to_print

	-- if we aren't going to be able to *read* the strictness info
	-- in TcPragmas, we need not even print it.
	wrapper_args_to_use
	  = if not (indicatesWorker wrapper_args) then
		wrapper_args -- no worker/wrappering in any case
	    else
		case for_this_id_maybe of
		  Nothing -> wrapper_args
		  Just id -> if externallyVisibleId id
			     && (unfoldingUnfriendlyId id || not have_wrkr) then
692
				-- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
693
694
695
696
697
698
699
700
701
				map un_workerise wrapper_args
			     else
				wrapper_args

	id_is_worker
	  = case for_this_id_maybe of
	      Nothing -> False
	      Just id -> isWorkerId id

702
	am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739

	pp_basic_info
	  = ppBesides [ppStr "_S_ \"",
		ppStr (showList wrapper_args_to_use ""), ppStr "\""]

	pp_with_worker
	  = ppBesides [ ppSP, ppChar '{',
			ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
			ppChar '}' ]
    in
    if all_present_WwLazies wrapper_args_to_use then -- too boring
	ifPprInterface sty pp_NONE

    else if id_is_worker && am_printing_iface then
    	pp_NONE -- we don't put worker strictness in interfaces
		-- (it can be deduced)

    else if not (indicatesWorker wrapper_args_to_use)
	 || not have_wrkr
	 || boringIdInfo wrkr_info then
	ppBeside pp_basic_info ppNil
    else
	ppBeside pp_basic_info pp_with_worker
  where
    un_workerise (WwLazy   _) = WwLazy False -- avoid absence
    un_workerise (WwUnpack _) = WwStrict
    un_workerise other	      = other
\end{code}

%************************************************************************
%*									*
\subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
%*									*
%************************************************************************

\begin{code}
mkUnfolding guide expr
740
  = GenForm (mkFormSummary NoStrictnessInfo expr)
741
	(occurAnalyseGlobalExpr expr)
742
743
744
745
746
747
	guide
\end{code}

\begin{code}
noInfo_UF = NoUnfoldingDetails

748
749
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
  = case unfolding of
750
751
      GenForm _ _ BadUnfolding -> NoUnfoldingDetails
      unfolding_as_was 	       -> unfolding_as_was
752
753
754
755

-- getInfo_UF ensures that any BadUnfoldings are never returned
-- We had to delay the test required in TcPragmas until now due
-- to strictness constraints in TcPragmas
756
757

addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
758
addInfo_UF   (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
759
760
761
762
763
764
765
766
767
768
769
\end{code}

\begin{code}
pp_unfolding sty for_this_id inline_env uf_details
  = case (lookupIdEnv inline_env for_this_id) of
      Nothing -> pp uf_details
      Just dt -> pp dt
  where
    pp NoUnfoldingDetails = pp_NONE

    pp (MagicForm tag _)
770
      = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
771

772
    pp (GenForm _ _ BadUnfolding) = pp_NONE
773

774
    pp (GenForm _ template guide)
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
      = let
	    untagged = unTagBinders template
	in
    	if untagged `isWrapperFor` for_this_id
	then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
	     pp_NONE
	else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]

\end{code}

%************************************************************************
%*									*
\subsection[update-IdInfo]{Update-analysis info about an @Id@}
%*									*
%************************************************************************

\begin{code}
data UpdateInfo
  = NoUpdateInfo
  | SomeUpdateInfo UpdateSpec
  deriving (Eq, Ord)
      -- we need Eq/Ord to cross-chk update infos in interfaces

-- the form in which we pass update-analysis info between modules:
type UpdateSpec = [Int]
\end{code}

\begin{code}
mkUpdateInfo = SomeUpdateInfo

updateInfoMaybe NoUpdateInfo	    = Nothing
updateInfoMaybe (SomeUpdateInfo []) = Nothing
updateInfoMaybe (SomeUpdateInfo	 u) = Just u
\end{code}

Text instance so that the update annotations can be read in.

\begin{code}
813
814
815
#ifdef REALLY_HASKELL_1_3
instance Read UpdateInfo where
#else
816
instance Text UpdateInfo where
817
#endif
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
    readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
		  | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
      where
	ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
		   | otherwise = panic "IdInfo: not a digit while reading update pragma"

instance OptIdInfo UpdateInfo where
    noInfo = NoUpdateInfo

    getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update

    addInfo id_info NoUpdateInfo = id_info
    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

    ppInfo sty better_id_fn NoUpdateInfo	= ifPprInterface sty pp_NONE
    ppInfo sty better_id_fn (SomeUpdateInfo [])	= ifPprInterface sty pp_NONE
    ppInfo sty better_id_fn (SomeUpdateInfo spec)
      = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
\end{code}

%************************************************************************
%*                                                                    *
\subsection[deforest-IdInfo]{Deforestation info about an @Id@}
%*                                                                    *
%************************************************************************

The deforest info says whether this Id is to be unfolded during
deforestation.  Therefore, when the deforest pragma is true, we must
also have the unfolding information available for this Id.

\begin{code}
data DeforestInfo
  = Don'tDeforest                     -- just a bool, might extend this
  | DoDeforest                                -- later.
  -- deriving (Eq, Ord)
\end{code}

\begin{code}
instance OptIdInfo DeforestInfo where
    noInfo = Don'tDeforest

    getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest

    addInfo id_info Don'tDeforest = id_info
862
    addInfo (IdInfo a b d e f g _ h i j) deforest =
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
    	IdInfo a b d e f g deforest h i j

    ppInfo sty better_id_fn Don'tDeforest
      = ifPprInterface sty pp_NONE
    ppInfo sty better_id_fn DoDeforest
      = ppPStr SLIT("_DEFOREST_")
\end{code}

%************************************************************************
%*									*
\subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
%*									*
%************************************************************************

\begin{code}
data ArgUsageInfo
  = NoArgUsageInfo
  | SomeArgUsageInfo ArgUsageType
  -- ??? deriving (Eq, Ord)

data ArgUsage = ArgUsage Int	-- number of arguments (is linear!)
	      | UnknownArgUsage
type ArgUsageType  = [ArgUsage]		-- c_1 -> ... -> BLOB
\end{code}

\begin{code}
mkArgUsageInfo = SomeArgUsageInfo

getArgUsage :: ArgUsageInfo -> ArgUsageType
getArgUsage NoArgUsageInfo	    = []
getArgUsage (SomeArgUsageInfo u)  = u
\end{code}

\begin{code}
instance OptIdInfo ArgUsageInfo where
    noInfo = NoArgUsageInfo

    getInfo (IdInfo _ _ _ _ _  _ _ au _ _) = au

    addInfo id_info NoArgUsageInfo = id_info
    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

905
906
    ppInfo sty better_id_fn NoArgUsageInfo		= ifPprInterface sty pp_NONE
    ppInfo sty better_id_fn (SomeArgUsageInfo [])	= ifPprInterface sty pp_NONE
907
908
909
910
911
912
913
    ppInfo sty better_id_fn (SomeArgUsageInfo aut)
      = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)


ppArgUsage (ArgUsage n)      = ppInt n
ppArgUsage (UnknownArgUsage) = ppChar '-'

914
ppArgUsageType aut = ppBesides
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
	[ ppChar '"' ,
	  ppIntersperse ppComma (map ppArgUsage aut),
	  ppChar '"' ]
\end{code}
%************************************************************************
%*									*
\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
%*									*
%************************************************************************

\begin{code}
data FBTypeInfo
  = NoFBTypeInfo
  | SomeFBTypeInfo FBType
  -- ??? deriving (Eq, Ord)

data FBType = FBType [FBConsum] FBProd deriving (Eq)

data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
data FBProd = FBGoodProd | FBBadProd deriving(Eq)
\end{code}

\begin{code}
mkFBTypeInfo = SomeFBTypeInfo

getFBType :: FBTypeInfo -> Maybe FBType
getFBType NoFBTypeInfo	      = Nothing
getFBType (SomeFBTypeInfo u)  = Just u
\end{code}

\begin{code}
instance OptIdInfo FBTypeInfo where
    noInfo = NoFBTypeInfo

    getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb

    addInfo id_info NoFBTypeInfo = id_info
    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

954
955
956
    ppInfo PprInterface _ NoFBTypeInfo = ppNil
    ppInfo sty 		_ NoFBTypeInfo = ifPprInterface sty pp_NONE
    ppInfo sty 		_ (SomeFBTypeInfo (FBType cons prod))
957
958
959
960
961
962
      = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)

--ppFBType (FBType n)      = ppBesides [ppInt n]
--ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
--

963
ppFBType cons prod = ppBesides
964
965
966
967
968
969
970
	([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
  where
	ppCons FBGoodConsum = ppChar 'G'
	ppCons FBBadConsum  = ppChar 'B'
	ppProd FBGoodProd   = ppChar 'G'
	ppProd FBBadProd    = ppChar 'B'
\end{code}