2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
12 SwitchResult, switchIsOn,
13 opt_D_dump_occur_anal,
14 opt_D_dump_simpl_iterations,
15 opt_D_simplifier_stats,
17 opt_D_verbose_core2core,
20 import CoreLint ( beginPass, endPass )
22 import PprCore ( pprCoreBindings )
23 import OccurAnal ( occurAnalyseBinds )
24 import CoreUtils ( exprIsTrivial, coreExprType )
25 import Simplify ( simplBind )
26 import SimplUtils ( etaCoreExpr, findDefault )
29 import Const ( Con(..), Literal(..), literalType, mkMachInt )
30 import ErrUtils ( dumpIfSet )
31 import FloatIn ( floatInwards )
32 import FloatOut ( floatOutwards )
33 import Id ( Id, mkSysLocal, mkUserId, isBottomingId,
34 idType, setIdType, idName, idInfo, idDetails
36 import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
37 inlinePragInfo, setInlinePragInfo,
42 import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
43 Module, NamedThing(..), OccName
45 import TyCon ( TyCon, isDataTyCon )
46 import PrimOp ( PrimOp(..) )
47 import PrelInfo ( unpackCStringId, unpackCString2Id,
48 integerZeroId, integerPlusOneId,
49 integerPlusTwoId, integerMinusOneId,
50 int2IntegerId, addr2IntegerId
52 import Type ( Type, splitAlgTyConApp_maybe,
53 isUnLiftedType, mkTyVarTy,
54 tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
57 import Class ( Class, classSelIds )
58 import TysWiredIn ( isIntegerTy )
59 import LiberateCase ( liberateCase )
60 import SAT ( doStaticArgs )
61 import Specialise ( specProgram)
62 import SpecEnv ( specEnvToList, specEnvFromList )
63 import StrictAnal ( saWwTopBinds )
64 import Var ( TyVar, mkId )
65 import Unique ( Unique, Uniquable(..),
66 ratioTyConKey, mkUnique, incrUnique, initTidyUniques
68 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
69 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
70 import Util ( mapAccumL )
73 import IO ( hPutStr, stderr )
78 core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
79 -> Module -- Module name (profiling only)
80 -> [Class] -- Local classes
81 -> UniqSupply -- A name supply
82 -> [CoreBind] -- Input
83 -> IO [CoreBind] -- Result
85 core2core core_todos module_name classes us binds
87 let (us1, us2) = splitUniqSupply us
89 -- Do the main business
90 processed_binds <- doCorePasses us1 binds core_todos
92 -- Do the post-simplification business
93 post_simpl_binds <- doPostSimplification us2 processed_binds
95 -- Do the final tidy-up
96 final_binds <- tidyCorePgm module_name classes post_simpl_binds
101 doCorePasses us binds []
104 doCorePasses us binds (to_do : to_dos)
106 let (us1, us2) = splitUniqSupply us
107 binds1 <- doCorePass us1 binds to_do
108 doCorePasses us2 binds1 to_dos
110 doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds
111 doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds
112 doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
113 doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
114 doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
115 doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saWwTopBinds us binds
116 doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
120 %************************************************************************
122 \subsection{The driver for the simplifier}
124 %************************************************************************
127 simplifyPgm :: (SimplifierSwitch -> SwitchResult)
129 -> [CoreBind] -- Input
130 -> IO [CoreBind] -- New bindings
132 simplifyPgm sw_chkr us binds
134 beginPass "Simplify";
136 (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
138 dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
139 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
141 pprSimplCount counts]);
144 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
148 max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
149 simpl_switch_is_on = switchIsOn sw_chkr
151 core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
154 iteration us iteration_no counts binds
156 -- Occurrence analysis
157 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
158 dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
159 (pprCoreBindings tagged_binds);
162 let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
163 all_counts = counts `plusSimplCount` counts'
166 -- Stop if nothing happened; don't dump output
167 if isZeroSimplCount counts' then
168 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
171 -- Dump the result of this iteration
172 dumpIfSet opt_D_dump_simpl_iterations
173 ("Simplifier iteration " ++ show iteration_no
174 ++ " out of " ++ show max_iterations)
175 (vcat[pprSimplCount counts',
177 core_iter_dump binds']) ;
179 -- Stop if we've run out of iterations
180 if iteration_no == max_iterations then
182 if max_iterations > 1 then
183 hPutStr stderr ("NOTE: Simplifier still going after " ++
184 show max_iterations ++
185 " iterations; bailing out.\n")
188 return ("Simplifier baled out", iteration_no, all_counts, binds')
192 else iteration us2 (iteration_no + 1) all_counts binds'
195 (us1, us2) = splitUniqSupply us
198 simplTopBinds binds = go binds `thenSmpl` \ (binds', _) ->
201 go [] = returnSmpl ([], ())
202 go (bind1 : binds) = simplBind bind1 (go binds)
206 %************************************************************************
208 \subsection{Tidying core}
210 %************************************************************************
212 Several tasks are done by @tidyCorePgm@
214 1. Make certain top-level bindings into Globals. The point is that
215 Global things get externally-visible labels at code generation
219 2. Give all binders a nice print-name. Their uniques aren't changed;
220 rather we give them lexically unique occ-names, so that we can
221 safely print the OccNae only in the interface file. [Bad idea to
222 change the uniques, because the code generator makes global labels
223 from the uniques for local thunks etc.]
227 tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
228 tidyCorePgm mod local_classes binds_in
230 beginPass "Tidy Core"
231 let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
232 endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
234 -- Make sure to avoid the names of class operations
235 -- They don't have top-level bindings, so we won't see them
236 -- in binds_in; so we must initialise the tidy_env appropriately
238 -- We also make sure to avoid any exported binders. Consider
239 -- f{-u1-} = 1 -- Local decl
241 -- f{-u2-} = 2 -- Exported decl
243 -- The second exported decl must 'get' the name 'f', so we
244 -- have to put 'f' in the avoids list before we get to the first
245 -- decl. Name.tidyName then does a no-op on exported binders.
246 init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
247 avoids = [getOccName sel_id | cls <- local_classes,
248 sel_id <- classSelIds cls]
250 [getOccName bndr | bind <- binds_in,
251 bndr <- bindersOf bind,
254 tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
257 -> (TidyEnv, CoreBind)
258 tidyBind maybe_mod env (NonRec bndr rhs)
260 (env', bndr') = tidyBndr maybe_mod env bndr
261 rhs' = tidyExpr env rhs
263 (env', NonRec bndr' rhs')
265 tidyBind maybe_mod env (Rec pairs)
267 -- We use env' when tidying the rhss
268 -- When tidying the binder itself we may tidy it's
269 -- specialisations; if any of these mention other binders
270 -- in the group we should really feed env' to them too;
271 -- but that seems (a) unlikely and (b) a bit tiresome.
272 -- So I left it out for now
274 (bndrs, rhss) = unzip pairs
275 (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
276 rhss' = map (tidyExpr env') rhss
278 (env', Rec (zip bndrs' rhss'))
280 tidyExpr env (Type ty) = Type (tidyType env ty)
281 tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
282 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
283 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
285 tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
287 (env', b') = tidyBind Nothing env b
289 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
291 (env', b') = tidyNestedBndr env b
293 tidyExpr env (Var v) = case lookupVarEnv var_env v of
299 tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
301 (env', b') = tidyNestedBndr env b
303 tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
305 (env', vs') = mapAccumL tidyNestedBndr env vs
307 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
311 tidyBndr (Just mod) env id = tidyTopBndr mod env id
312 tidyBndr Nothing env var = tidyNestedBndr env var
314 tidyNestedBndr env tyvar
316 = tidyTyVar env tyvar
318 tidyNestedBndr env@(tidy_env, var_env) id
319 = -- Non-top-level variables
321 -- Give the Id a fresh print-name, *and* rename its type
322 name' = mkLocalName (getUnique id) occ'
323 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
324 ty' = tidyType env (idType id)
325 id' = mkUserId name' ty'
326 -- NB: This throws away the IdInfo of the Id, which we
327 -- no longer need. That means we don't need to
328 -- run over it with env, nor renumber it.
329 var_env' = extendVarEnv var_env id id'
331 ((tidy_env', var_env'), id')
333 tidyTopBndr mod env@(tidy_env, var_env) id
334 = -- Top level variables
336 (tidy_env', name') = tidyTopName mod tidy_env (idName id)
337 ty' = tidyTopType (idType id)
338 idinfo' = tidyIdInfo env (idInfo id)
339 id' = mkId name' ty' (idDetails id) idinfo'
340 var_env' = extendVarEnv var_env id id'
342 ((tidy_env', var_env'), id')
344 -- tidyIdInfo does these things:
345 -- a) tidy the specialisation info (if any)
346 -- b) zap a complicated ICanSafelyBeINLINEd pragma,
347 -- c) zap the unfolding
348 -- The latter two are to avoid space leaks
353 spec_items = specEnvToList (specInfo info)
354 spec_env' = specEnvFromList (map tidy_item spec_items)
355 info1 | null spec_items = info
356 | otherwise = spec_env' `setSpecInfo` info
358 info2 = case inlinePragInfo info of
359 ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
362 info3 = noUnfolding `setUnfoldingInfo` info2
364 tidy_item (tyvars, tys, rhs)
365 = (tyvars', tidyTypes env' tys, tidyExpr env rhs)
367 (env', tyvars') = tidyTyVars env tyvars
372 %************************************************************************
374 \subsection{PostSimplification}
376 %************************************************************************
378 Several tasks are performed by the post-simplification pass
380 1. Make the representation of NoRep literals explicit, and
381 float their bindings to the top level. We only do the floating
382 part for NoRep lits inside a lambda (else no gain). We need to
383 take care with let x = "foo" in e
384 that we don't end up with a silly binding
386 with a floated "foo". What a bore.
388 2. *Mangle* cases involving par# in the discriminant. The unfolding
389 for par in PrelConc.lhs include case expressions with integer
390 results solely to fool the strictness analyzer, the simplifier,
391 and anyone else who might want to fool with the evaluation order.
392 At this point in the compiler our evaluation order is safe.
393 Therefore, we convert expressions of the form:
402 fork# isn't handled like this - it's an explicit IO operation now.
403 The reason is that fork# returns a ThreadId#, which gets in the
404 way of the above scheme. And anyway, IO is the only guaranteed
405 way to enforce ordering --SDM.
407 3. Mangle cases involving seq# in the discriminant. Up to this
408 point, seq# will appear like this:
414 where the 0# branch is purely to bamboozle the strictness analyser
415 (see case 4 above). This code comes from an unfolding for 'seq'
416 in Prelude.hs. We translate this into
421 Now that the evaluation order is safe.
423 4. Do eta reduction for lambda abstractions appearing in:
424 - the RHS of case alternatives
427 These will otherwise turn into local bindings during Core->STG;
428 better to nuke them if possible. (In general the simplifier does
429 eta expansion not eta reduction, up to this point. It does eta
430 on the RHSs of bindings but not the RHSs of case alternatives and
434 ------------------- NOT DONE ANY MORE ------------------------
435 [March 98] Indirections are now elimianted by the occurrence analyser
436 1. Eliminate indirections. The point here is to transform
442 [Dec 98] [Not now done because there is no penalty in the code
443 generator for using the former form]
445 case x of {...; x' -> ...x'...}
447 case x of {...; _ -> ...x... }
448 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
449 --------------------------------------------------------------
454 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
455 things, and we need local Ids for non-floated stuff):
457 Don't float stuff out of a binder that's marked as a bottoming Id.
458 Reason: it doesn't do any good, and creates more CAFs that increase
467 f' = unpackCString# "string"
470 hence f' and f become CAFs. Instead, the special case for
471 tidyTopBinding below makes sure this comes out as
473 f = let f' = unpackCString# "string" in error f'
475 and we can safely ignore f as a CAF, since it can only ever be entered once.
480 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
481 doPostSimplification us binds_in
483 beginPass "Post-simplification pass"
484 let binds_out = initPM us (postSimplTopBinds binds_in)
485 endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
487 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
488 postSimplTopBinds binds
489 = mapPM postSimplTopBind binds `thenPM` \ binds' ->
490 returnPM (bagToList (unionManyBags binds'))
492 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
493 postSimplTopBind (NonRec bndr rhs)
494 | isBottomingId bndr -- Don't lift out floats for bottoming Ids
496 = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
497 returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
499 postSimplTopBind bind
500 = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
501 returnPM (floats `snocBag` bind')
503 postSimplBind (NonRec bndr rhs)
504 = postSimplExpr rhs `thenPM` \ rhs' ->
505 returnPM (NonRec bndr rhs')
507 postSimplBind (Rec pairs)
508 = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
509 returnPM (Rec (bndrs `zip` rhss'))
511 (bndrs, rhss) = unzip pairs
518 postSimplExpr (Var v) = returnPM (Var v)
519 postSimplExpr (Type ty) = returnPM (Type ty)
521 postSimplExpr (App fun arg)
522 = postSimplExpr fun `thenPM` \ fun' ->
523 postSimplExpr arg `thenPM` \ arg' ->
524 returnPM (App fun' arg')
526 postSimplExpr (Con (Literal lit) args)
527 = ASSERT( null args )
528 litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
529 getInsideLambda `thenPM` \ in_lam ->
530 if in_lam && not (exprIsTrivial lit_expr) then
531 -- It must have been a no-rep literal with a
532 -- non-trivial representation; and we're inside a lambda;
533 -- so float it to the top
534 addTopFloat lit_ty lit_expr `thenPM` \ v ->
539 postSimplExpr (Con con args)
540 = mapPM postSimplExpr args `thenPM` \ args' ->
541 returnPM (Con con args')
543 postSimplExpr (Lam bndr body)
544 = insideLambda bndr $
545 postSimplExpr body `thenPM` \ body' ->
546 returnPM (Lam bndr body')
548 postSimplExpr (Let bind body)
549 = postSimplBind bind `thenPM` \ bind' ->
550 postSimplExprEta body `thenPM` \ body' ->
551 returnPM (Let bind' body')
553 postSimplExpr (Note note body)
554 = postSimplExprEta body `thenPM` \ body' ->
555 returnPM (Note note body')
557 -- seq#: see notes above.
558 -- NB: seq# :: forall a. a -> Int#
559 postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
560 = postSimplExpr e `thenPM` \ e' ->
562 -- The old binder can't have been used, so we
563 -- can gaily re-use it (yuk!)
564 new_bndr = setIdType bndr ty
566 postSimplExprEta default_rhs `thenPM` \ rhs' ->
567 returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
569 (other_alts, maybe_default) = findDefault alts
570 Just default_rhs = maybe_default
572 -- par#: see notes above.
573 postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
574 | funnyParallelOp op && maybeToBool maybe_default
575 = postSimplExpr scrut `thenPM` \ scrut' ->
576 postSimplExprEta default_rhs `thenPM` \ rhs' ->
577 returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
579 (other_alts, maybe_default) = findDefault alts
580 Just default_rhs = maybe_default
582 postSimplExpr (Case scrut case_bndr alts)
583 = postSimplExpr scrut `thenPM` \ scrut' ->
584 mapPM ps_alt alts `thenPM` \ alts' ->
585 returnPM (Case scrut' case_bndr alts')
587 ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
588 returnPM (con, bndrs, rhs')
590 postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
591 returnPM (etaCoreExpr e')
595 funnyParallelOp ParOp = True
596 funnyParallelOp _ = False
600 %************************************************************************
602 \subsection[coreToStg-lits]{Converting literals}
604 %************************************************************************
606 Literals: the NoRep kind need to be de-no-rep'd.
607 We always replace them with a simple variable, and float a suitable
608 binding out to the top level.
611 litToRep :: Literal -> PostM (Type, CoreExpr)
613 litToRep (NoRepStr s ty)
616 rhs = if (any is_NUL (_UNPK_ s))
618 then -- Must cater for NULs in literal string
619 mkApps (Var unpackCString2Id)
621 mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
623 else -- No NULs in the string
624 App (Var unpackCStringId) (mkLit (MachStr s))
629 If an Integer is small enough (Haskell implementations must support
630 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
631 otherwise, wrap with @litString2Integer@.
634 litToRep (NoRepInteger i integer_ty)
635 = returnPM (integer_ty, rhs)
637 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
638 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
639 | i == 2 = Var integerPlusTwoId
640 | i == (-1) = Var integerMinusOneId
642 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
644 = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
646 | otherwise -- Big, so start from a string
647 = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
650 litToRep (NoRepRational r rational_ty)
651 = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
652 postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
653 returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
655 (ratio_data_con, integer_ty)
656 = case (splitAlgTyConApp_maybe rational_ty) of
657 Just (tycon, [i_ty], [con])
658 -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
661 _ -> (panic "ratio_data_con", panic "integer_ty")
663 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
667 %************************************************************************
669 \subsection{The monad}
671 %************************************************************************
674 type PostM a = Bool -- True <=> inside a *value* lambda
675 -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
676 -> (a, (UniqSupply, Bag CoreBind))
678 initPM :: UniqSupply -> PostM a -> a
680 = case m False {- not inside lambda -} (us, emptyBag) of
681 (result, _) -> result
683 returnPM v in_lam usf = (v, usf)
684 thenPM m k in_lam usf = case m in_lam usf of
685 (r, usf') -> k r in_lam usf'
687 mapPM f [] = returnPM []
688 mapPM f (x:xs) = f x `thenPM` \ r ->
689 mapPM f xs `thenPM` \ rs ->
692 insideLambda :: CoreBndr -> PostM a -> PostM a
693 insideLambda bndr m in_lam usf | isId bndr = m True usf
694 | otherwise = m in_lam usf
696 getInsideLambda :: PostM Bool
697 getInsideLambda in_lam usf = (in_lam, usf)
699 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
700 getFloatsPM m in_lam (us, floats)
702 (a, (us', floats')) = m in_lam (us, emptyBag)
704 ((a, floats'), (us', floats))
706 addTopFloat :: Type -> CoreExpr -> PostM Id
707 addTopFloat lit_ty lit_rhs in_lam (us, floats)
709 (us1, us2) = splitUniqSupply us
710 uniq = uniqFromSupply us1
711 lit_id = mkSysLocal SLIT("lf") uniq lit_ty
713 (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))