2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
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, really
20 -- all the *Infos herein are instances of it
22 -- component "id infos"; also abstract:
24 mkArityInfo, unknownArity, arityMaybe,
30 SpecEnv, SpecInfo(..),
31 nullSpecEnv, mkSpecEnv, addOneToSpecEnv,
32 lookupSpecId, lookupSpecEnv, lookupConstMethodId,
37 StrictnessInfo(..), -- non-abstract
38 Demand(..), -- non-abstract
39 wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
40 --UNUSED: isStrict, absentArg,
41 indicatesWorker, nonAbsentArgs,
42 mkStrictnessInfo, mkBottomStrictnessInfo,
43 getWrapperArgTypeCategories,
48 UnfoldingDetails(..), -- non-abstract! re-exported
49 UnfoldingGuidance(..), -- non-abstract; ditto
51 iWantToBeINLINEd, mkMagicUnfolding,
52 noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
74 -- and to make the interface self-sufficient...
75 Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id,
76 IdEnv(..), UniqFM, Unique, IdVal, FormSummary,
77 InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..),
78 SimplifiableBinder(..), SimplifiableCoreExpr(..),
79 PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..),
80 PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..),
83 -- and to make sure pragmas work...
84 IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc)
87 IMPORT_Trace -- ToDo: rm (debugging)
89 import AbsPrel ( mkFunTy, nilDataCon{-HACK-}
90 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
91 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
94 import Bag ( emptyBag, Bag )
95 import CmdLineOpts ( GlobalSwitch(..) )
96 import Id ( getIdUniType, getIdInfo,
97 getDataConSig, getInstantiatedDataConSig,
98 externallyVisibleId, isDataCon,
99 unfoldingUnfriendlyId, isWorkerId,
100 isWrapperId, DataCon(..)
101 IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId)
102 IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
104 import IdEnv -- ( nullIdEnv, lookupIdEnv )
105 import Inst ( apply_to_Inst, applySubstToInst, Inst )
111 import SimplEnv -- UnfoldingDetails(..), UnfoldingGuidance(..)
113 import Subst ( applySubstToTy, Subst )
114 import OccurAnal ( occurAnalyseGlobalExpr )
115 import TaggedCore -- SimplifiableCore* ...
118 import WwLib ( mAX_WORKER_ARGS )
121 An @IdInfo@ gives {\em optional} information about an @Id@. If
122 present it never lies, but it may not be present, in which case there
123 is always a conservative assumption which can be made.
125 Two @Id@s may have different info even though they have the same
126 @Unique@ (and are hence the same @Id@); for example, one might lack
127 the properties attached to the other.
129 The @IdInfo@ gives information about the value, or definition, of the
130 @Id@. It does {\em not} contain information about the @Id@'s usage
131 (except for @DemandInfo@? ToDo).
136 ArityInfo -- Its arity
138 DemandInfo -- Whether or not it is definitely
141 SpecEnv -- Specialisations of this function which exist
143 StrictnessInfo -- Strictness properties, notably
144 -- how to conjure up "worker" functions
146 UnfoldingDetails -- Its unfolding; for locally-defined
147 -- things, this can *only* be NoUnfoldingDetails
148 -- or IWantToBeINLINEd (i.e., INLINE pragma).
150 UpdateInfo -- Which args should be updated
152 DeforestInfo -- Whether its definition should be
153 -- unfolded during deforestation
155 ArgUsageInfo -- how this Id uses its arguments
157 FBTypeInfo -- the Foldr/Build W/W property of this function.
159 SrcLoc -- Source location of definition
161 -- ToDo: SrcLoc is in FullNames too (could rm?) but it
162 -- is needed here too for things like ConstMethodIds and the
163 -- like, which don't have full-names of their own Mind you,
164 -- perhaps the FullName for a constant method could give the
165 -- class/type involved?
169 noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
170 noInfo noInfo noInfo noInfo mkUnknownSrcLoc
172 -- "boring" means: nothing to put an interface
173 boringIdInfo (IdInfo UnknownArity
180 _ {- arg_usage: currently no interface effect -}
182 _ {- src_loc: no effect on interfaces-})
183 | boring_strictness strictness
184 && boring_unfolding unfolding
187 boring_strictness NoStrictnessInfo = True
188 boring_strictness BottomGuaranteed = False
189 boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
191 boring_unfolding NoUnfoldingDetails = True
192 boring_unfolding _ = False
194 boringIdInfo _ = False
196 pp_NONE = ppPStr SLIT("_N_")
199 Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
200 will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very
201 nasty loop, friends...)
203 apply_to_IdInfo ty_fn
204 (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
206 new_spec = apply_spec spec
209 -- apply_strict strictness `thenLft` \ new_strict ->
210 -- apply_wrap wrap `thenLft` \ new_wrap ->
213 new_spec strictness unfold
214 update deforest arg_usage fb_ww srcloc
216 apply_spec (SpecEnv is)
217 = SpecEnv (map do_one is)
219 do_one (SpecInfo ty_maybes ds spec_id)
220 = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id ->
221 SpecInfo (map apply_to_maybe ty_maybes) ds spec_id
223 apply_to_maybe Nothing = Nothing
224 apply_to_maybe (Just ty) = Just (ty_fn ty)
227 apply_strict info@NoStrictnessInfo = returnLft info
228 apply_strict BottomGuaranteed = ???
229 apply_strict (StrictnessInfo wrap_arg_info id_maybe)
231 Nothing -> returnLft Nothing
232 Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
233 returnLft (Just new_xx)
234 ) `thenLft` \ new_id_maybe ->
235 returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
239 Variant of the same thing for the typechecker.
241 applySubstToIdInfo s0
242 (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
243 = case (apply_spec s0 spec) of { (s1, new_spec) ->
244 (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
246 apply_spec s0 (SpecEnv is)
247 = case (mapAccumL do_one s0 is) of { (s1, new_is) ->
248 (s1, SpecEnv new_is) }
250 do_one s0 (SpecInfo ty_maybes ds spec_id)
251 = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
252 (s1, SpecInfo new_maybes ds spec_id) }
254 apply_to_maybe s0 Nothing = (s0, Nothing)
255 apply_to_maybe s0 (Just ty)
256 = case (applySubstToTy s0 ty) of { (s1, new_ty) ->
262 -> Id -- The Id for which we're printing this IdInfo
263 -> Bool -- True <=> print specialisations, please
264 -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos;
265 -> IdEnv UnfoldingDetails
266 -- inlining info for top-level fns in this module
267 -> IdInfo -- see MkIface notes
270 ppIdInfo sty for_this_id specs_please better_id_fn inline_env
271 i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc)
273 = ppPStr SLIT("_NI_")
278 -- order is important!:
279 ppInfo sty better_id_fn arity,
280 ppInfo sty better_id_fn update,
281 ppInfo sty better_id_fn deforest,
283 pp_strictness sty (Just for_this_id)
284 better_id_fn inline_env strictness,
286 if bottomIsGuaranteed strictness
288 else pp_unfolding sty for_this_id inline_env unfold,
291 then pp_specs sty (not (isDataCon for_this_id))
292 better_id_fn inline_env specialise
295 -- DemandInfo needn't be printed since it has no effect on interfaces
296 ppInfo sty better_id_fn demand,
297 ppInfo sty better_id_fn fbtype
301 PprInterface sw_chker -> if sw_chker OmitInterfacePragmas
309 pp_info_op :: String -> Pretty -- like pprNonOp
312 = if isAvarop name || isAconop name
313 then ppBesides [ppLparen, ppStr name, ppRparen]
318 %************************************************************************
320 \subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
322 %************************************************************************
325 class OptIdInfo a where
327 getInfo :: IdInfo -> a
328 addInfo :: IdInfo -> a -> IdInfo
329 -- By default, "addInfo" will not overwrite
330 -- "info" with "non-info"; look at any instance
331 -- to see an example.
332 ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty
335 %************************************************************************
337 \subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
339 %************************************************************************
341 Not used much, but...
343 getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
346 %************************************************************************
348 \subsection[arity-IdInfo]{Arity info about an @Id@}
350 %************************************************************************
354 = UnknownArity -- no idea
355 | ArityExactly Int -- arity is exactly this
359 mkArityInfo = ArityExactly
360 unknownArity = UnknownArity
362 arityMaybe :: ArityInfo -> Maybe Int
364 arityMaybe UnknownArity = Nothing
365 arityMaybe (ArityExactly i) = Just i
369 instance OptIdInfo ArityInfo where
370 noInfo = UnknownArity
372 getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
374 addInfo id_info UnknownArity = id_info
375 addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
377 ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE
378 ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
381 %************************************************************************
383 \subsection[demand-IdInfo]{Demand info about an @Id@}
385 %************************************************************************
387 Whether a value is certain to be demanded or not. (This is the
388 information that is computed by the ``front-end'' of the strictness
391 This information is only used within a module, it is not exported
397 | DemandedAsPer Demand
401 mkDemandInfo :: Demand -> DemandInfo
402 mkDemandInfo demand = DemandedAsPer demand
404 willBeDemanded :: DemandInfo -> Bool
405 willBeDemanded (DemandedAsPer demand) = isStrict demand
406 willBeDemanded _ = False
410 instance OptIdInfo DemandInfo where
411 noInfo = UnknownDemand
413 getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
415 {- DELETED! If this line is in, there is no way to
416 nuke a DemandInfo, and we have to be able to do that
417 when floating let-bindings around
418 addInfo id_info UnknownDemand = id_info
420 addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
422 ppInfo (PprInterface _) _ _ = ppNil
423 ppInfo sty _ UnknownDemand = ppStr "{-# L #-}"
424 ppInfo sty _ (DemandedAsPer info)
425 = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
428 %************************************************************************
430 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
432 %************************************************************************
434 The details of one specialisation, held in an @Id@'s
435 @SpecEnv@ are as follows:
438 = SpecInfo [Maybe UniType] -- Instance types; no free type variables in here
439 Int -- No. of dictionaries to eat
440 Id -- Specialised version
443 For example, if \tr{f} has this @SpecInfo@:
445 SpecInfo [Just t1, Nothing, Just t3] 2 f'
449 f t1 t2 t3 d1 d2 ===> f t2
451 The \tr{Nothings} identify type arguments in which the specialised
452 version is polymorphic.
455 data SpecEnv = SpecEnv [SpecInfo]
458 nullSpecEnv = SpecEnv []
459 addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
461 lookupConstMethodId :: Id -> UniType -> Maybe Id
462 -- slight variant on "lookupSpecEnv" below
464 lookupConstMethodId sel_id spec_ty
465 = case (getInfo (getIdInfo sel_id)) of
466 SpecEnv spec_infos -> firstJust (map try spec_infos)
468 try (SpecInfo (Just ty:nothings) _ const_meth_id)
469 = ASSERT(all nothing_is_nothing nothings)
470 case (cmpUniType True{-properly-} ty spec_ty) of
471 EQ_ -> Just const_meth_id
474 nothing_is_nothing Nothing = True -- debugging only
475 nothing_is_nothing _ = panic "nothing_is_nothing!"
477 lookupSpecId :: Id -- *un*specialised Id
478 -> [Maybe UniType] -- types to which it is to be specialised
479 -> Id -- specialised Id
481 lookupSpecId unspec_id ty_maybes
482 = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
484 case (firstJust (map try spec_infos)) of
486 Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
489 try (SpecInfo template_maybes _ id)
490 | and (zipWith same template_maybes ty_maybes)
491 && length template_maybes == length ty_maybes = Just id
492 | otherwise = Nothing
494 same Nothing Nothing = True
495 same (Just ty1) (Just ty2) = ty1 == ty2
498 lookupSpecEnv :: SpecEnv
504 lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
506 lookupSpecEnv spec_env [] = Nothing -- another common case
508 -- This can happen even if there is a non-empty spec_env, because
509 -- of eta reduction. For example, we might have a defn
511 -- f = /\a -> \d -> g a d
512 -- which gets transformed to
515 -- Now g isn't applied to any arguments
517 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
518 = select_match spec_infos
520 select_match [] -- no matching spec_infos
522 select_match (SpecInfo ty_maybes toss spec_id : rest)
523 = case (match ty_maybes spec_tys) of
524 Nothing -> select_match rest
525 Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
527 -- Ambiguity can only arise as a result of specialisations with
528 -- an explicit spec_id. The best match is deemed to be the match
529 -- with least polymorphism i.e. has the least number of tys left.
530 -- This is a non-critical approximation. The only type arguments
531 -- where there may be some discretion is for non-overloaded boxed
532 -- types. Unboxed types must be matched and we insist that we
533 -- always specialise on overloaded types (and discard all the dicts).
535 select_next best _ toss []
537 [match] -> Just match -- Unique best match
538 ambig -> pprPanic "Ambiguous Specialisation:\n"
539 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
540 ppCat (ppStr "between spec ids:" :
541 map (ppr PprDebug) [id | (id, _, _) <- ambig]),
544 select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
545 = ASSERT(dnum == toss)
546 case (match ty_maybes spec_tys) of
547 Nothing -> select_next best tnum dnum rest
549 let tys_len = length tys_left in
550 case _tagCmp tnum tys_len of
551 _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
552 _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
553 _GT -> select_next best tnum dnum rest -- worse match
556 match [{-out of templates-}] [] = Just []
558 match (Nothing:ty_maybes) (spec_ty:spec_tys)
559 = case (isUnboxedDataType spec_ty) of
560 True -> Nothing -- Can only match boxed type against
561 -- type argument which has not been
563 False -> case match ty_maybes spec_tys of
565 Just tys -> Just (spec_ty:tys)
567 match (Just ty:ty_maybes) (spec_ty:spec_tys)
568 = case (cmpUniType True{-properly-} ty spec_ty) of
569 EQ_ -> match ty_maybes spec_tys
572 match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
573 -- This is a Real Problem
575 match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
576 -- Partial eta abstraction might make this happen;
577 -- meanwhile let's leave in the check
579 pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
584 instance OptIdInfo SpecEnv where
587 getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
589 addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
590 = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
591 -- We *add* the new specialisation info rather than just replacing it
592 -- so that we don't lose old specialisation details.
594 ppInfo sty better_id_fn spec_env
595 = pp_specs sty True better_id_fn nullIdEnv spec_env
597 pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
598 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
599 = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
600 ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
603 better_spec_id = better_id_fn spec_id
604 spec_id_info = getIdInfo better_spec_id
606 if not print_spec_ids || boringIdInfo spec_id_info then
610 ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
613 | (SpecInfo ty_maybes numds spec_id) <- specs ])
616 pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
618 pp_maybe Nothing = ifPprInterface sty pp_NONE
619 pp_maybe (Just t) = pprParendUniType sty t
622 %************************************************************************
624 \subsection[strictness-IdInfo]{Strictness info about an @Id@}
626 %************************************************************************
628 We specify the strictness of a function by giving information about
629 each of the ``wrapper's'' arguments (see the description about
630 worker/wrapper-style transformations in the PJ/Launchbury paper on
633 The list of @Demands@ specifies: (a)~the strictness properties
634 of a function's arguments; (b)~the {\em existence} of a ``worker''
635 version of the function; and (c)~the type signature of that worker (if
636 it exists); i.e. its calling convention.
642 | BottomGuaranteed -- This Id guarantees never to return;
643 -- it is bottom regardless of its arguments.
644 -- Useful for "error" and other disguised
647 | StrictnessInfo [Demand] -- the main stuff; see below.
648 (Maybe Id) -- worker's Id, if applicable.
651 This type is also actually used in the strictness analyser:
654 = WwLazy -- Argument is lazy as far as we know
655 MaybeAbsent -- (does not imply worker's existence [etc]).
656 -- If MaybeAbsent == True, then it is
657 -- *definitely* lazy. (NB: Absence implies
660 | WwStrict -- Argument is strict but that's all we know
661 -- (does not imply worker's existence or any
662 -- calling-convention magic)
664 | WwUnpack -- Argument is strict & a single-constructor
665 [Demand] -- type; its constituent parts (whose StrictInfos
666 -- are in the list) should be passed
667 -- as arguments to the worker.
669 | WwPrim -- Argument is of primitive type, therefore
670 -- strict; doesn't imply existence of a worker;
671 -- argument should be passed as is to worker.
673 | WwEnum -- Argument is strict & an enumeration type;
674 -- an Int# representing the tag (start counting
675 -- at zero) should be passed to the worker.
677 -- we need Eq/Ord to cross-chk update infos in interfaces
679 type MaybeAbsent = Bool -- True <=> not even used
681 -- versions that don't worry about Absence:
682 wwLazy = WwLazy False
684 wwUnpack xs = WwUnpack xs
690 mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
692 mkStrictnessInfo [] _ = NoStrictnessInfo
693 mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
695 mkBottomStrictnessInfo = BottomGuaranteed
697 bottomIsGuaranteed BottomGuaranteed = True
698 bottomIsGuaranteed other = False
700 getWrapperArgTypeCategories
701 :: UniType -- wrapper's type
702 -> StrictnessInfo -- strictness info about its args
705 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
706 getWrapperArgTypeCategories _ BottomGuaranteed
707 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
708 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
710 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
711 = Just (mkWrapperArgTypeCategories ty arg_info)
713 workerExists :: StrictnessInfo -> Bool
714 workerExists (StrictnessInfo _ (Just worker_id)) = True
715 workerExists other = False
717 getWorkerId :: StrictnessInfo -> Id
719 getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
721 getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
726 isStrict :: Demand -> Bool
728 isStrict WwStrict = True
729 isStrict (WwUnpack _) = True
730 isStrict WwPrim = True
731 isStrict WwEnum = True
735 absentArg :: Demand -> Bool
737 absentArg (WwLazy absentp) = absentp
738 absentArg other = False
741 nonAbsentArgs :: [Demand] -> Int
744 = foldr tick_non 0 cmpts
746 tick_non (WwLazy True) acc = acc
747 tick_non other acc = acc + 1
749 all_present_WwLazies :: [Demand] -> Bool
750 all_present_WwLazies infos
751 = and (map is_L infos)
753 is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count!
754 is_L _ = False -- (as they imply a worker)
757 WDP 95/04: It is no longer enough to look at a list of @Demands@ for
758 an ``Unpack'' or an ``Absent'' and declare a worker. We also have to
759 check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore,
760 @indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
761 in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack
762 or an Absent {\em that we accept}.
764 indicatesWorker :: [Demand] -> Bool
767 = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
769 fake_mk_ww _ [] = False
770 fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
771 fake_mk_ww extra_args (WwUnpack cmpnts : dems)
772 | extra_args_now > 0 = True -- we accepted an Unpack
774 extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
776 fake_mk_ww extra_args (_ : dems)
777 = fake_mk_ww extra_args dems
781 mkWrapperArgTypeCategories
782 :: UniType -- wrapper's type
783 -> [Demand] -- info about its arguments
784 -> String -- a string saying lots about the args
786 mkWrapperArgTypeCategories wrapper_ty wrap_info
787 = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
788 map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
791 -- ToDo: this needs FIXING UP (it was a hack anyway...)
792 do_one (WwPrim, _) = 'P'
793 do_one (WwEnum, _) = 'E'
794 do_one (WwStrict, arg_ty_char) = arg_ty_char
795 do_one (WwUnpack _, arg_ty_char)
796 = if arg_ty_char `elem` "CIJFDTS"
797 then toLower arg_ty_char
798 else if arg_ty_char == '+' then 't'
799 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
800 do_one (other_wrap_info, _) = '-'
803 Whether a worker exists depends on whether the worker has an
804 absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
806 If a @WwUnpack@ argument is for an {\em abstract} type (or one that
807 will be abstract outside this module), which might happen for an
808 imported function, then we can't (or don't want to...) unpack the arg
809 as the worker requires. Hence we have to give up altogether, and call
810 the wrapper only; so under these circumstances we return \tr{False}.
813 instance Text Demand where
814 readList str = read_em [{-acc-}] str
816 read_em acc [] = [(reverse acc, "")]
817 -- lower case indicates absence...
818 read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
819 read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
820 read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
821 read_em acc ('P' : xs) = read_em (WwPrim : acc) xs
822 read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
824 read_em acc (')' : xs) = [(reverse acc, xs)]
825 read_em acc ( 'U' : '(' : xs)
826 = case (read_em [] xs) of
827 [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
828 _ -> panic ("Text.Demand:"++str++"::"++xs)
830 read_em acc other = panic ("IdInfo.readem:"++other)
832 showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
834 show1 (WwLazy False) = "L"
835 show1 (WwLazy True) = "A"
839 show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
841 instance Outputable Demand where
842 ppr sty si = ppStr (showList [si] "")
844 instance OptIdInfo StrictnessInfo where
845 noInfo = NoStrictnessInfo
847 getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
849 addInfo id_info NoStrictnessInfo = id_info
850 addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
852 ppInfo sty better_id_fn strictness_info
853 = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
856 We'll omit the worker info if the thing has an explicit unfolding
859 pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
861 pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
863 pp_strictness sty for_this_id_maybe better_id_fn inline_env
864 info@(StrictnessInfo wrapper_args wrkr_maybe)
866 (have_wrkr, wrkr_id) = case wrkr_maybe of
867 Nothing -> (False, panic "ppInfo(Strictness)")
868 Just xx -> (True, xx)
870 wrkr_to_print = better_id_fn wrkr_id
871 wrkr_info = getIdInfo wrkr_to_print
873 -- if we aren't going to be able to *read* the strictness info
874 -- in TcPragmas, we need not even print it.
876 = if not (indicatesWorker wrapper_args) then
877 wrapper_args -- no worker/wrappering in any case
879 case for_this_id_maybe of
880 Nothing -> wrapper_args
881 Just id -> if externallyVisibleId id
882 && (unfoldingUnfriendlyId id || not have_wrkr) then
883 -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) (
884 map un_workerise wrapper_args
890 = case for_this_id_maybe of
892 Just id -> isWorkerId id
896 PprInterface _ -> True
900 = ppBesides [ppStr "_S_ \"",
901 ppStr (showList wrapper_args_to_use ""), ppStr "\""]
904 = ppBesides [ ppSP, ppChar '{',
905 ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
908 if all_present_WwLazies wrapper_args_to_use then -- too boring
909 ifPprInterface sty pp_NONE
911 else if id_is_worker && am_printing_iface then
912 pp_NONE -- we don't put worker strictness in interfaces
913 -- (it can be deduced)
915 else if not (indicatesWorker wrapper_args_to_use)
917 || boringIdInfo wrkr_info then
918 ppBeside pp_basic_info ppNil
920 ppBeside pp_basic_info pp_with_worker
922 un_workerise (WwLazy _) = WwLazy False -- avoid absence
923 un_workerise (WwUnpack _) = WwStrict
924 un_workerise other = other
927 %************************************************************************
929 \subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
931 %************************************************************************
934 mkUnfolding :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails
935 iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
936 mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails
938 mkUnfolding guide expr
939 = GeneralForm False (mkFormSummary NoStrictnessInfo expr)
940 (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
945 iWantToBeINLINEd guide = IWantToBeINLINEd guide
947 mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag)
952 noInfo_UF = NoUnfoldingDetails
954 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
956 NoUnfoldingDetails -> NoUnfoldingDetails
957 GeneralForm _ _ _ BadUnfolding -> NoUnfoldingDetails
958 unfold_ok -> unfold_ok
960 -- getInfo_UF ensures that any BadUnfoldings are never returned
961 -- We had to delay the test required in TcPragmas until now due
962 -- to strictness constraints in TcPragmas
964 addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
965 addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
970 pp_unfolding sty for_this_id inline_env uf_details
971 = case (lookupIdEnv inline_env for_this_id) of
972 Nothing -> pp uf_details
975 pp NoUnfoldingDetails = pp_NONE
977 pp (IWantToBeINLINEd guide) -- not in interfaces
978 = if isWrapperId for_this_id
979 then pp_NONE -- wrapper: don't complain or mutter
980 else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE]
983 = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
985 pp (GeneralForm _ _ _ BadUnfolding) = pp_NONE
987 pp (GeneralForm _ _ template guide)
989 untagged = unTagBinders template
991 if untagged `isWrapperFor` for_this_id
992 then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
994 else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
998 %************************************************************************
1000 \subsection[update-IdInfo]{Update-analysis info about an @Id@}
1002 %************************************************************************
1007 | SomeUpdateInfo UpdateSpec
1009 -- we need Eq/Ord to cross-chk update infos in interfaces
1011 -- the form in which we pass update-analysis info between modules:
1012 type UpdateSpec = [Int]
1016 mkUpdateInfo = SomeUpdateInfo
1018 updateInfoMaybe NoUpdateInfo = Nothing
1019 updateInfoMaybe (SomeUpdateInfo []) = Nothing
1020 updateInfoMaybe (SomeUpdateInfo u) = Just u
1023 Text instance so that the update annotations can be read in.
1026 instance Text UpdateInfo where
1027 readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
1028 | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
1030 ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
1031 | otherwise = panic "IdInfo: not a digit while reading update pragma"
1033 instance OptIdInfo UpdateInfo where
1034 noInfo = NoUpdateInfo
1036 getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
1038 addInfo id_info NoUpdateInfo = id_info
1039 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
1041 ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE
1042 ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
1043 ppInfo sty better_id_fn (SomeUpdateInfo spec)
1044 = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
1047 %************************************************************************
1049 \subsection[deforest-IdInfo]{Deforestation info about an @Id@}
1051 %************************************************************************
1053 The deforest info says whether this Id is to be unfolded during
1054 deforestation. Therefore, when the deforest pragma is true, we must
1055 also have the unfolding information available for this Id.
1059 = Don'tDeforest -- just a bool, might extend this
1060 | DoDeforest -- later.
1061 -- deriving (Eq, Ord)
1065 instance OptIdInfo DeforestInfo where
1066 noInfo = Don'tDeforest
1068 getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
1070 addInfo id_info Don'tDeforest = id_info
1071 addInfo (IdInfo a b d e f g _ h i j) deforest =
1072 IdInfo a b d e f g deforest h i j
1074 ppInfo sty better_id_fn Don'tDeforest
1075 = ifPprInterface sty pp_NONE
1076 ppInfo sty better_id_fn DoDeforest
1077 = ppPStr SLIT("_DEFOREST_")
1080 %************************************************************************
1082 \subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
1084 %************************************************************************
1089 | SomeArgUsageInfo ArgUsageType
1090 -- ??? deriving (Eq, Ord)
1092 data ArgUsage = ArgUsage Int -- number of arguments (is linear!)
1094 type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB
1098 mkArgUsageInfo = SomeArgUsageInfo
1100 getArgUsage :: ArgUsageInfo -> ArgUsageType
1101 getArgUsage NoArgUsageInfo = []
1102 getArgUsage (SomeArgUsageInfo u) = u
1106 instance OptIdInfo ArgUsageInfo where
1107 noInfo = NoArgUsageInfo
1109 getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au
1111 addInfo id_info NoArgUsageInfo = id_info
1112 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
1114 ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
1115 ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
1116 ppInfo sty better_id_fn (SomeArgUsageInfo aut)
1117 = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
1120 ppArgUsage (ArgUsage n) = ppInt n
1121 ppArgUsage (UnknownArgUsage) = ppChar '-'
1123 ppArgUsageType aut = ppBesides
1125 ppIntersperse ppComma (map ppArgUsage aut),
1128 %************************************************************************
1130 \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
1132 %************************************************************************
1137 | SomeFBTypeInfo FBType
1138 -- ??? deriving (Eq, Ord)
1140 data FBType = FBType [FBConsum] FBProd deriving (Eq)
1142 data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
1143 data FBProd = FBGoodProd | FBBadProd deriving(Eq)
1147 mkFBTypeInfo = SomeFBTypeInfo
1149 getFBType :: FBTypeInfo -> Maybe FBType
1150 getFBType NoFBTypeInfo = Nothing
1151 getFBType (SomeFBTypeInfo u) = Just u
1155 instance OptIdInfo FBTypeInfo where
1156 noInfo = NoFBTypeInfo
1158 getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
1160 addInfo id_info NoFBTypeInfo = id_info
1161 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
1163 ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil
1164 ppInfo sty better_id_fn NoFBTypeInfo = ifPprInterface sty pp_NONE
1165 ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod))
1166 = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
1168 --ppFBType (FBType n) = ppBesides [ppInt n]
1169 --ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
1172 ppFBType cons prod = ppBesides
1173 ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
1175 ppCons FBGoodConsum = ppChar 'G'
1176 ppCons FBBadConsum = ppChar 'B'
1177 ppProd FBGoodProd = ppChar 'G'
1178 ppProd FBBadProd = ppChar 'B'