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,
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 )
71 import SrcLoc ( noSrcLoc )
74 import IO ( hPutStr, stderr )
77 import Ratio ( numerator, denominator )
81 core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
82 -> Module -- Module name (profiling only)
83 -> [Class] -- Local classes
84 -> UniqSupply -- A name supply
85 -> [CoreBind] -- Input
86 -> IO [CoreBind] -- Result
88 core2core core_todos module_name classes us binds
90 let (us1, us2) = splitUniqSupply us
92 -- Do the main business
93 processed_binds <- doCorePasses us1 binds core_todos
95 -- Do the post-simplification business
96 post_simpl_binds <- doPostSimplification us2 processed_binds
98 -- Do the final tidy-up
99 final_binds <- tidyCorePgm module_name classes post_simpl_binds
104 doCorePasses us binds []
107 doCorePasses us binds (to_do : to_dos)
109 let (us1, us2) = splitUniqSupply us
110 binds1 <- doCorePass us1 binds to_do
111 doCorePasses us2 binds1 to_dos
113 doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds
114 doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds
115 doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
116 doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
117 doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
118 doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saWwTopBinds us binds
119 doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
123 %************************************************************************
125 \subsection{The driver for the simplifier}
127 %************************************************************************
130 simplifyPgm :: (SimplifierSwitch -> SwitchResult)
132 -> [CoreBind] -- Input
133 -> IO [CoreBind] -- New bindings
135 simplifyPgm sw_chkr us binds
137 beginPass "Simplify";
139 (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
141 dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
142 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
144 pprSimplCount counts]);
147 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
151 max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
152 simpl_switch_is_on = switchIsOn sw_chkr
154 core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
157 iteration us iteration_no counts binds
159 -- Occurrence analysis
160 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
161 dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
162 (pprCoreBindings tagged_binds);
165 let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
166 all_counts = counts `plusSimplCount` counts'
169 -- Stop if nothing happened; don't dump output
170 if isZeroSimplCount counts' then
171 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
174 -- Dump the result of this iteration
175 dumpIfSet opt_D_dump_simpl_iterations
176 ("Simplifier iteration " ++ show iteration_no
177 ++ " out of " ++ show max_iterations)
178 (vcat[pprSimplCount counts',
180 core_iter_dump binds']) ;
182 -- Stop if we've run out of iterations
183 if iteration_no == max_iterations then
185 if max_iterations > 1 then
186 hPutStr stderr ("NOTE: Simplifier still going after " ++
187 show max_iterations ++
188 " iterations; bailing out.\n")
191 return ("Simplifier baled out", iteration_no, all_counts, binds')
195 else iteration us2 (iteration_no + 1) all_counts binds'
198 (us1, us2) = splitUniqSupply us
201 simplTopBinds binds = go binds `thenSmpl` \ (binds', _) ->
204 go [] = returnSmpl ([], ())
205 go (bind1 : binds) = simplBind bind1 (go binds)
209 %************************************************************************
211 \subsection{Tidying core}
213 %************************************************************************
215 Several tasks are done by @tidyCorePgm@
217 1. Make certain top-level bindings into Globals. The point is that
218 Global things get externally-visible labels at code generation
222 2. Give all binders a nice print-name. Their uniques aren't changed;
223 rather we give them lexically unique occ-names, so that we can
224 safely print the OccNae only in the interface file. [Bad idea to
225 change the uniques, because the code generator makes global labels
226 from the uniques for local thunks etc.]
230 tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
231 tidyCorePgm mod local_classes binds_in
233 beginPass "Tidy Core"
234 let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
235 endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
237 -- Make sure to avoid the names of class operations
238 -- They don't have top-level bindings, so we won't see them
239 -- in binds_in; so we must initialise the tidy_env appropriately
241 -- We also make sure to avoid any exported binders. Consider
242 -- f{-u1-} = 1 -- Local decl
244 -- f{-u2-} = 2 -- Exported decl
246 -- The second exported decl must 'get' the name 'f', so we
247 -- have to put 'f' in the avoids list before we get to the first
248 -- decl. Name.tidyName then does a no-op on exported binders.
249 init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
250 avoids = [getOccName sel_id | cls <- local_classes,
251 sel_id <- classSelIds cls]
253 [getOccName bndr | bind <- binds_in,
254 bndr <- bindersOf bind,
257 tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
260 -> (TidyEnv, CoreBind)
261 tidyBind maybe_mod env (NonRec bndr rhs)
263 (env', bndr') = tidyBndr maybe_mod env bndr
264 rhs' = tidyExpr env rhs
266 (env', NonRec bndr' rhs')
268 tidyBind maybe_mod env (Rec pairs)
270 -- We use env' when tidying the rhss
271 -- When tidying the binder itself we may tidy it's
272 -- specialisations; if any of these mention other binders
273 -- in the group we should really feed env' to them too;
274 -- but that seems (a) unlikely and (b) a bit tiresome.
275 -- So I left it out for now
277 (bndrs, rhss) = unzip pairs
278 (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
279 rhss' = map (tidyExpr env') rhss
281 (env', Rec (zip bndrs' rhss'))
283 tidyExpr env (Type ty) = Type (tidyType env ty)
284 tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
285 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
286 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
288 tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
290 (env', b') = tidyBind Nothing env b
292 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
294 (env', b') = tidyNestedBndr env b
296 tidyExpr env (Var v) = case lookupVarEnv var_env v of
302 tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
304 (env', b') = tidyNestedBndr env b
306 tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
308 (env', vs') = mapAccumL tidyNestedBndr env vs
310 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
312 tidyNote env note = note
316 tidyBndr (Just mod) env id = tidyTopBndr mod env id
317 tidyBndr Nothing env var = tidyNestedBndr env var
319 tidyNestedBndr env tyvar
321 = tidyTyVar env tyvar
323 tidyNestedBndr env@(tidy_env, var_env) id
324 = -- Non-top-level variables
326 -- Give the Id a fresh print-name, *and* rename its type
327 -- The SrcLoc isn't important now, though we could extract it from the Id
328 name' = mkLocalName (getUnique id) occ' noSrcLoc
329 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
330 ty' = tidyType env (idType id)
331 id' = mkUserId name' ty'
332 -- NB: This throws away the IdInfo of the Id, which we
333 -- no longer need. That means we don't need to
334 -- run over it with env, nor renumber it.
335 var_env' = extendVarEnv var_env id id'
337 ((tidy_env', var_env'), id')
339 tidyTopBndr mod env@(tidy_env, var_env) id
340 = -- Top level variables
342 (tidy_env', name') = tidyTopName mod tidy_env (idName id)
343 ty' = tidyTopType (idType id)
344 idinfo' = tidyIdInfo env (idInfo id)
345 id' = mkId name' ty' (idDetails id) idinfo'
346 var_env' = extendVarEnv var_env id id'
348 ((tidy_env', var_env'), id')
350 -- tidyIdInfo does these things:
351 -- a) tidy the specialisation info (if any)
352 -- b) zap a complicated ICanSafelyBeINLINEd pragma,
353 -- c) zap the unfolding
354 -- The latter two are to avoid space leaks
359 spec_items = specEnvToList (specInfo info)
360 spec_env' = specEnvFromList (map tidy_item spec_items)
361 info1 | null spec_items = info
362 | otherwise = spec_env' `setSpecInfo` info
364 info2 = case inlinePragInfo info of
365 ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
368 info3 = noUnfolding `setUnfoldingInfo` info2
370 tidy_item (tyvars, tys, rhs)
371 = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)
373 (env', tyvars') = tidyTyVars env tyvars
378 %************************************************************************
380 \subsection{PostSimplification}
382 %************************************************************************
384 Several tasks are performed by the post-simplification pass
386 1. Make the representation of NoRep literals explicit, and
387 float their bindings to the top level. We only do the floating
388 part for NoRep lits inside a lambda (else no gain). We need to
389 take care with let x = "foo" in e
390 that we don't end up with a silly binding
392 with a floated "foo". What a bore.
394 2. *Mangle* cases involving par# in the discriminant. The unfolding
395 for par in PrelConc.lhs include case expressions with integer
396 results solely to fool the strictness analyzer, the simplifier,
397 and anyone else who might want to fool with the evaluation order.
398 At this point in the compiler our evaluation order is safe.
399 Therefore, we convert expressions of the form:
408 fork# isn't handled like this - it's an explicit IO operation now.
409 The reason is that fork# returns a ThreadId#, which gets in the
410 way of the above scheme. And anyway, IO is the only guaranteed
411 way to enforce ordering --SDM.
413 3. Mangle cases involving seq# in the discriminant. Up to this
414 point, seq# will appear like this:
420 where the 0# branch is purely to bamboozle the strictness analyser
421 (see case 4 above). This code comes from an unfolding for 'seq'
422 in Prelude.hs. We translate this into
427 Now that the evaluation order is safe.
429 4. Do eta reduction for lambda abstractions appearing in:
430 - the RHS of case alternatives
433 These will otherwise turn into local bindings during Core->STG;
434 better to nuke them if possible. (In general the simplifier does
435 eta expansion not eta reduction, up to this point. It does eta
436 on the RHSs of bindings but not the RHSs of case alternatives and
440 ------------------- NOT DONE ANY MORE ------------------------
441 [March 98] Indirections are now elimianted by the occurrence analyser
442 1. Eliminate indirections. The point here is to transform
448 [Dec 98] [Not now done because there is no penalty in the code
449 generator for using the former form]
451 case x of {...; x' -> ...x'...}
453 case x of {...; _ -> ...x... }
454 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
455 --------------------------------------------------------------
460 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
461 things, and we need local Ids for non-floated stuff):
463 Don't float stuff out of a binder that's marked as a bottoming Id.
464 Reason: it doesn't do any good, and creates more CAFs that increase
473 f' = unpackCString# "string"
476 hence f' and f become CAFs. Instead, the special case for
477 tidyTopBinding below makes sure this comes out as
479 f = let f' = unpackCString# "string" in error f'
481 and we can safely ignore f as a CAF, since it can only ever be entered once.
486 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
487 doPostSimplification us binds_in
489 beginPass "Post-simplification pass"
490 let binds_out = initPM us (postSimplTopBinds binds_in)
491 endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
493 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
494 postSimplTopBinds binds
495 = mapPM postSimplTopBind binds `thenPM` \ binds' ->
496 returnPM (bagToList (unionManyBags binds'))
498 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
499 postSimplTopBind (NonRec bndr rhs)
500 | isBottomingId bndr -- Don't lift out floats for bottoming Ids
502 = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
503 returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
505 postSimplTopBind bind
506 = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
507 returnPM (floats `snocBag` bind')
509 postSimplBind (NonRec bndr rhs)
510 = postSimplExpr rhs `thenPM` \ rhs' ->
511 returnPM (NonRec bndr rhs')
513 postSimplBind (Rec pairs)
514 = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
515 returnPM (Rec (bndrs `zip` rhss'))
517 (bndrs, rhss) = unzip pairs
524 postSimplExpr (Var v) = returnPM (Var v)
525 postSimplExpr (Type ty) = returnPM (Type ty)
527 postSimplExpr (App fun arg)
528 = postSimplExpr fun `thenPM` \ fun' ->
529 postSimplExpr arg `thenPM` \ arg' ->
530 returnPM (App fun' arg')
532 postSimplExpr (Con (Literal lit) args)
533 = ASSERT( null args )
534 litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
535 getInsideLambda `thenPM` \ in_lam ->
536 if in_lam && not (exprIsTrivial lit_expr) then
537 -- It must have been a no-rep literal with a
538 -- non-trivial representation; and we're inside a lambda;
539 -- so float it to the top
540 addTopFloat lit_ty lit_expr `thenPM` \ v ->
545 postSimplExpr (Con con args)
546 = mapPM postSimplExpr args `thenPM` \ args' ->
547 returnPM (Con con args')
549 postSimplExpr (Lam bndr body)
550 = insideLambda bndr $
551 postSimplExpr body `thenPM` \ body' ->
552 returnPM (Lam bndr body')
554 postSimplExpr (Let bind body)
555 = postSimplBind bind `thenPM` \ bind' ->
556 postSimplExprEta body `thenPM` \ body' ->
557 returnPM (Let bind' body')
559 postSimplExpr (Note note body)
560 = postSimplExprEta body `thenPM` \ body' ->
561 returnPM (Note note body')
563 -- seq#: see notes above.
564 -- NB: seq# :: forall a. a -> Int#
565 postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
566 = postSimplExpr e `thenPM` \ e' ->
568 -- The old binder can't have been used, so we
569 -- can gaily re-use it (yuk!)
570 new_bndr = setIdType bndr ty
572 postSimplExprEta default_rhs `thenPM` \ rhs' ->
573 returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
575 (other_alts, maybe_default) = findDefault alts
576 Just default_rhs = maybe_default
578 -- par#: see notes above.
579 postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
580 | funnyParallelOp op && maybeToBool maybe_default
581 = postSimplExpr scrut `thenPM` \ scrut' ->
582 postSimplExprEta default_rhs `thenPM` \ rhs' ->
583 returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
585 (other_alts, maybe_default) = findDefault alts
586 Just default_rhs = maybe_default
588 postSimplExpr (Case scrut case_bndr alts)
589 = postSimplExpr scrut `thenPM` \ scrut' ->
590 mapPM ps_alt alts `thenPM` \ alts' ->
591 returnPM (Case scrut' case_bndr alts')
593 ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
594 returnPM (con, bndrs, rhs')
596 postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
597 returnPM (etaCoreExpr e')
601 funnyParallelOp ParOp = True
602 funnyParallelOp _ = False
606 %************************************************************************
608 \subsection[coreToStg-lits]{Converting literals}
610 %************************************************************************
612 Literals: the NoRep kind need to be de-no-rep'd.
613 We always replace them with a simple variable, and float a suitable
614 binding out to the top level.
617 litToRep :: Literal -> PostM (Type, CoreExpr)
619 litToRep (NoRepStr s ty)
622 rhs = if (any is_NUL (_UNPK_ s))
624 then -- Must cater for NULs in literal string
625 mkApps (Var unpackCString2Id)
627 mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
629 else -- No NULs in the string
630 App (Var unpackCStringId) (mkLit (MachStr s))
635 If an Integer is small enough (Haskell implementations must support
636 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
637 otherwise, wrap with @litString2Integer@.
640 litToRep (NoRepInteger i integer_ty)
641 = returnPM (integer_ty, rhs)
643 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
644 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
645 | i == 2 = Var integerPlusTwoId
646 | i == (-1) = Var integerMinusOneId
648 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
650 = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
652 | otherwise -- Big, so start from a string
653 = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
656 litToRep (NoRepRational r rational_ty)
657 = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
658 postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
659 returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
661 (ratio_data_con, integer_ty)
662 = case (splitAlgTyConApp_maybe rational_ty) of
663 Just (tycon, [i_ty], [con])
664 -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
667 _ -> (panic "ratio_data_con", panic "integer_ty")
669 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
673 %************************************************************************
675 \subsection{The monad}
677 %************************************************************************
680 type PostM a = Bool -- True <=> inside a *value* lambda
681 -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
682 -> (a, (UniqSupply, Bag CoreBind))
684 initPM :: UniqSupply -> PostM a -> a
686 = case m False {- not inside lambda -} (us, emptyBag) of
687 (result, _) -> result
689 returnPM v in_lam usf = (v, usf)
690 thenPM m k in_lam usf = case m in_lam usf of
691 (r, usf') -> k r in_lam usf'
693 mapPM f [] = returnPM []
694 mapPM f (x:xs) = f x `thenPM` \ r ->
695 mapPM f xs `thenPM` \ rs ->
698 insideLambda :: CoreBndr -> PostM a -> PostM a
699 insideLambda bndr m in_lam usf | isId bndr = m True usf
700 | otherwise = m in_lam usf
702 getInsideLambda :: PostM Bool
703 getInsideLambda in_lam usf = (in_lam, usf)
705 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
706 getFloatsPM m in_lam (us, floats)
708 (a, (us', floats')) = m in_lam (us, emptyBag)
710 ((a, floats'), (us', floats))
712 addTopFloat :: Type -> CoreExpr -> PostM Id
713 addTopFloat lit_ty lit_rhs in_lam (us, floats)
715 (us1, us2) = splitUniqSupply us
716 uniq = uniqFromSupply us1
717 lit_id = mkSysLocal SLIT("lf") uniq lit_ty
719 (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))