-%\r
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
-%\r
-\section[SimplCore]{Driver for simplifying @Core@ programs}\r
-\r
-\begin{code}\r
-module SimplCore ( core2core ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), \r
- SwitchResult(..), switchIsOn, intSwitchSet,\r
- opt_D_dump_occur_anal, opt_D_dump_rules,\r
- opt_D_dump_simpl_iterations,\r
- opt_D_dump_simpl_stats,\r
- opt_D_dump_simpl, opt_D_dump_rules,\r
- opt_D_verbose_core2core,\r
- opt_D_dump_occur_anal,\r
- opt_UsageSPOn,\r
- )\r
-import CoreLint ( beginPass, endPass )\r
-import CoreTidy ( tidyCorePgm )\r
-import CoreSyn\r
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )\r
-import CoreUnfold\r
-import PprCore ( pprCoreBindings )\r
-import OccurAnal ( occurAnalyseBinds )\r
-import CoreUtils ( exprIsTrivial, coreExprType )\r
-import Simplify ( simplTopBinds, simplExpr )\r
-import SimplUtils ( etaCoreExpr, findDefault, simplBinders )\r
-import SimplMonad\r
-import Const ( Con(..), Literal(..), literalType, mkMachInt )\r
-import ErrUtils ( dumpIfSet )\r
-import FloatIn ( floatInwards )\r
-import FloatOut ( floatOutwards )\r
-import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,\r
- idType, setIdType, idName, idInfo, setIdNoDiscard\r
- )\r
-import VarEnv\r
-import VarSet\r
-import Module ( Module )\r
-import Name ( mkLocalName, tidyOccName, tidyTopName, \r
- NamedThing(..), OccName\r
- )\r
-import TyCon ( TyCon, isDataTyCon )\r
-import PrimOp ( PrimOp(..) )\r
-import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )\r
-import Type ( Type, splitAlgTyConApp_maybe, \r
- isUnLiftedType,\r
- tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,\r
- Type\r
- )\r
-import TysWiredIn ( smallIntegerDataCon, isIntegerTy )\r
-import LiberateCase ( liberateCase )\r
-import SAT ( doStaticArgs )\r
-import Specialise ( specProgram)\r
-import UsageSPInf ( doUsageSPInf )\r
-import StrictAnal ( saBinds )\r
-import WorkWrap ( wwTopBinds )\r
-import CprAnalyse ( cprAnalyse )\r
-\r
-import Unique ( Unique, Uniquable(..),\r
- ratioTyConKey\r
- )\r
-import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )\r
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )\r
-import Util ( mapAccumL )\r
-import SrcLoc ( noSrcLoc )\r
-import Bag\r
-import Maybes\r
-import IO ( hPutStr, stderr )\r
-import Outputable\r
-\r
-import Ratio ( numerator, denominator )\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The driver for the simplifier}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-core2core :: [CoreToDo] -- Spec of what core-to-core passes to do\r
- -> [CoreBind] -- Binds in\r
- -> [ProtoCoreRule] -- Rules\r
- -> IO ([CoreBind], [ProtoCoreRule])\r
-\r
-core2core core_todos binds rules\r
- = do\r
- us <- mkSplitUniqSupply 's'\r
- let (cp_us, us1) = splitUniqSupply us\r
- (ru_us, ps_us) = splitUniqSupply us1\r
-\r
- better_rules <- simplRules ru_us rules binds\r
-\r
- let (binds1, rule_base) = prepareRuleBase binds better_rules\r
-\r
- -- Do the main business\r
- (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 \r
- rule_base core_todos\r
-\r
- dumpIfSet opt_D_dump_simpl_stats\r
- "Grand total simplifier statistics"\r
- (pprSimplCount stats)\r
-\r
- -- Do the post-simplification business\r
- post_simpl_binds <- doPostSimplification ps_us processed_binds\r
-\r
- -- Return results\r
- return (post_simpl_binds, filter orphanRule better_rules)\r
- \r
-\r
-doCorePasses stats us binds irs []\r
- = return (stats, binds)\r
-\r
-doCorePasses stats us binds irs (to_do : to_dos) \r
- = do\r
- let (us1, us2) = splitUniqSupply us\r
- (stats1, binds1) <- doCorePass us1 binds irs to_do\r
- doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos\r
-\r
-doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds\r
-doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)\r
-doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)\r
-doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)\r
-doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)\r
-doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)\r
-doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)\r
-doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)\r
-doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)\r
-doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)\r
-doCorePass us binds rb CoreDoUSPInf\r
- = _scc_ "CoreUsageSPInf" \r
- if opt_UsageSPOn then\r
- noStats (doUsageSPInf us binds)\r
- else\r
- trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $\r
- noStats (return binds)\r
-\r
-printCore binds = do dumpIfSet True "Print Core"\r
- (pprCoreBindings binds)\r
- return binds\r
-\r
-noStats thing = do { result <- thing; return (zeroSimplCount, result) }\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Dealing with rules}\r
-%* *\r
-%************************************************************************\r
-\r
-We must do some gentle simplifiation on the template (but not the RHS)\r
-of each rule. The case that forced me to add this was the fold/build rule,\r
-which without simplification looked like:\r
- fold k z (build (/\a. g a)) ==> ...\r
-This doesn't match unless you do eta reduction on the build argument.\r
-\r
-\begin{code}\r
-simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]\r
-simplRules us rules binds\r
- = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)\r
- \r
- dumpIfSet opt_D_dump_rules\r
- "Transformation rules"\r
- (vcat (map pprProtoCoreRule better_rules))\r
-\r
- return better_rules\r
- where\r
- black_list_all v = True -- This stops all inlining\r
- sw_chkr any = SwBool False -- A bit bogus\r
-\r
- -- Boringly, we need to gather the in-scope set.\r
- -- Typically this thunk won't even be force, but the test in\r
- -- simpVar fails if it isn't right, and it might conceivably matter\r
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds\r
-\r
-\r
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))\r
- | not is_local\r
- = returnSmpl rule -- No need to fiddle with imported rules\r
- | otherwise\r
- = simplBinders bndrs $ \ bndrs' -> \r
- mapSmpl simplExpr args `thenSmpl` \ args' ->\r
- simplExpr rhs `thenSmpl` \ rhs' ->\r
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The driver for the simplifier}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-simplifyPgm :: RuleBase\r
- -> (SimplifierSwitch -> SwitchResult)\r
- -> UniqSupply\r
- -> [CoreBind] -- Input\r
- -> IO (SimplCount, [CoreBind]) -- New bindings\r
-\r
-simplifyPgm (imported_rule_ids, rule_lhs_fvs) \r
- sw_chkr us binds\r
- = do {\r
- beginPass "Simplify";\r
-\r
- -- Glom all binds together in one Rec, in case any\r
- -- transformations have introduced any new dependencies\r
- let { recd_binds = [Rec (flattenBinds binds)] };\r
-\r
- (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;\r
-\r
- dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)\r
- "Simplifier statistics"\r
- (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",\r
- text "",\r
- pprSimplCount counts_out]);\r
-\r
- endPass "Simplify" \r
- (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)\r
- binds' ;\r
-\r
- return (counts_out, binds')\r
- }\r
- where\r
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations\r
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)\r
-\r
- core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds\r
- | otherwise = empty\r
-\r
- iteration us iteration_no counts binds\r
- = do {\r
- -- Occurrence analysis\r
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;\r
-\r
- dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"\r
- (pprCoreBindings tagged_binds);\r
-\r
- -- Simplify\r
- let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids \r
- black_list_fn \r
- (simplTopBinds tagged_binds);\r
- all_counts = counts `plusSimplCount` counts'\r
- } ;\r
-\r
- -- Stop if nothing happened; don't dump output\r
- if isZeroSimplCount counts' then\r
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')\r
- else do {\r
-\r
- -- Dump the result of this iteration\r
- dumpIfSet opt_D_dump_simpl_iterations\r
- ("Simplifier iteration " ++ show iteration_no \r
- ++ " out of " ++ show max_iterations)\r
- (pprSimplCount counts') ;\r
-\r
- if opt_D_dump_simpl_iterations then\r
- endPass ("Simplifier iteration " ++ show iteration_no ++ " result")\r
- opt_D_verbose_core2core\r
- binds'\r
- else\r
- return [] ;\r
-\r
- -- Stop if we've run out of iterations\r
- if iteration_no == max_iterations then\r
- do {\r
- if max_iterations > 2 then\r
- hPutStr stderr ("NOTE: Simplifier still going after " ++ \r
- show max_iterations ++ \r
- " iterations; bailing out.\n")\r
- else return ();\r
-\r
- return ("Simplifier baled out", iteration_no, all_counts, binds')\r
- }\r
-\r
- -- Else loop\r
- else iteration us2 (iteration_no + 1) all_counts binds'\r
- } }\r
- where\r
- (us1, us2) = splitUniqSupply us\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{PostSimplification}\r
-%* *\r
-%************************************************************************\r
-\r
-Several tasks are performed by the post-simplification pass\r
-\r
-1. Make the representation of NoRep literals explicit, and\r
- float their bindings to the top level. We only do the floating\r
- part for NoRep lits inside a lambda (else no gain). We need to\r
- take care with let x = "foo" in e\r
- that we don't end up with a silly binding\r
- let x = y in e\r
- with a floated "foo". What a bore.\r
- \r
-4. Do eta reduction for lambda abstractions appearing in:\r
- - the RHS of case alternatives\r
- - the body of a let\r
-\r
- These will otherwise turn into local bindings during Core->STG;\r
- better to nuke them if possible. (In general the simplifier does\r
- eta expansion not eta reduction, up to this point. It does eta\r
- on the RHSs of bindings but not the RHSs of case alternatives and\r
- let bodies)\r
-\r
-\r
-------------------- NOT DONE ANY MORE ------------------------\r
-[March 98] Indirections are now elimianted by the occurrence analyser\r
-1. Eliminate indirections. The point here is to transform\r
- x_local = E\r
- x_exported = x_local\r
- ==>\r
- x_exported = E\r
-\r
-[Dec 98] [Not now done because there is no penalty in the code\r
- generator for using the former form]\r
-2. Convert\r
- case x of {...; x' -> ...x'...}\r
- ==>\r
- case x of {...; _ -> ...x... }\r
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.\r
---------------------------------------------------------------\r
-\r
-Special case\r
-~~~~~~~~~~~~\r
-\r
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish\r
-things, and we need local Ids for non-floated stuff):\r
-\r
- Don't float stuff out of a binder that's marked as a bottoming Id.\r
- Reason: it doesn't do any good, and creates more CAFs that increase\r
- the size of SRTs.\r
-\r
-eg.\r
-\r
- f = error "string"\r
-\r
-is translated to\r
-\r
- f' = unpackCString# "string"\r
- f = error f'\r
-\r
-hence f' and f become CAFs. Instead, the special case for\r
-tidyTopBinding below makes sure this comes out as\r
-\r
- f = let f' = unpackCString# "string" in error f'\r
-\r
-and we can safely ignore f as a CAF, since it can only ever be entered once.\r
-\r
-\r
-\r
-\begin{code}\r
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]\r
-doPostSimplification us binds_in\r
- = do\r
- beginPass "Post-simplification pass"\r
- let binds_out = initPM us (postSimplTopBinds binds_in)\r
- endPass "Post-simplification pass" opt_D_verbose_core2core binds_out\r
-\r
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]\r
-postSimplTopBinds binds\r
- = mapPM postSimplTopBind binds `thenPM` \ binds' ->\r
- returnPM (bagToList (unionManyBags binds'))\r
-\r
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)\r
-postSimplTopBind (NonRec bndr rhs)\r
- | isBottomingId bndr -- Don't lift out floats for bottoming Ids\r
- -- See notes above\r
- = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->\r
- returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))\r
-\r
-postSimplTopBind bind\r
- = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->\r
- returnPM (floats `snocBag` bind')\r
-\r
-postSimplBind (NonRec bndr rhs)\r
- = postSimplExpr rhs `thenPM` \ rhs' ->\r
- returnPM (NonRec bndr rhs')\r
-\r
-postSimplBind (Rec pairs)\r
- = mapPM postSimplExpr rhss `thenPM` \ rhss' ->\r
- returnPM (Rec (bndrs `zip` rhss'))\r
- where\r
- (bndrs, rhss) = unzip pairs\r
-\end{code}\r
-\r
-\r
-Expressions\r
-~~~~~~~~~~~\r
-\begin{code}\r
-postSimplExpr (Var v) = returnPM (Var v)\r
-postSimplExpr (Type ty) = returnPM (Type ty)\r
-\r
-postSimplExpr (App fun arg)\r
- = postSimplExpr fun `thenPM` \ fun' ->\r
- postSimplExpr arg `thenPM` \ arg' ->\r
- returnPM (App fun' arg')\r
-\r
-postSimplExpr (Con (Literal lit) args)\r
- = ASSERT( null args )\r
- litToRep lit `thenPM` \ (lit_ty, lit_expr) ->\r
- getInsideLambda `thenPM` \ in_lam ->\r
- if in_lam && not (exprIsTrivial lit_expr) then\r
- -- It must have been a no-rep literal with a\r
- -- non-trivial representation; and we're inside a lambda;\r
- -- so float it to the top\r
- addTopFloat lit_ty lit_expr `thenPM` \ v ->\r
- returnPM (Var v)\r
- else\r
- returnPM lit_expr\r
-\r
-postSimplExpr (Con con args)\r
- = mapPM postSimplExpr args `thenPM` \ args' ->\r
- returnPM (Con con args')\r
-\r
-postSimplExpr (Lam bndr body)\r
- = insideLambda bndr $\r
- postSimplExpr body `thenPM` \ body' ->\r
- returnPM (Lam bndr body')\r
-\r
-postSimplExpr (Let bind body)\r
- = postSimplBind bind `thenPM` \ bind' ->\r
- postSimplExprEta body `thenPM` \ body' ->\r
- returnPM (Let bind' body')\r
-\r
-postSimplExpr (Note note body)\r
- = postSimplExprEta body `thenPM` \ body' ->\r
- returnPM (Note note body')\r
-\r
-postSimplExpr (Case scrut case_bndr alts)\r
- = postSimplExpr scrut `thenPM` \ scrut' ->\r
- mapPM ps_alt alts `thenPM` \ alts' ->\r
- returnPM (Case scrut' case_bndr alts')\r
- where\r
- ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->\r
- returnPM (con, bndrs, rhs')\r
-\r
-postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->\r
- returnPM (etaCoreExpr e')\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection[coreToStg-lits]{Converting literals}\r
-%* *\r
-%************************************************************************\r
-\r
-Literals: the NoRep kind need to be de-no-rep'd.\r
-We always replace them with a simple variable, and float a suitable\r
-binding out to the top level.\r
-\r
-\begin{code}\r
-litToRep :: Literal -> PostM (Type, CoreExpr)\r
-\r
-litToRep (NoRepStr s ty)\r
- = returnPM (ty, rhs)\r
- where\r
- rhs = if (any is_NUL (_UNPK_ s))\r
-\r
- then -- Must cater for NULs in literal string\r
- mkApps (Var unpackCString2Id)\r
- [mkLit (MachStr s),\r
- mkLit (mkMachInt (toInteger (_LENGTH_ s)))]\r
-\r
- else -- No NULs in the string\r
- App (Var unpackCStringId) (mkLit (MachStr s))\r
-\r
- is_NUL c = c == '\0'\r
-\end{code}\r
-\r
-If an Integer is small enough (Haskell implementations must support\r
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;\r
-otherwise, wrap with @addr2Integer@.\r
-\r
-\begin{code}\r
-litToRep (NoRepInteger i integer_ty)\r
- = returnPM (integer_ty, rhs)\r
- where\r
- rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int\r
- i < tARGET_MAX_INT\r
- = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]\r
- \r
- | otherwise -- Big, so start from a string\r
- = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])\r
-\r
-\r
-litToRep (NoRepRational r rational_ty)\r
- = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->\r
- postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->\r
- returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])\r
- where\r
- (ratio_data_con, integer_ty)\r
- = case (splitAlgTyConApp_maybe rational_ty) of\r
- Just (tycon, [i_ty], [con])\r
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)\r
- (con, i_ty)\r
-\r
- _ -> (panic "ratio_data_con", panic "integer_ty")\r
-\r
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The monad}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-type PostM a = Bool -- True <=> inside a *value* lambda\r
- -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in \r
- -> (a, (UniqSupply, Bag CoreBind))\r
-\r
-initPM :: UniqSupply -> PostM a -> a\r
-initPM us m\r
- = case m False {- not inside lambda -} (us, emptyBag) of \r
- (result, _) -> result\r
-\r
-returnPM v in_lam usf = (v, usf)\r
-thenPM m k in_lam usf = case m in_lam usf of\r
- (r, usf') -> k r in_lam usf'\r
-\r
-mapPM f [] = returnPM []\r
-mapPM f (x:xs) = f x `thenPM` \ r ->\r
- mapPM f xs `thenPM` \ rs ->\r
- returnPM (r:rs)\r
-\r
-insideLambda :: CoreBndr -> PostM a -> PostM a\r
-insideLambda bndr m in_lam usf | isId bndr = m True usf\r
- | otherwise = m in_lam usf\r
-\r
-getInsideLambda :: PostM Bool\r
-getInsideLambda in_lam usf = (in_lam, usf)\r
-\r
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)\r
-getFloatsPM m in_lam (us, floats)\r
- = let\r
- (a, (us', floats')) = m in_lam (us, emptyBag)\r
- in\r
- ((a, floats'), (us', floats))\r
-\r
-addTopFloat :: Type -> CoreExpr -> PostM Id\r
-addTopFloat lit_ty lit_rhs in_lam (us, floats)\r
- = let\r
- (us1, us2) = splitUniqSupply us\r
- uniq = uniqFromSupply us1\r
- lit_id = mkSysLocal SLIT("lf") uniq lit_ty\r
- in\r
- (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))\r
-\end{code}\r
-\r
-\r
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[SimplCore]{Driver for simplifying @Core@ programs}
+
+\begin{code}
+module SimplCore ( core2core ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SwitchResult(..), switchIsOn, intSwitchSet,
+ opt_D_dump_occur_anal, opt_D_dump_rules,
+ opt_D_dump_simpl_iterations,
+ opt_D_dump_simpl_stats,
+ opt_D_dump_simpl, opt_D_dump_rules,
+ opt_D_verbose_core2core,
+ opt_D_dump_occur_anal,
+ opt_UsageSPOn,
+ )
+import CoreLint ( beginPass, endPass )
+import CoreSyn
+import CSE ( cseProgram )
+import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
+import CoreUnfold
+import PprCore ( pprCoreBindings )
+import OccurAnal ( occurAnalyseBinds )
+import CoreUtils ( exprIsTrivial, etaReduceExpr )
+import Simplify ( simplTopBinds, simplExpr )
+import SimplUtils ( findDefault, simplBinders )
+import SimplMonad
+import Literal ( Literal(..), literalType, mkMachInt )
+import ErrUtils ( dumpIfSet )
+import FloatIn ( floatInwards )
+import FloatOut ( floatOutwards )
+import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId, isDataConWrapId,
+ idType, setIdType, idName, idInfo, setIdNoDiscard
+ )
+import VarEnv
+import VarSet
+import Module ( Module )
+import Name ( mkLocalName, tidyOccName, tidyTopName,
+ NamedThing(..), OccName
+ )
+import TyCon ( TyCon, isDataTyCon )
+import PrelRules ( builtinRules )
+import Type ( Type,
+ isUnLiftedType,
+ tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
+ Type
+ )
+import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
+import LiberateCase ( liberateCase )
+import SAT ( doStaticArgs )
+import Specialise ( specProgram)
+import UsageSPInf ( doUsageSPInf )
+import StrictAnal ( saBinds )
+import WorkWrap ( wwTopBinds )
+import CprAnalyse ( cprAnalyse )
+
+import Unique ( Unique, Uniquable(..) )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
+import Util ( mapAccumL )
+import SrcLoc ( noSrcLoc )
+import Bag
+import Maybes
+import IO ( hPutStr, stderr )
+import Outputable
+
+import Ratio ( numerator, denominator )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
+\begin{code}
+core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
+ -> [CoreBind] -- Binds in
+ -> [ProtoCoreRule] -- Rules
+ -> IO ([CoreBind], [ProtoCoreRule])
+
+core2core core_todos binds rules
+ = do
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, us1) = splitUniqSupply us
+ (ru_us, ps_us) = splitUniqSupply us1
+
+ better_rules <- simplRules ru_us rules binds
+
+ let all_rules = builtinRules ++ better_rules
+ -- Here is where we add in the built-in rules
+
+ let (binds1, rule_base) = prepareRuleBase binds all_rules
+
+ -- Do the main business
+ (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
+ rule_base core_todos
+
+ dumpIfSet opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
+
+ -- Return results
+ return (processed_binds, filter orphanRule better_rules)
+
+
+doCorePasses stats us binds irs []
+ = return (stats, binds)
+
+doCorePasses stats us binds irs (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+ (stats1, binds1) <- doCorePass us1 binds irs to_do
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
+doCorePass us binds rb (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats (floatOutwards f us binds)
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf"
+ if opt_UsageSPOn then
+ noStats (doUsageSPInf us binds)
+ else
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+ noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Dealing with rules}
+%* *
+%************************************************************************
+
+We must do some gentle simplifiation on the template (but not the RHS)
+of each rule. The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+This doesn't match unless you do eta reduction on the build argument.
+
+\begin{code}
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
+simplRules us rules binds
+ = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
+
+ dumpIfSet opt_D_dump_rules
+ "Transformation rules"
+ (vcat (map pprProtoCoreRule better_rules))
+
+ return better_rules
+ where
+ black_list_all v = not (isDataConWrapId v)
+ -- This stops all inlining except the
+ -- wrappers for data constructors
+
+ sw_chkr any = SwBool False -- A bit bogus
+
+ -- Boringly, we need to gather the in-scope set.
+ -- Typically this thunk won't even be force, but the test in
+ -- simpVar fails if it isn't right, and it might conceivably matter
+ bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
+ | not is_local
+ = returnSmpl rule -- No need to fiddle with imported rules
+ | otherwise
+ = simplBinders bndrs $ \ bndrs' ->
+ mapSmpl simpl_arg args `thenSmpl` \ args' ->
+ simplExpr rhs `thenSmpl` \ rhs' ->
+ returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+
+simpl_arg e
+-- I've seen rules in which a LHS like
+-- augment g (build h)
+-- turns into
+-- augment (\a. g a) (build h)
+-- So it's a help to eta-reduce the args as we simplify them.
+-- Otherwise we don't match when given an argument like
+-- (\a. h a a)
+ = simplExpr e `thenSmpl` \ e' ->
+ returnSmpl (etaReduceExpr e')
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
+\begin{code}
+simplifyPgm :: RuleBase
+ -> (SimplifierSwitch -> SwitchResult)
+ -> UniqSupply
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
+
+simplifyPgm (imported_rule_ids, rule_lhs_fvs)
+ sw_chkr us binds
+ = do {
+ beginPass "Simplify";
+
+ -- Glom all binds together in one Rec, in case any
+ -- transformations have introduced any new dependencies
+ --
+ -- NB: the global invariant is this:
+ -- *** the top level bindings are never cloned, and are always unique ***
+ --
+ -- We sort them into dependency order, but applying transformation rules may
+ -- make something at the top refer to something at the bottom:
+ -- f = \x -> p (q x)
+ -- h = \y -> 3
+ --
+ -- RULE: p (q x) = h x
+ --
+ -- Applying this rule makes f refer to h, although it doesn't appear to in the
+ -- source program. Our solution is to do this occasional glom-together step,
+ -- just once per overall simplfication step.
+
+ let { recd_binds = [Rec (flattenBinds binds)] };
+
+ (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
+
+ dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+ "Simplifier statistics"
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+ text "",
+ pprSimplCount counts_out]);
+
+ endPass "Simplify"
+ (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
+ binds' ;
+
+ return (counts_out, binds')
+ }
+ where
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+
+ core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
+ | otherwise = empty
+
+ iteration us iteration_no counts binds
+ = do {
+ -- Occurrence analysis
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+
+ dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
+ (pprCoreBindings tagged_binds);
+
+ -- Simplify
+ let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
+ black_list_fn
+ (simplTopBinds tagged_binds);
+ -- The imported_rule_ids are used by initSmpl to initialise
+ -- the in-scope set. That way, the simplifier will change any
+ -- occurrences of the imported id to the one in the imported_rule_ids
+ -- set, which are decorated with their rules.
+
+ all_counts = counts `plusSimplCount` counts'
+ } ;
+
+ -- Stop if nothing happened; don't dump output
+ if isZeroSimplCount counts' then
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ else do {
+
+ -- Dump the result of this iteration
+ dumpIfSet opt_D_dump_simpl_iterations
+ ("Simplifier iteration " ++ show iteration_no
+ ++ " out of " ++ show max_iterations)
+ (pprSimplCount counts') ;
+
+ if opt_D_dump_simpl_iterations then
+ endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
+ opt_D_verbose_core2core
+ binds'
+ else
+ return [] ;
+
+ -- Stop if we've run out of iterations
+ if iteration_no == max_iterations then
+ do {
+#ifdef DEBUG
+ if max_iterations > 2 then
+ hPutStr stderr ("NOTE: Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out.\n")
+ else
+#endif
+ return ();
+
+ return ("Simplifier baled out", iteration_no, all_counts, binds')
+ }
+
+ -- Else loop
+ else iteration us2 (iteration_no + 1) all_counts binds'
+ } }
+ where
+ (us1, us2) = splitUniqSupply us
+\end{code}
projects / ghc-hetmet.git / blobdiff