%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.40 2000/11/24 09:51:38 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.41 2001/02/20 09:38:59 simonpj Exp $
%
%********************************************************
%* *
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
+ = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
+ full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.45 2001/02/20 09:38:59 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
)
import TyCon ( isBoxedTupleTyCon )
import IdInfo ( ArityInfo(..) )
-import Name ( Name, isExternallyVisibleName, nameUnique,
- getOccName )
+import Name ( Name, nameUnique, getOccName )
import OccName ( occNameUserString )
import PprType ( getTyDescription )
import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+staticClosureRequired binder bndr_info
(LFReEntrant _ top_level _ _ _ _) -- It's a function
= ASSERT( isTopLevel top_level )
-- Assumption: it's a top-level, no-free-var binding
- arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+ not (satCallsOnly bndr_info)
staticClosureRequired binder other_binder_info other_lf_info = True
-> StgBinderInfo
-> EntryConvention
-> Bool
-slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
- = arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+slowFunEntryCodeRequired binder bndr_info entry_conv
+ = not (satCallsOnly bndr_info)
|| (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
{- The last case deals with the parallel world; a function usually
as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
-slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
-
funInfoTableRequired
:: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant _ top_level _ _ _ _)
+funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _)
= isNotTopLevel top_level
- || arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || isExternallyVisibleName binder
+ || not (satCallsOnly bndr_info)
funInfoTableRequired other_binder_info binder other_lf_info = True
\end{code}
#include "HsVersions.h"
-import CoreUtils
-import CoreFVs
-import CoreLint
+import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreFVs ( exprFreeVars )
+import CoreLint ( endPass )
import CoreSyn
-import Type
-import Demand
-import Var ( TyVar, setTyVarUnique )
+import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
+ isUnLiftedType, isUnboxedTupleType, repType,
+ uaUTy, usOnce, usMany, seqType )
+import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
+import Var ( Id, TyVar, setTyVarUnique )
import VarSet
-import IdInfo
-import Id
-import PrimOp
+import IdInfo ( IdFlavour(..) )
+import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity )
+
import UniqSupply
import Maybes
+import OrdList
import ErrUtils
import CmdLineOpts
import Outputable
-- Overview
-- ---------------------------------------------------------------------------
+MAJOR CONSTRAINT:
+ By the time this pass happens, we have spat out tidied Core into
+ the interface file, including all IdInfo.
+
+ So we must not change the arity of any top-level function,
+ because we've already fixed it and put it out into the interface file.
+
+ It's ok to introduce extra bindings, which don't appear in the
+ interface file. We don't put arity info on these extra bindings,
+ because they are never fully applied, so there's no chance of
+ compiling just-a-fast-entry point for them.
+
Most of the contents of this pass used to be in CoreToStg. The
primary goals here are:
-1. Get the program into "A-normal form". In particular:
+1. Saturate constructor and primop applications.
- f E ==> let x = E in f x
- OR ==> case E of x -> f x
+2. Convert to A-normal form:
+ * Use case for strict arguments:
+ f E ==> case E of x -> f x
+ (where f is strict)
- if E is a non-trivial expression.
- Which transformation is used depends on whether f is strict or not.
- [Previously the transformation to case used to be done by the
- simplifier, but it's better done here. It does mean that f needs
- to have its strictness info correct!.]
+ * Use let for non-trivial lazy arguments
+ f E ==> let x = E in f x
+ (were f is lazy and x is non-trivial)
-2. Similarly, convert any unboxed lets into cases.
- [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
- right up to this point.]
+3. Similarly, convert any unboxed lets into cases.
+ [I'm experimenting with leaving 'ok-for-speculation'
+ rhss in let-form right up to this point.]
- This is all done modulo type applications and abstractions, so that
- when type erasure is done for conversion to STG, we don't end up with
- any trivial or useless bindings.
-
-3. Ensure that lambdas only occur as the RHS of a binding
+4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
-4. Saturate constructor and primop applications.
-
+This is all done modulo type applications and abstractions, so that
+when type erasure is done for conversion to STG, we don't end up with
+any trivial or useless bindings.
+
-- -----------------------------------------------------------------------------
coreSatPgm dflags binds
= do showPass dflags "CoreSat"
us <- mkSplitUniqSupply 's'
- let new_binds = initUs_ us (coreSatBinds binds)
+ let new_binds = initUs_ us (coreSatTopBinds binds)
endPass dflags "CoreSat" Opt_D_dump_sat new_binds
coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
us <- mkSplitUniqSupply 's'
let new_expr = initUs_ us (coreSatAnExpr expr)
dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
- (ppr new_expr)
+ (ppr new_expr)
return new_expr
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------
-data FloatingBind
- = RecF [(Id, CoreExpr)]
- | NonRecF Id
- CoreExpr -- *Can* be a Lam
- RhsDemand
- [FloatingBind]
-
-coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
-coreSatBinds [] = returnUs []
-coreSatBinds (b:bs)
- = coreSatBind b `thenUs` \ float ->
- coreSatBinds bs `thenUs` \ new_bs ->
- case float of
- NonRecF bndr rhs dem floats
- -> ASSERT2( not (isStrictDem dem) &&
- not (isUnLiftedType (idType bndr)),
- ppr b ) -- No top-level cases!
-
- mkBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (NonRec bndr new_rhs : new_bs)
- -- Keep all the floats inside...
- -- Some might be cases etc
- -- We might want to revisit this decision
-
- RecF prs -> returnUs (Rec prs : new_bs)
-
-coreSatBind :: CoreBind -> UniqSM FloatingBind
+data FloatingBind = FloatBind CoreBind
+ | FloatCase Id CoreExpr
+
+coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
+-- Very careful to preserve the arity of top-level functions
+coreSatTopBinds bs
+ = mapUs do_bind bs
+ where
+ do_bind (NonRec b r) = coreSatAnExpr r `thenUs` \ r' ->
+ returnUs (NonRec b r')
+ do_bind (Rec prs) = mapUs do_pair prs `thenUs` \ prs' ->
+ returnUs (Rec prs')
+ do_pair (b,r) = coreSatAnExpr r `thenUs` \ r' ->
+ returnUs (b, r')
+
+
+coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
+-- Used for non-top-level bindings
+-- We return a *list* of bindings because we may start with
+-- x* = f (g y)
+-- where x is demanded, in which case we want to finish with
+-- a = g y
+-- x* = f a
+-- And then x will actually end up case-bound
+
coreSatBind (NonRec binder rhs)
- = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
+ = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
+ mkNonRec binder new_rhs (bdrDem binder) floats
+ -- NB: if there are any lambdas at the top of the RHS,
+ -- the floats will be empty, so the arity won't be affected
+
coreSatBind (Rec pairs)
- = mapUs do_rhs pairs `thenUs` \ new_rhss ->
- returnUs (RecF (binders `zip` new_rhss))
+ = mapUs do_rhs pairs `thenUs` \ new_pairs ->
+ returnUs (unitOL (FloatBind (Rec new_pairs)))
where
- binders = map fst pairs
- do_rhs (bndr,rhs) =
- coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- mkBinds floats new_rhs `thenUs` \ new_rhs' ->
- -- NB: new_rhs' might still be a Lam (and we want that)
- returnUs new_rhs'
+ do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' ->
+ returnUs (bndr,new_rhs')
+
-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
-coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
+coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
coreSatArg arg dem
= coreSatExprFloat arg `thenUs` \ (floats, arg') ->
- if exprIsTrivial arg'
+ if needs_binding arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
- returnUs ([NonRecF v arg' dem floats], Var v)
+ mkNonRec v arg' dem floats `thenUs` \ floats' ->
+ returnUs (floats', Var v)
+
+needs_binding | opt_KeepStgTypes = exprIsAtom
+ | otherwise = exprIsTrivial
-- ---------------------------------------------------------------------------
-- Dealing with expressions
mkBinds floats expr
-coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
+coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
coreSatExprFloat (Var v)
= maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
- returnUs ([], app)
+ returnUs (nilOL, app)
coreSatExprFloat (Lit lit)
- = returnUs ([], Lit lit)
+ = returnUs (nilOL, Lit lit)
coreSatExprFloat (Let bind body)
- = coreSatBind bind `thenUs` \ new_bind ->
+ = coreSatBind bind `thenUs` \ new_binds ->
coreSatExprFloat body `thenUs` \ (floats, new_body) ->
- returnUs (new_bind:floats, new_body)
+ returnUs (new_binds `appOL` floats, new_body)
coreSatExprFloat (Note n@(SCC _) expr)
= coreSatAnExpr expr `thenUs` \ expr ->
deLam expr `thenUs` \ expr ->
- returnUs ([], Note n expr)
+ returnUs (nilOL, Note n expr)
coreSatExprFloat (Note other_note expr)
= coreSatExprFloat expr `thenUs` \ (floats, expr) ->
returnUs (floats, Note other_note expr)
coreSatExprFloat expr@(Type _)
- = returnUs ([], expr)
+ = returnUs (nilOL, expr)
-coreSatExprFloat (Lam v e)
- = coreSatAnExpr e `thenUs` \ e' ->
- returnUs ([], Lam v e')
+coreSatExprFloat expr@(Lam _ _)
+ = coreSatAnExpr body `thenUs` \ body' ->
+ returnUs (nilOL, mkLams bndrs body')
+ where
+ (bndrs,body) = collectBinders expr
coreSatExprFloat (Case scrut bndr alts)
= coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
returnUs (floats, Case scrut bndr alts)
where
sat_alt (con, bs, rhs)
- = coreSatAnExpr rhs `thenUs` \ rhs ->
- deLam rhs `thenUs` \ rhs ->
+ = coreSatAnExpr rhs `thenUs` \ rhs ->
+ deLam rhs `thenUs` \ rhs ->
returnUs (con, bs, rhs)
coreSatExprFloat expr@(App _ _)
-- Deconstruct and rebuild the application, floating any non-atomic
-- arguments to the outside. We collect the type of the expression,
- -- the head of the applicaiton, and the number of actual value arguments,
+ -- the head of the application, and the number of actual value arguments,
-- all of which are used to possibly saturate this application if it
-- has a constructor or primop at the head.
collect_args
:: CoreExpr
- -> Int -- current app depth
- -> UniqSM (CoreExpr, -- the rebuilt expression
- (CoreExpr,Int), -- the head of the application,
+ -> Int -- current app depth
+ -> UniqSM (CoreExpr, -- the rebuilt expression
+ (CoreExpr,Int), -- the head of the application,
-- and no. of args it was applied to
- Type, -- type of the whole expr
- [FloatingBind], -- any floats we pulled out
- [Demand]) -- remaining argument demands
+ Type, -- type of the whole expr
+ OrdList FloatingBind, -- any floats we pulled out
+ [Demand]) -- remaining argument demands
collect_args (App fun arg@(Type arg_ty)) depth
= collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
splitFunTy_maybe fun_ty
in
coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
- returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
+ returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
collect_args (Var v) depth
- = returnUs (Var v, (Var v, depth), idType v, [], stricts)
+ = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
where
stricts = case idStrictness v of
StrictnessInfo demands _
-- non-variable fun, better let-bind it
collect_args fun depth
- = newVar ty `thenUs` \ fn_id ->
- coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
- returnUs (Var fn_id, (Var fn_id, depth), ty,
- [NonRecF fn_id fun onceDem fun_floats], [])
- where ty = exprType fun
+ = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
+ newVar ty `thenUs` \ fn_id ->
+ mkNonRec fn_id fun onceDem fun_floats `thenUs` \ floats ->
+ returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
+ where
+ ty = exprType fun
ignore_note InlineCall = True
ignore_note InlineMe = True
returnUs (etaExpand excess_arity us expr ty)
-- ---------------------------------------------------------------------------
--- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
+-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
-deLam (Note n e)
- = deLam e `thenUs` \ e ->
- returnUs (Note n e)
-
- -- types will all disappear, so that's ok
-deLam (Lam x e) | isTyVar x
- = deLam e `thenUs` \ e ->
- returnUs (Lam x e)
-
-deLam expr@(Lam _ _)
- -- Try for eta reduction
- | Just e <- eta body
- = returnUs e
-
- -- Eta failed, so let-bind the lambda
- | otherwise
- = newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
-
+-- mkNonrec is used for local bindings only, not top level
+mkNonRec bndr rhs dem floats
+ | isUnLiftedType bndr_rep_ty
+ || isStrictDem dem && not (exprIsValue rhs)
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
+ returnUs (floats `snocOL` FloatCase bndr rhs)
where
- (bndrs, body) = collectBinders expr
-
- eta expr@(App _ _)
- | ok_to_eta_reduce f &&
- n_remaining >= 0 &&
- and (zipWith ok bndrs last_args) &&
- not (any (`elemVarSet` fvs_remaining) bndrs)
- = Just remaining_expr
- where
- (f, args) = collectArgs expr
- remaining_expr = mkApps f remaining_args
- fvs_remaining = exprFreeVars remaining_expr
- (remaining_args, last_args) = splitAt n_remaining args
- n_remaining = length args - length bndrs
-
- ok bndr (Var arg) = bndr == arg
- ok bndr other = False
-
- -- we can't eta reduce something which must be saturated.
- ok_to_eta_reduce (Var f)
- = case idFlavour f of
- PrimOpId op -> False
- DataConId dc -> False
- other -> True
- ok_to_eta_reduce _ = False --safe. ToDo: generalise
-
- eta (Let bind@(NonRec b r) body)
- | not (any (`elemVarSet` fvs) bndrs)
- = case eta body of
- Just e -> Just (Let bind e)
- Nothing -> Nothing
- where fvs = exprFreeVars r
+ bndr_rep_ty = repType (idType bndr)
- eta _ = Nothing
+mkNonRec bndr rhs dem floats
+ = mkBinds floats rhs `thenUs` \ rhs' ->
+ returnUs (unitOL (FloatBind (NonRec bndr rhs')))
-deLam expr = returnUs expr
+mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
+mkBinds binds body
+ | isNilOL binds = returnUs body
+ | otherwise = deLam body `thenUs` \ body' ->
+ returnUs (foldOL mk_bind body' binds)
+ where
+ mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)]
+ mk_bind (FloatBind bind) body = Let bind body
-- ---------------------------------------------------------------------------
--- Precipitating the floating bindings
+-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
+-- We arrange that they only show up as the RHS of a let(rec)
-- ---------------------------------------------------------------------------
-mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
-mkBinds [] body = returnUs body
-mkBinds (b:bs) body
- = deLam body `thenUs` \ body' ->
- go (b:bs) body'
+deLam :: CoreExpr -> UniqSM CoreExpr
+-- Remove top level lambdas by let-bindinig
+deLam expr
+ | null bndrs = returnUs expr
+ | otherwise = case tryEta bndrs body of
+ Just no_lam_result -> returnUs no_lam_result
+ Nothing -> newVar (exprType expr) `thenUs` \ fn ->
+ returnUs (Let (NonRec fn expr) (Var fn))
where
- go [] body = returnUs body
- go (b:bs) body = go bs body `thenUs` \ body' ->
- mkBind b body'
-
--- body can't be Lam
-mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
-
-mkBind (NonRecF bndr rhs dem floats) body
-#ifdef DEBUG
- -- We shouldn't get let or case of the form v=w
- = if exprIsTrivial rhs
- then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
- (mk_let bndr rhs dem floats body)
- else mk_let bndr rhs dem floats body
-
-mk_let bndr rhs dem floats body
-#endif
- | isUnLiftedType bndr_rep_ty
- = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
-
- | is_whnf
- = if is_strict then
- -- Strict let with WHNF rhs
- mkBinds floats $
- Let (NonRec bndr rhs) body
- else
- -- Lazy let with WHNF rhs; float until we find a strict binding
- let
- (floats_out, floats_in) = splitFloats floats
- in
- mkBinds floats_in rhs `thenUs` \ new_rhs ->
- mkBinds floats_out $
- Let (NonRec bndr new_rhs) body
-
- | otherwise -- Not WHNF
- = if is_strict then
- -- Strict let with non-WHNF rhs
- mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
- else
- -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
- mkBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (Let (NonRec bndr new_rhs) body)
-
+ (bndrs,body) = collectBinders expr
+
+tryEta bndrs expr@(App _ _)
+ | ok_to_eta_reduce f &&
+ n_remaining >= 0 &&
+ and (zipWith ok bndrs last_args) &&
+ not (any (`elemVarSet` fvs_remaining) bndrs)
+ = Just remaining_expr
where
- bndr_rep_ty = repType (idType bndr)
- is_strict = isStrictDem dem
- is_whnf = exprIsValue rhs
+ (f, args) = collectArgs expr
+ remaining_expr = mkApps f remaining_args
+ fvs_remaining = exprFreeVars remaining_expr
+ (remaining_args, last_args) = splitAt n_remaining args
+ n_remaining = length args - length bndrs
-splitFloats fs@(NonRecF _ _ dem _ : _)
- | isStrictDem dem = ([], fs)
+ ok bndr (Var arg) = bndr == arg
+ ok bndr other = False
-splitFloats (f : fs) = case splitFloats fs of
- (fs_out, fs_in) -> (f : fs_out, fs_in)
+ -- we can't eta reduce something which must be saturated.
+ ok_to_eta_reduce (Var f)
+ = case idFlavour f of
+ PrimOpId op -> False
+ DataConId dc -> False
+ other -> True
+ ok_to_eta_reduce _ = False --safe. ToDo: generalise
+
+tryEta bndrs (Let bind@(NonRec b r) body)
+ | not (any (`elemVarSet` fvs) bndrs)
+ = case tryEta bndrs body of
+ Just e -> Just (Let bind e)
+ Nothing -> Nothing
+ where
+ fvs = exprFreeVars r
-splitFloats [] = ([], [])
+tryEta bndrs _ = Nothing
-- -----------------------------------------------------------------------------
-- Demands
exprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe,
+ exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
exprArity,
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
exprIsTrivial other = False
+
+exprIsAtom :: CoreExpr -> Bool
+-- Used to decide whether to let-binding an STG argument
+-- when compiling to ILX => type applications are not allowed
+exprIsAtom (Var v) = True -- primOpIsDupable?
+exprIsAtom (Lit lit) = True
+exprIsAtom (Type ty) = True
+exprIsAtom (Note _ e) = exprIsAtom e
+exprIsAtom other = False
\end{code}
opt_Parallel,
opt_SMP,
opt_NoMonomorphismRestriction,
+ opt_KeepStgTypes,
-- optimisation opts
opt_NoMethodSharing,
| Opt_D_dump_stranal
| Opt_D_dump_tc
| Opt_D_dump_types
+ | Opt_D_dump_tc_trace
| Opt_D_dump_rules
| Opt_D_dump_usagesp
| Opt_D_dump_cse
{-
The optional '-inpackage=P' flag tells what package
we are compiling this module for.
- The Prelude, for example is compiled with '-package prelude'
+ The Prelude, for example is compiled with '-inpackage prelude'
-}
opt_InPackage = case lookup_str "-inpackage=" of
Just p -> _PK_ p
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
+opt_KeepStgTypes = lookUp SLIT("-fkeep-stg-types")
-- Simplifier switches
opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining")
"fno-method-sharing",
"fno-monomorphism-restriction",
"fomit-interface-pragmas",
+ "fkeep-stg-types",
"fno-pre-inlining",
"fdo-eta-reduction",
"fdo-lambda-eta-expansion",
import Rename ( checkOldIface, renameModule, closeIfaceDecls )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
-import PrelNames ( knownKeyNames )
+import PrelNames ( vanillaSyntaxMap, knownKeyNames )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
writeIface, pprIface )
import TcModule
-- TYPECHECK
maybe_tc_result <- typecheckModule dflags pcs_cl hst
- old_iface alwaysQualify cl_hs_decls
+ old_iface alwaysQualify (vanillaSyntaxMap, cl_hs_decls)
False{-don't check for Main.main-};
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
-------------------
+ -- Do saturation and convert to A-normal form
+ ; saturated <- coreSatPgm dflags tidy_binds
+
; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
- foreign_stuff env_tc tidy_binds
+ foreign_stuff env_tc saturated
hit (pcs_PIT pcs_simpl)
-- and the answer is ...
(simplified, orphan_rules)
<- core2core dflags pcs hst dont_discard binds rules
- -- Do saturation and convert to A-normal form
- -- NOTE: subsequent passes may not transform the syntax, only annotate it
- saturated <- coreSatPgm dflags simplified
-
-- Do the final tidy-up
(pcs', tidy_binds, tidy_orphan_rules)
- <- tidyCorePgm dflags this_mod pcs saturated orphan_rules
+ <- tidyCorePgm dflags this_mod pcs simplified orphan_rules
return (pcs', tidy_binds, tidy_orphan_rules)
-- Typecheck it
maybe_tc_return
- <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr;
+ <- typecheckExpr dflags wrap_io syn_map pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_return of {
Nothing -> return ({-WAS:pcs1-} pcs0, Nothing);
Just (pcs2, tc_expr, ty) -> do
import Type
import TyCon ( isAlgTyCon )
import Id
+import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import PrimOp ( PrimOp(..), ccallMayGC )
import TysPrim ( foreignObjPrimTyCon )
import Maybes ( maybeToBool, orElse )
-import Name ( getOccName )
+import Name ( getOccName, isExternallyVisibleName )
import Module ( Module )
import OccName ( occNameUserString )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( DynFlags )
+import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
import Outputable
-infixr 9 `thenLne`, `thenLne_`
+infixr 9 `thenLne`
\end{code}
%************************************************************************
coreToStgRhs scope_fv_info top (binder, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
- case new_rhs of
-
- StgLam _ bndrs body
- -> let binder_info = lookupFVInfo scope_fv_info binder
- in returnLne (StgRhsClosure noCCS
- binder_info
- noSRT
- (getFVs rhs_fvs)
- ReEntrant
- bndrs
- body,
- rhs_fvs, rhs_escs)
+ returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
+ rhs_fvs, rhs_escs)
+ where
+ binder_info = lookupFVInfo scope_fv_info binder
+
+mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
+ -> StgExpr -> StgRhs
+
+mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info noSRT
+ (getFVs rhs_fvs)
+ ReEntrant
+ bndrs body
- StgConApp con args
- | isNotTopLevel top || not (isDllConApp con args)
- -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs)
-
- _other_expr
- -> let binder_info = lookupFVInfo scope_fv_info binder
- in returnLne (StgRhsClosure noCCS
- binder_info
- noSRT
- (getFVs rhs_fvs)
- (updatable [] new_rhs)
- []
- new_rhs,
- rhs_fvs, rhs_escs
- )
-
-updatable args body | null args && isPAP body = ReEntrant
- | otherwise = Updatable
+mkStgRhs top rhs_fvs binder_info (StgConApp con args)
+ | isNotTopLevel top || not (isDllConApp con args)
+ = StgRhsCon noCCS con args
+
+mkStgRhs top rhs_fvs binder_info rhs
+ = StgRhsClosure noCCS binder_info noSRT
+ (getFVs rhs_fvs)
+ (updatable [] rhs)
+ [] rhs
+ where
+ updatable args body | null args && isPAP body = ReEntrant
+ | otherwise = Updatable
{- ToDo:
upd = if isOnceDem dem
then (if isNotTop toplev
\begin{code}
isPAP (StgApp f args) = idArity f > length args
isPAP _ = False
+\end{code}
--- ---------------------------------------------------------------------------
--- Atoms
--- ---------------------------------------------------------------------------
-
-coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
-coreToStgAtoms atoms
- = let val_atoms = filter isValArg atoms in
- mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) ->
- returnLne (args', unionFVInfos fvs_lists)
- where
- coreToStgAtom e
- = coreToStgExpr e `thenLne` \ (expr, fvs, escs) ->
- case expr of
- StgApp v [] -> returnLne (StgVarArg v, fvs)
- StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs)
- StgLit lit -> returnLne (StgLitArg lit, fvs)
- _ -> pprPanic "coreToStgAtom" (ppr expr)
-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
-{-
-@varsExpr@ carries in a monad-ised environment, which binds each
-let(rec) variable (ie non top level, not imported, not lambda bound,
-not case-alternative bound) to:
- - its STG arity, and
- - its set of live vars.
-For normal variables the set of live vars is just the variable
-itself. For let-no-escaped variables, the set of live vars is the set
-live at the moment the variable is entered. The set is guaranteed to
-have no further let-no-escaped vars in it.
--}
-
+\begin{code}
coreToStgExpr
:: CoreExpr
-> LneM (StgExpr, -- Decorated STG expr
decisions. Hence no black holes.
\begin{code}
-coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
-
-coreToStgExpr (Var v)
- = coreToStgApp Nothing v []
+coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
coreToStgExpr expr@(App _ _)
- = let (f, args) = myCollectArgs expr
- in
- coreToStgApp Nothing (shouldBeVar f) args
+ = coreToStgApp Nothing f args
+ where
+ (f, args) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
= let (args, body) = myCollectBinders expr
- args' = filter isId args
+ args' = filterStgBinders args
in
extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
-- Cases require a little more real work.
coreToStgExpr (Case scrut bndr alts)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
+ = getVarsLiveInCont `thenLne` \ live_in_cont ->
extendVarEnvLne [(bndr, CaseBound)] $
- vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
- lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
+ vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
-- determine whether the default binder is dead or not
- bndr'= if (bndr `elementOfFVInfo` alts_fvs)
- then bndr `setIdOccInfo` NoOccInfo
- else bndr `setIdOccInfo` IAmDead
+ bndr' = bndr `setIdOccInfo` occ_info
+ occ_info | bndr `elementOfFVInfo` alts_fvs = NoOccInfo
+ | otherwise = IAmDead
-- for a _ccall_GC_, some of the *arguments* need to live across the
-- call (see findLiveArgs comments.), so we annotate them as being live
mb_live_across_case =
case scrut of
-- ToDo: Notes?
- e@(App _ _) | (Var v, args) <- myCollectArgs e,
+ e@(App _ _) | (v, args) <- myCollectArgs e,
PrimOpId (CCallOp ccall) <- idFlavour v,
ccallMayGC ccall
-> Just (filterVarSet isForeignObjArg (exprFreeVars e))
vars_alg_alt (DataAlt con, binders, rhs)
= let
-- remove type variables
- binders' = filter isId binders
+ binders' = filterStgBinders binders
in
extendVarEnvLne [(b, CaseBound) | b <- binders'] $
coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
vars_deflt (Just rhs)
= coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
-
\end{code}
Lets not only take quite a bit of work, but this is where we convert
\end{code}
-Applications:
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
+
\begin{code}
coreToStgApp
:: Maybe UpdateFlag -- Just upd <=> this application is
coreToStgApp maybe_thunk_body f args
= getVarsLiveInCont `thenLne` \ live_in_cont ->
- coreToStgAtoms args `thenLne` \ (args', args_fvs) ->
+ coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
let
n_args = length args
not_letrec_bound = not (isLetrecBound how_bound)
- f_arity = idArity f
fun_fvs = singletonFVInfo f how_bound fun_occ
+ -- Mostly, the arity info of a function is in the fn's IdInfo
+ -- But new bindings introduced by CoreSat may not have no
+ -- arity info; it would do us no good anyway. For example:
+ -- let f = \ab -> e in f
+ -- No point in having correct arity info for f!
+ -- Hence the hasArity stuff below.
+ f_arity_info = idArityInfo f
+ f_arity = arityLowerBound f_arity_info -- Zero if no info
+
fun_occ
- | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
-
- -- Otherwise it is letrec bound; must have its arity
- | n_args == 0 = stgFakeFunAppOcc -- Function Application
- -- with no arguments.
- -- used by the lambda lifter.
- | f_arity > n_args = stgUnsatOcc -- Unsaturated
-
- | f_arity == n_args &&
- maybeToBool maybe_thunk_body -- Exactly saturated,
- -- and rhs of thunk
- = case maybe_thunk_body of
- Just Updatable -> stgStdHeapOcc
- Just SingleEntry -> stgNoUpdHeapOcc
- other -> panic "coreToStgApp"
-
- | otherwise = stgNormalOcc
- -- Record only that it occurs free
-
- myself = unitVarSet f
-
- fun_escs | not_letrec_bound = emptyVarSet
- -- Only letrec-bound escapees are interesting
- | f_arity == n_args = emptyVarSet
- -- Function doesn't escape
- | otherwise = myself
- -- Inexact application; it does escape
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+
+ fun_escs
+ | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | hasArity f_arity_info &&
+ f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
+ -- saturated call doesn't escape
+ -- (let-no-escape applies to 'thunks' too)
+
+ | otherwise = unitVarSet f -- Inexact application; it does escape
-- At the moment of the call:
-- continuation, but it does no harm to just union the
-- two regardless.
- -- XXX not needed?
- -- live_at_call
- -- = live_in_cont `unionVarSet` case how_bound of
- -- LetrecBound _ lvs -> lvs `minusVarSet` myself
- -- other -> emptyVarSet
-
app = case idFlavour f of
DataConId dc -> StgConApp dc args'
PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
)
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgArgs []
+ = returnLne ([], emptyFVInfo)
+
+coreToStgArgs (Type ty : args) -- Type argument
+ = coreToStgArgs args `thenLne` \ (args', fvs) ->
+ if opt_KeepStgTypes then
+ returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
+ else
+ returnLne (args', fvs)
+
+coreToStgArgs (arg : args) -- Non-type argument
+ = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
+ coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
+ let
+ fvs = args_fvs `unionFVInfo` arg_fvs
+ stg_arg = case arg' of
+ StgApp v [] -> StgVarArg v
+ StgConApp con [] -> StgVarArg (dataConWrapId con)
+ StgLit lit -> StgLitArg lit
+ _ -> pprPanic "coreToStgArgs" (ppr arg)
+ in
+ returnLne (stg_arg : stg_args, fvs)
+
+
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------
let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
- -- this let(rec)
+ -- this let(rec)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
help. All the stuff here is only passed {\em down}.
\begin{code}
-type LneM a = IdEnv HowBound
+type LneM a = IdEnv HowBound
-> StgLiveVars -- vars live in continuation
-> a
isLetrecBound other = False
\end{code}
-For a let(rec)-bound variable, x, we record what varibles are live if
-x is live. For "normal" variables that is just x alone. If x is
-a let-no-escaped variable then x is represented by a code pointer and
-a stack pointer (well, one for each stack). So all of the variables
-needed in the execution of x are live if x is, and are therefore recorded
-in the LetrecBound constructor; x itself *is* included.
+For a let(rec)-bound variable, x, we record StgLiveVars, the set of
+variables that are live if x is live. For "normal" variables that is
+just x alone. If x is a let-no-escaped variable then x is represented
+by a code pointer and a stack pointer (well, one for each stack). So
+all of the variables needed in the execution of x are live if x is,
+and are therefore recorded in the LetrecBound constructor; x itself
+*is* included.
+
+The set of live variables is guaranteed ot have no further let-no-escaped
+variables in it.
The std monad functions:
\begin{code}
initLne m = m emptyVarEnv emptyVarSet
{-# INLINE thenLne #-}
-{-# INLINE thenLne_ #-}
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
thenLne :: LneM a -> (a -> LneM b) -> LneM b
thenLne m k env lvs_cont
- = case (m env lvs_cont) of
- m_result -> k m_result env lvs_cont
-
-thenLne_ :: LneM a -> LneM b -> LneM b
-thenLne_ m k env lvs_cont
- = case (m env lvs_cont) of
- _ -> k env lvs_cont
+ = k (m env lvs_cont) env lvs_cont
mapLne :: (a -> LneM b) -> [a] -> LneM [b]
mapLne f [] = returnLne []
returnLne (r1:rs1, r2:rs2, r3:rs3)
fixLne :: (a -> LneM a) -> LneM a
-fixLne expr env lvs_cont = result
+fixLne expr env lvs_cont
+ = result
where
result = expr result env lvs_cont
--- ^^^^^^ ------ ^^^^^^
\end{code}
Functions specific to this monad:
+
\begin{code}
getVarsLiveInCont :: LneM StgLiveVars
getVarsLiveInCont env lvs_cont = lvs_cont
%************************************************************************
\begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
- -- If f is mapped to NoStgBinderInfo, that means
- -- that f *is* mentioned (else it wouldn't be in the
- -- IdEnv at all), but only in a saturated applications.
- --
- -- All case/lambda-bound things are also mapped to
- -- NoStgBinderInfo, since we aren't interested in their
- -- occurence info.
- --
- -- The Bool is True <=> the Id is top level letrec bound
-
-type EscVarsSet = IdSet
+type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
+ -- If f is mapped to noBinderInfo, that means
+ -- that f *is* mentioned (else it wouldn't be in the
+ -- IdEnv at all), but only in a saturated applications.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- noBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- The Bool is True <=> the Id is top level letrec bound
+ --
+ -- For ILX we track free var info for type variables too;
+ -- hence VarEnv not IdEnv
+
+type EscVarsSet = IdSet
\end{code}
\begin{code}
singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
singletonFVInfo id other info = unitVarEnv id (id, False, info)
+tyvarFVInfo :: TyVarSet -> FreeVarsInfo
+tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
+ where
+ add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
+
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
-lookupFVInfo fvs id = case lookupVarEnv fvs id of
- Nothing -> NoStgBinderInfo
+-- Find how the given Id is used.
+-- Externally visible things may be used any old how
+lookupFVInfo fvs id
+ | isExternallyVisibleName (idName id) = noBinderInfo
+ | otherwise = case lookupVarEnv fvs id of
+ Nothing -> noBinderInfo
Just (_,_,info) -> info
getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
\end{code}
Misc.
-
\begin{code}
-shouldBeVar (Note _ e) = shouldBeVar e
-shouldBeVar (Var v) = v
-shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs
+ | opt_KeepStgTypes = bndrs
+ | otherwise = filter isId bndrs
+\end{code}
--- ignore all notes except SCC
+
+\begin{code}
+ -- Ignore all notes except SCC
myCollectBinders expr
= go [] expr
where
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
-myCollectArgs :: Expr b -> (Expr b, [Arg b])
+myCollectArgs :: CoreExpr -> (Id, [CoreArg])
+ -- We assume that we only have variables
+ -- in the function position by now
myCollectArgs expr
= go expr []
where
+ go (Var v) as = (v, as)
go (App f a) as = go f (a:as)
- go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
- go (Note n e) as = go e as
- go e as = (e, as)
+ go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note n e) as = go e as
+ go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
UpdateFlag(..), isUpdatable,
- StgBinderInfo(..),
- stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
- stgNormalOcc, stgFakeFunAppOcc,
+ StgBinderInfo,
+ noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
combineStgBinderInfo,
-- a set of synonyms for the most common (only :-) parameterisation
\begin{code}
data StgBinderInfo
= NoStgBinderInfo
- | StgBinderInfo
- Bool -- At least one occurrence as an argument
+ | SatCallsOnly -- All occurrences are *saturated* *function* calls
+ -- This means we don't need to build an info table and
+ -- slow entry code for the thing
+ -- Thunks never get this value
- Bool -- At least one occurrence in an unsaturated application
+noBinderInfo = NoStgBinderInfo
+stgUnsatOcc = NoStgBinderInfo
+stgSatOcc = SatCallsOnly
- Bool -- This thing (f) has at least occurrence of the form:
- -- x = [..] \u [] -> f a b c
- -- where the application is saturated
-
- Bool -- Ditto for non-updatable x.
-
- Bool -- At least one fake application occurrence, that is
- -- an StgApp f args where args is an empty list
- -- This is due to the fact that we do not have a
- -- StgVar constructor.
- -- Used by the lambda lifter.
- -- True => "at least one unsat app" is True too
-
-stgArgOcc = StgBinderInfo True False False False False
-stgUnsatOcc = StgBinderInfo False True False False False
-stgStdHeapOcc = StgBinderInfo False False True False False
-stgNoUpdHeapOcc = StgBinderInfo False False False True False
-stgNormalOcc = StgBinderInfo False False False False False
--- [Andre] can't think of a good name for the last one.
-stgFakeFunAppOcc = StgBinderInfo False True False False True
+satCallsOnly :: StgBinderInfo -> Bool
+satCallsOnly SatCallsOnly = True
+satCallsOnly NoStgBinderInfo = False
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
+combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
+combineStgBinderInfo info1 info2 = NoStgBinderInfo
-combineStgBinderInfo NoStgBinderInfo info2 = info2
-combineStgBinderInfo info1 NoStgBinderInfo = info1
-combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
- (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
- = StgBinderInfo (arg1 || arg2)
- (unsat1 || unsat2)
- (std_heap1 || std_heap2)
- (upd_heap1 || upd_heap2)
- (fkap1 || fkap2)
+--------------
+pp_binder_info NoStgBinderInfo = empty
+pp_binder_info SatCallsOnly = ptext SLIT("sat-only")
\end{code}
%************************************************************************
pprMaybeSRT (NoSRT) = empty
pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
-
---------------
-
-pp_binder_info NoStgBinderInfo = empty
-
--- cases so boring that we print nothing
-pp_binder_info (StgBinderInfo True b c d e) = empty
-
--- general case
-pp_binder_info (StgBinderInfo a b c d e)
- = getPprStyle $ \ sty ->
- if userStyle sty then
- empty
- else
- parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
\end{code}
Collect @IdInfo@ stuff that is most easily just snaffled straight
projects / ghc-hetmet.git / commitdiff