leastItCouldCost
) where
-IMPORT_Trace
+import Ubiq{-uitous-}
+import SmplLoop ( simplExpr )
-import SimplMonad
-import SimplEnv
-import PlainCore
-import TaggedCore
-import BasicLit ( isNoRepLit )
-
-import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe,
- getTyConFamilySize, isPrimType
- )
-import BinderInfo ( oneTextualOcc, oneSafeOcc )
import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
-import Id ( getIdUniType, getIdInfo )
-import IdInfo
-import Maybes ( maybeToBool, Maybe(..) )
-import Simplify ( simplExpr )
-import SimplUtils ( simplIdWantsToBeINLINEd )
-import MagicUFs
-import Pretty
-import Util
+import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+ FormSummary(..)
+ )
+import Id ( idType, getIdInfo,
+ GenId{-instance Outputable-}
+ )
+import IdInfo ( DeforestInfo(..) )
+import Literal ( isNoRepLit )
+import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppBesides, ppStr )
+import SimplEnv
+import SimplMonad
+import TyCon ( tyConFamilySize )
+import Type ( isPrimType, getAppDataTyCon, maybeAppDataTyCon )
+import Util ( pprTrace, assertPanic, panic )
\end{code}
%************************************************************************
completeVar env var args
= let
- boring_result = applyToArgs (CoVar var) args
+ boring_result = mkGenApp (Var var) args
in
case (lookupUnfolding env var) of
-
- LiteralForm lit
- | not (isNoRepLit lit)
+
+ LitForm lit
+ | not (isNoRepLit lit)
-- Inline literals, if they aren't no-repish things
-> ASSERT( null args )
- returnSmpl (CoLit lit)
+ returnSmpl (Lit lit)
- ConstructorForm con ty_args val_args
+ ConForm con args
-- Always inline constructors.
-- See comments before completeLetBinding
-> ASSERT( null args )
- returnSmpl (CoCon con ty_args val_args)
+ returnSmpl (Con con args)
- GeneralForm txt_occ form_summary template guidance
+ GenForm txt_occ form_summary template guidance
-> considerUnfolding env var args
txt_occ form_summary template guidance
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
case result of
Nothing -> returnSmpl boring_result
- Just magic_result ->
+ Just magic_result ->
{- pprTrace "MagicForm:- " (ppAbove
(ppBesides [
ppr PprDebug var,
tick MagicUnfold `thenSmpl_`
returnSmpl magic_result
- IWantToBeINLINEd _ -> returnSmpl boring_result
+-- LATER:
+-- IWantToBeINLINEd _ -> returnSmpl boring_result
other -> returnSmpl boring_result
\end{code}
-> FormSummary
-> InExpr -- Template for unfolding;
-> UnfoldingGuidance -- To help us decide...
- -> SmplM PlainCoreExpr -- Result!
+ -> SmplM CoreExpr -- Result!
considerUnfolding env var args txt_occ form_summary template guidance
| switchIsOn sw_chkr EssentialUnfoldingsOnly
= go_for_it
| (case form_summary of {BottomForm -> True; other -> False} &&
- not (any isPrimType [ ty | (TypeArg ty) <- args ]))
+ not (any isPrimType [ ty | (TyArg ty) <- args ]))
-- Always inline bottoming applications, unless
-- there's a primitive type lurking around...
= go_for_it
dont_go_for_it
else if n_vals_wanted == 0
- && looks_like_a_data_val_to_me then
+ && rhs_looks_like_a_Con then
-- we are very keen on inlining data values
-- (see comments elsewhere); we ignore any size issues!
go_for_it
con_discount -- ToDo: ************ get from a switch *********
= uNFOLDING_CON_DISCOUNT_WEIGHT
- (tyargs, valargs, args_left) = decomposeArgs args
+ (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
no_tyargs = length tyargs
no_valargs = length valargs
+ args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
+ -- we concoct this dummy expr, just so we can use collectArgs
+ -- (rather than make up a special-purpose bit of code)
- looks_like_a_data_val_to_me
+ rhs_looks_like_a_Con
= let
- (_,val_binders,body) = digForLambdas template
+ (_,_,val_binders,body) = collectBinders template
in
case (val_binders, body) of
- ([], CoCon _ _ _) -> True
+ ([], Con _ _) -> True
other -> False
- dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args)
+ dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
tick UnfoldingDone `thenSmpl_`
-> Int -- the size/cost of the expr
-> Int -- the number of val args (== length args)
-> ArgInfoVector -- what we know about the *use* of the arguments
- -> [OutAtom] -- *an actual set of value arguments*!
- -> Int
+ -> [OutArg] -- *an actual set of value arguments*!
+ -> Int
-- If we apply an expression (usually a function) of given "costs"
-- to a particular set of arguments (possibly none), what will
= let
full_price = disc size
take_something_off v = let
- (tycon, _, _) = getUniDataTyCon (getIdUniType v)
- no_cons = case (getTyConFamilySize tycon) of
- Just n -> n
+ (tycon, _, _) = getAppDataTyCon (idType v)
+ no_cons = tyConFamilySize tycon
reduced_size
= size - (no_cons * con_discount_weight)
in
full_price
else
case arg of
- CoLitAtom _ -> full_price
- CoVarAtom v -> case lookupUnfolding env v of
- ConstructorForm _ _ _ -> take_something_off v
- other_form -> full_price
+ LitArg _ -> full_price
+ VarArg v -> case lookupUnfolding env v of
+ ConForm _ _ -> take_something_off v
+ other_form -> full_price
) want_cons rest_args
\end{code}
-> Int -- the size/cost of the expr
-> Int -- number of value args
-> ArgInfoVector -- what we know about the *use* of the arguments
- -> [UniType] -- NB: actual arguments *not* looked at;
+ -> [Type] -- NB: actual arguments *not* looked at;
-- but we know their types
-> Int
= let
take_something_off tycon
= let
- no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
+ no_cons = tyConFamilySize tycon
reduced_size
= size - (no_cons * con_discount_weight)
if not want_con_here then
disc size want_cons rest_arg_tys
else
- case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of
+ case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
(Just (tycon, _, _), False) ->
- disc (take_something_off tycon) want_cons rest_arg_tys
+ disc (take_something_off tycon) want_cons rest_arg_tys
other -> disc size want_cons rest_arg_tys
\end{code}
projects / ghc-hetmet.git / blobdiff