2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
6 (And a pretty good illustration of quite a few things wrong with
10 #include "HsVersions.h"
17 applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please
19 OptIdInfo(..), -- class; for convenience only
20 -- all the *Infos herein are instances of it
22 -- component "id infos"; also abstract:
27 mkArityInfo, unknownArity, arityMaybe,
33 MatchEnv, -- the SpecEnv
34 StrictnessInfo(..), -- non-abstract
35 Demand(..), -- non-abstract
37 wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
38 indicatesWorker, nonAbsentArgs,
39 mkStrictnessInfo, mkBottomStrictnessInfo,
40 getWrapperArgTypeCategories,
46 noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
72 import 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".
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(..) )
83 import SrcLoc ( mkUnknownSrcLoc )
84 import Type ( eqSimpleTy )
85 import Util ( mapAccumL, panic, assertPanic, pprPanic )
87 applySubstToTy = panic "IdInfo.applySubstToTy"
88 splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
89 showTypeCategory = panic "IdInfo.showTypeCategory"
90 mkFormSummary = panic "IdInfo.mkFormSummary"
91 occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
92 isWrapperFor = panic "IdInfo.isWrapperFor"
93 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
96 An @IdInfo@ gives {\em optional} information about an @Id@. If
97 present it never lies, but it may not be present, in which case there
98 is always a conservative assumption which can be made.
100 Two @Id@s may have different info even though they have the same
101 @Unique@ (and are hence the same @Id@); for example, one might lack
102 the properties attached to the other.
104 The @IdInfo@ gives information about the value, or definition, of the
105 @Id@. It does {\em not} contain information about the @Id@'s usage
106 (except for @DemandInfo@? ToDo).
111 ArityInfo -- Its arity
113 DemandInfo -- Whether or not it is definitely
116 (MatchEnv [Type] CoreExpr)
117 -- Specialisations of this function which exist
118 -- This corresponds to a SpecEnv which we do
119 -- not import directly to avoid loop
121 StrictnessInfo -- Strictness properties, notably
122 -- how to conjure up "worker" functions
124 UnfoldingDetails -- Its unfolding; for locally-defined
125 -- things, this can *only* be NoUnfoldingDetails
127 UpdateInfo -- Which args should be updated
129 DeforestInfo -- Whether its definition should be
130 -- unfolded during deforestation
132 ArgUsageInfo -- how this Id uses its arguments
134 FBTypeInfo -- the Foldr/Build W/W property of this function.
136 SrcLoc -- Source location of definition
138 -- ToDo: SrcLoc is in FullNames too (could rm?) but it
139 -- is needed here too for things like ConstMethodIds and the
140 -- like, which don't have full-names of their own Mind you,
141 -- perhaps the Name for a constant method could give the
142 -- class/type involved?
146 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
147 noInfo noInfo noInfo noInfo mkUnknownSrcLoc
149 -- "boring" means: nothing to put in interface
150 boringIdInfo (IdInfo UnknownArity
157 _ {- arg_usage: currently no interface effect -}
159 _ {- src_loc: no effect on interfaces-}
161 | null (mEnvToList specenv)
162 && boring_strictness strictness
163 && boring_unfolding unfolding
166 boring_strictness NoStrictnessInfo = True
167 boring_strictness BottomGuaranteed = False
168 boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
170 boring_unfolding NoUnfoldingDetails = True
171 boring_unfolding _ = False
173 boringIdInfo _ = False
175 pp_NONE = ppPStr SLIT("_N_")
178 Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
179 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very
180 nasty loop, friends...)
182 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
183 update deforest arg_usage fb_ww srcloc)
187 = panic "IdInfo:apply_to_IdInfo"
190 new_spec = apply_spec spec
193 -- apply_strict strictness `thenLft` \ new_strict ->
194 -- apply_wrap wrap `thenLft` \ new_wrap ->
196 IdInfo arity demand new_spec strictness unfold
197 update deforest arg_usage fb_ww srcloc
199 apply_spec (SpecEnv is)
200 = SpecEnv (map do_one is)
202 do_one (SpecInfo ty_maybes ds spec_id)
203 = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
204 SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
206 apply_to_maybe Nothing = Nothing
207 apply_to_maybe (Just ty) = Just (ty_fn ty)
211 apply_strict info@NoStrictnessInfo = returnLft info
212 apply_strict BottomGuaranteed = ???
213 apply_strict (StrictnessInfo wrap_arg_info id_maybe)
215 Nothing -> returnLft Nothing
216 Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
217 returnLft (Just new_xx)
218 ) `thenLft` \ new_id_maybe ->
219 returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
223 Variant of the same thing for the typechecker.
225 applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
226 update deforest arg_usage fb_ww srcloc)
227 = panic "IdInfo:applySubstToIdInfo"
229 case (apply_spec s0 spec) of { (s1, new_spec) ->
230 (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
232 apply_spec s0 (SpecEnv is)
233 = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
234 (s1, SpecEnv new_is) }
236 do_one s0 (SpecInfo ty_maybes ds spec_id)
237 = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
238 (s1, SpecInfo new_maybes ds spec_id) }
240 apply_to_maybe s0 Nothing = (s0, Nothing)
241 apply_to_maybe s0 (Just ty)
242 = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
249 -> Id -- The Id for which we're printing this IdInfo
250 -> Bool -- True <=> print specialisations, please
251 -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos;
252 -> IdEnv UnfoldingDetails
253 -- inlining info for top-level fns in this module
254 -> IdInfo -- see MkIface notes
257 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
258 i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
260 = ppPStr SLIT("_NI_")
265 -- order is important!:
266 ppInfo sty better_id_fn arity,
267 ppInfo sty better_id_fn update,
268 ppInfo sty better_id_fn deforest,
270 pp_strictness sty (Just for_this_id)
271 better_id_fn inline_env strictness,
273 if bottomIsGuaranteed strictness
275 else pp_unfolding sty for_this_id inline_env unfold,
278 then ppSpecs sty (not (isDataCon for_this_id))
279 better_id_fn inline_env (mEnvToList specenv)
282 -- DemandInfo needn't be printed since it has no effect on interfaces
283 ppInfo sty better_id_fn demand,
284 ppInfo sty better_id_fn fbtype
288 PprInterface -> if opt_OmitInterfacePragmas
294 %************************************************************************
296 \subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
298 %************************************************************************
301 class OptIdInfo a where
303 getInfo :: IdInfo -> a
304 addInfo :: IdInfo -> a -> IdInfo
305 -- By default, "addInfo" will not overwrite
306 -- "info" with "non-info"; look at any instance
307 -- to see an example.
308 ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty
311 %************************************************************************
313 \subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
315 %************************************************************************
317 Not used much, but...
319 getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
322 %************************************************************************
324 \subsection[arity-IdInfo]{Arity info about an @Id@}
326 %************************************************************************
330 = UnknownArity -- no idea
331 | ArityExactly Int -- arity is exactly this
335 mkArityInfo = ArityExactly
336 unknownArity = UnknownArity
338 arityMaybe :: ArityInfo -> Maybe Int
340 arityMaybe UnknownArity = Nothing
341 arityMaybe (ArityExactly i) = Just i
345 instance OptIdInfo ArityInfo where
346 noInfo = UnknownArity
348 getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
350 addInfo id_info UnknownArity = id_info
351 addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
353 ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE
354 ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
357 %************************************************************************
359 \subsection[demand-IdInfo]{Demand info about an @Id@}
361 %************************************************************************
363 Whether a value is certain to be demanded or not. (This is the
364 information that is computed by the ``front-end'' of the strictness
367 This information is only used within a module, it is not exported
373 | DemandedAsPer Demand
377 mkDemandInfo :: Demand -> DemandInfo
378 mkDemandInfo demand = DemandedAsPer demand
380 willBeDemanded :: DemandInfo -> Bool
381 willBeDemanded (DemandedAsPer demand) = isStrict demand
382 willBeDemanded _ = False
386 instance OptIdInfo DemandInfo where
387 noInfo = UnknownDemand
389 getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
391 {- DELETED! If this line is in, there is no way to
392 nuke a DemandInfo, and we have to be able to do that
393 when floating let-bindings around
394 addInfo id_info UnknownDemand = id_info
396 addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
398 ppInfo PprInterface _ _ = ppNil
399 ppInfo sty _ UnknownDemand = ppStr "{-# L #-}"
400 ppInfo sty _ (DemandedAsPer info)
401 = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
404 %************************************************************************
406 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
408 %************************************************************************
413 instance OptIdInfo (MatchEnv [Type] CoreExpr) where
416 getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
418 addInfo id_info spec | null (mEnvToList spec) = id_info
419 addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
421 ppInfo sty better_id_fn spec
422 = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
424 ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
425 = panic "IdInfo:ppSpecs"
428 %************************************************************************
430 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
432 %************************************************************************
434 We specify the strictness of a function by giving information about
435 each of the ``wrapper's'' arguments (see the description about
436 worker/wrapper-style transformations in the PJ/Launchbury paper on
439 The list of @Demands@ specifies: (a)~the strictness properties
440 of a function's arguments; (b)~the {\em existence} of a ``worker''
441 version of the function; and (c)~the type signature of that worker (if
442 it exists); i.e. its calling convention.
448 | BottomGuaranteed -- This Id guarantees never to return;
449 -- it is bottom regardless of its arguments.
450 -- Useful for "error" and other disguised
453 | StrictnessInfo [Demand] -- the main stuff; see below.
454 (Maybe Id) -- worker's Id, if applicable.
457 This type is also actually used in the strictness analyser:
460 = WwLazy -- Argument is lazy as far as we know
461 MaybeAbsent -- (does not imply worker's existence [etc]).
462 -- If MaybeAbsent == True, then it is
463 -- *definitely* lazy. (NB: Absence implies
466 | WwStrict -- Argument is strict but that's all we know
467 -- (does not imply worker's existence or any
468 -- calling-convention magic)
470 | WwUnpack -- Argument is strict & a single-constructor
471 [Demand] -- type; its constituent parts (whose StrictInfos
472 -- are in the list) should be passed
473 -- as arguments to the worker.
475 | WwPrim -- Argument is of primitive type, therefore
476 -- strict; doesn't imply existence of a worker;
477 -- argument should be passed as is to worker.
479 | WwEnum -- Argument is strict & an enumeration type;
480 -- an Int# representing the tag (start counting
481 -- at zero) should be passed to the worker.
483 -- we need Eq/Ord to cross-chk update infos in interfaces
485 type MaybeAbsent = Bool -- True <=> not even used
487 -- versions that don't worry about Absence:
488 wwLazy = WwLazy False
490 wwUnpack xs = WwUnpack xs
496 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
498 mkStrictnessInfo [] _ = NoStrictnessInfo
499 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
501 mkBottomStrictnessInfo = BottomGuaranteed
503 bottomIsGuaranteed BottomGuaranteed = True
504 bottomIsGuaranteed other = False
506 getWrapperArgTypeCategories
507 :: Type -- wrapper's type
508 -> StrictnessInfo -- strictness info about its args
511 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
512 getWrapperArgTypeCategories _ BottomGuaranteed
513 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
514 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
516 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
517 = Just (mkWrapperArgTypeCategories ty arg_info)
519 workerExists :: StrictnessInfo -> Bool
520 workerExists (StrictnessInfo _ (Just worker_id)) = True
521 workerExists other = False
523 getWorkerId :: StrictnessInfo -> Id
525 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
527 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
532 isStrict :: Demand -> Bool
534 isStrict WwStrict = True
535 isStrict (WwUnpack _) = True
536 isStrict WwPrim = True
537 isStrict WwEnum = True
540 nonAbsentArgs :: [Demand] -> Int
543 = foldr tick_non 0 cmpts
545 tick_non (WwLazy True) acc = acc
546 tick_non other acc = acc + 1
548 all_present_WwLazies :: [Demand] -> Bool
549 all_present_WwLazies infos
550 = and (map is_L infos)
552 is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count!
553 is_L _ = False -- (as they imply a worker)
556 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
557 an ``Unpack'' or an ``Absent'' and declare a worker. We also have to
558 check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore,
559 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
560 in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack
561 or an Absent {\em that we accept}.
563 indicatesWorker :: [Demand] -> Bool
566 = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
568 fake_mk_ww _ [] = False
569 fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
570 fake_mk_ww extra_args (WwUnpack cmpnts : dems)
571 | extra_args_now > 0 = True -- we accepted an Unpack
573 extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
575 fake_mk_ww extra_args (_ : dems)
576 = fake_mk_ww extra_args dems
580 mkWrapperArgTypeCategories
581 :: Type -- wrapper's type
582 -> [Demand] -- info about its arguments
583 -> String -- a string saying lots about the args
585 mkWrapperArgTypeCategories wrapper_ty wrap_info
586 = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
587 map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
590 -- ToDo: this needs FIXING UP (it was a hack anyway...)
591 do_one (WwPrim, _) = 'P'
592 do_one (WwEnum, _) = 'E'
593 do_one (WwStrict, arg_ty_char) = arg_ty_char
594 do_one (WwUnpack _, arg_ty_char)
595 = if arg_ty_char `elem` "CIJFDTS"
596 then toLower arg_ty_char
597 else if arg_ty_char == '+' then 't'
598 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
599 do_one (other_wrap_info, _) = '-'
602 Whether a worker exists depends on whether the worker has an
603 absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
605 If a @WwUnpack@ argument is for an {\em abstract} type (or one that
606 will be abstract outside this module), which might happen for an
607 imported function, then we can't (or don't want to...) unpack the arg
608 as the worker requires. Hence we have to give up altogether, and call
609 the wrapper only; so under these circumstances we return \tr{False}.
612 instance Text Demand where
613 readList str = read_em [{-acc-}] str
615 read_em acc [] = [(reverse acc, "")]
616 -- lower case indicates absence...
617 read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
618 read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
619 read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
620 read_em acc ('P' : xs) = read_em (WwPrim : acc) xs
621 read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
623 read_em acc (')' : xs) = [(reverse acc, xs)]
624 read_em acc ( 'U' : '(' : xs)
625 = case (read_em [] xs) of
626 [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
627 _ -> panic ("Text.Demand:"++str++"::"++xs)
629 read_em acc other = panic ("IdInfo.readem:"++other)
631 showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
633 show1 (WwLazy False) = "L"
634 show1 (WwLazy True) = "A"
638 show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
640 instance Outputable Demand where
641 ppr sty si = ppStr (showList [si] "")
643 instance OptIdInfo StrictnessInfo where
644 noInfo = NoStrictnessInfo
646 getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
648 addInfo id_info NoStrictnessInfo = id_info
649 addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
651 ppInfo sty better_id_fn strictness_info
652 = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
655 We'll omit the worker info if the thing has an explicit unfolding
658 pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
660 pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
662 pp_strictness sty for_this_id_maybe better_id_fn inline_env
663 info@(StrictnessInfo wrapper_args wrkr_maybe)
665 (have_wrkr, wrkr_id) = case wrkr_maybe of
666 Nothing -> (False, panic "ppInfo(Strictness)")
667 Just xx -> (True, xx)
669 wrkr_to_print = better_id_fn wrkr_id
670 wrkr_info = getIdInfo wrkr_to_print
672 -- if we aren't going to be able to *read* the strictness info
673 -- in TcPragmas, we need not even print it.
675 = if not (indicatesWorker wrapper_args) then
676 wrapper_args -- no worker/wrappering in any case
678 case for_this_id_maybe of
679 Nothing -> wrapper_args
680 Just id -> if externallyVisibleId id
681 && (unfoldingUnfriendlyId id || not have_wrkr) then
682 -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
683 map un_workerise wrapper_args
688 = case for_this_id_maybe of
690 Just id -> isWorkerId id
692 am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
695 = ppBesides [ppStr "_S_ \"",
696 ppStr (showList wrapper_args_to_use ""), ppStr "\""]
699 = ppBesides [ ppSP, ppChar '{',
700 ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
703 if all_present_WwLazies wrapper_args_to_use then -- too boring
704 ifPprInterface sty pp_NONE
706 else if id_is_worker && am_printing_iface then
707 pp_NONE -- we don't put worker strictness in interfaces
708 -- (it can be deduced)
710 else if not (indicatesWorker wrapper_args_to_use)
712 || boringIdInfo wrkr_info then
713 ppBeside pp_basic_info ppNil
715 ppBeside pp_basic_info pp_with_worker
717 un_workerise (WwLazy _) = WwLazy False -- avoid absence
718 un_workerise (WwUnpack _) = WwStrict
719 un_workerise other = other
722 %************************************************************************
724 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
726 %************************************************************************
729 mkUnfolding guide expr
730 = GenForm False (mkFormSummary NoStrictnessInfo expr)
731 (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
736 noInfo_UF = NoUnfoldingDetails
738 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
740 GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
741 unfolding_as_was -> unfolding_as_was
743 -- getInfo_UF ensures that any BadUnfoldings are never returned
744 -- We had to delay the test required in TcPragmas until now due
745 -- to strictness constraints in TcPragmas
747 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
748 addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
752 pp_unfolding sty for_this_id inline_env uf_details
753 = case (lookupIdEnv inline_env for_this_id) of
754 Nothing -> pp uf_details
757 pp NoUnfoldingDetails = pp_NONE
760 = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
762 pp (GenForm _ _ _ BadUnfolding) = pp_NONE
764 pp (GenForm _ _ template guide)
766 untagged = unTagBinders template
768 if untagged `isWrapperFor` for_this_id
769 then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
771 else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
775 %************************************************************************
777 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
779 %************************************************************************
784 | SomeUpdateInfo UpdateSpec
786 -- we need Eq/Ord to cross-chk update infos in interfaces
788 -- the form in which we pass update-analysis info between modules:
789 type UpdateSpec = [Int]
793 mkUpdateInfo = SomeUpdateInfo
795 updateInfoMaybe NoUpdateInfo = Nothing
796 updateInfoMaybe (SomeUpdateInfo []) = Nothing
797 updateInfoMaybe (SomeUpdateInfo u) = Just u
800 Text instance so that the update annotations can be read in.
803 instance Text UpdateInfo where
804 readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
805 | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
807 ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
808 | otherwise = panic "IdInfo: not a digit while reading update pragma"
810 instance OptIdInfo UpdateInfo where
811 noInfo = NoUpdateInfo
813 getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
815 addInfo id_info NoUpdateInfo = id_info
816 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
818 ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE
819 ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
820 ppInfo sty better_id_fn (SomeUpdateInfo spec)
821 = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
824 %************************************************************************
826 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
828 %************************************************************************
830 The deforest info says whether this Id is to be unfolded during
831 deforestation. Therefore, when the deforest pragma is true, we must
832 also have the unfolding information available for this Id.
836 = Don'tDeforest -- just a bool, might extend this
837 | DoDeforest -- later.
838 -- deriving (Eq, Ord)
842 instance OptIdInfo DeforestInfo where
843 noInfo = Don'tDeforest
845 getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
847 addInfo id_info Don'tDeforest = id_info
848 addInfo (IdInfo a b d e f g _ h i j) deforest =
849 IdInfo a b d e f g deforest h i j
851 ppInfo sty better_id_fn Don'tDeforest
852 = ifPprInterface sty pp_NONE
853 ppInfo sty better_id_fn DoDeforest
854 = ppPStr SLIT("_DEFOREST_")
857 %************************************************************************
859 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
861 %************************************************************************
866 | SomeArgUsageInfo ArgUsageType
867 -- ??? deriving (Eq, Ord)
869 data ArgUsage = ArgUsage Int -- number of arguments (is linear!)
871 type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB
875 mkArgUsageInfo = SomeArgUsageInfo
877 getArgUsage :: ArgUsageInfo -> ArgUsageType
878 getArgUsage NoArgUsageInfo = []
879 getArgUsage (SomeArgUsageInfo u) = u
883 instance OptIdInfo ArgUsageInfo where
884 noInfo = NoArgUsageInfo
886 getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au
888 addInfo id_info NoArgUsageInfo = id_info
889 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
891 ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
892 ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
893 ppInfo sty better_id_fn (SomeArgUsageInfo aut)
894 = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
897 ppArgUsage (ArgUsage n) = ppInt n
898 ppArgUsage (UnknownArgUsage) = ppChar '-'
900 ppArgUsageType aut = ppBesides
902 ppIntersperse ppComma (map ppArgUsage aut),
905 %************************************************************************
907 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
909 %************************************************************************
914 | SomeFBTypeInfo FBType
915 -- ??? deriving (Eq, Ord)
917 data FBType = FBType [FBConsum] FBProd deriving (Eq)
919 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
920 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
924 mkFBTypeInfo = SomeFBTypeInfo
926 getFBType :: FBTypeInfo -> Maybe FBType
927 getFBType NoFBTypeInfo = Nothing
928 getFBType (SomeFBTypeInfo u) = Just u
932 instance OptIdInfo FBTypeInfo where
933 noInfo = NoFBTypeInfo
935 getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
937 addInfo id_info NoFBTypeInfo = id_info
938 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
940 ppInfo PprInterface _ NoFBTypeInfo = ppNil
941 ppInfo sty _ NoFBTypeInfo = ifPprInterface sty pp_NONE
942 ppInfo sty _ (SomeFBTypeInfo (FBType cons prod))
943 = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
945 --ppFBType (FBType n) = ppBesides [ppInt n]
946 --ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
949 ppFBType cons prod = ppBesides
950 ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
952 ppCons FBGoodConsum = ppChar 'G'
953 ppCons FBBadConsum = ppChar 'B'
954 ppProd FBGoodProd = ppChar 'G'
955 ppProd FBBadProd = ppChar 'B'