2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core ) where
9 #include "HsVersions.h"
11 import AnalFBWW ( analFBWW )
12 import Bag ( isEmptyBag, foldBag )
13 import BinderInfo ( BinderInfo{-instance Outputable-} )
14 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
16 opt_D_simplifier_stats,
18 opt_D_verbose_core2core,
21 opt_ReportWhyUnfoldingsDisallowed,
23 opt_LiberateCaseThreshold
25 import CoreLint ( lintCoreBindings )
27 import CoreUtils ( coreExprType )
28 import SimplUtils ( etaCoreExpr, typeOkForCase )
30 import Literal ( Literal(..), literalType, mkMachInt )
31 import ErrUtils ( ghcExit, dumpIfSet, doIfSet )
32 import FiniteMap ( FiniteMap, emptyFM )
33 import FloatIn ( floatInwards )
34 import FloatOut ( floatOutwards )
35 import FoldrBuildWW ( mkFoldrBuildWW )
36 import MkId ( mkSysLocal, mkUserId )
37 import Id ( setIdVisibility,
38 getIdDemandInfo, idType,
39 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
43 import IdInfo ( willBeDemanded, DemandInfo )
44 import Name ( isExported, isLocallyDefined,
45 isLocalName, uniqToOccName,
47 Module, NamedThing(..), OccName(..)
49 import TyCon ( TyCon )
50 import PrimOp ( PrimOp(..) )
51 import PrelVals ( unpackCStringId, unpackCString2Id,
52 integerZeroId, integerPlusOneId,
53 integerPlusTwoId, integerMinusOneId
55 import Type ( splitAlgTyConApp_maybe, isUnpointedType, Type )
56 import TysWiredIn ( stringTy, isIntegerTy )
57 import LiberateCase ( liberateCase )
58 import MagicUFs ( MagicUnfoldingFun )
60 import PprType ( nmbrType )
61 import SAT ( doStaticArgs )
62 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
63 import SimplPgm ( simplifyPgm )
65 import StrictAnal ( saWwTopBinds )
66 import TyVar ( TyVar, nameTyVar )
67 import Unique ( Unique{-instance Eq-}, Uniquable(..),
68 integerTyConKey, ratioTyConKey,
72 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
73 splitUniqSupply, getUnique
75 import UniqFM ( UniqFM, lookupUFM, addToUFM )
76 import Util ( mapAccumL )
77 import SrcLoc ( noSrcLoc )
78 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
81 import IO ( hPutStr, stderr )
86 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
87 -> FAST_STRING -- module name (profiling only)
88 -> UniqSupply -- a name supply
89 -> [TyCon] -- local data tycons and tycon specialisations
90 -> [CoreBinding] -- input...
91 -> IO [CoreBinding] -- results: program
93 core2core core_todos module_name us local_tycons binds
94 = -- Do the main business
96 (binds, us, zeroSimplCount)
98 >>= \ (processed_binds, us', simpl_stats) ->
100 -- Do the final tidy-up
102 final_binds = tidyCorePgm module_name processed_binds
104 lintCoreBindings "TidyCorePgm" True final_binds >>
108 dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
109 "Core transformations"
110 (pprCoreBindings final_binds) >>
113 doIfSet opt_D_simplifier_stats
114 (hPutStr stderr ("\nSimplifier Stats:\n") >>
115 hPutStr stderr (showSimplCount simpl_stats) >>
116 hPutStr stderr "\n") >>
122 do_core_pass info@(binds, us, simpl_stats) to_do =
123 case (splitUniqSupply us) of
126 CoreDoSimplify simpl_sw_chkr
127 -> _scc_ "CoreSimplify"
128 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
129 then " (foldr/build)" else "") >>
130 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
131 (p, it_cnt, simpl_stats2)
132 -> end_pass us2 p simpl_stats2
133 ("Simplify (" ++ show it_cnt ++ ")"
134 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
135 then " foldr/build" else "")
137 CoreDoFoldrBuildWorkerWrapper
138 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
140 case (mkFoldrBuildWW us1 binds) of { binds2 ->
141 end_pass us2 binds2 simpl_stats "FBWW" }
143 CoreDoFoldrBuildWWAnal
144 -> _scc_ "CoreDoFoldrBuildWWAnal"
145 begin_pass "AnalFBWW" >>
146 case (analFBWW binds) of { binds2 ->
147 end_pass us2 binds2 simpl_stats "AnalFBWW" }
150 -> _scc_ "LiberateCase"
151 begin_pass "LiberateCase" >>
152 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
153 end_pass us2 binds2 simpl_stats "LiberateCase" }
156 -> _scc_ "FloatInwards"
157 begin_pass "FloatIn" >>
158 case (floatInwards binds) of { binds2 ->
159 end_pass us2 binds2 simpl_stats "FloatIn" }
162 -> _scc_ "CoreFloating"
163 begin_pass "FloatOut" >>
164 case (floatOutwards us1 binds) of { binds2 ->
165 end_pass us2 binds2 simpl_stats "FloatOut" }
168 -> _scc_ "CoreStaticArgs"
169 begin_pass "StaticArgs" >>
170 case (doStaticArgs binds us1) of { binds2 ->
171 end_pass us2 binds2 simpl_stats "StaticArgs" }
172 -- Binds really should be dependency-analysed for static-
173 -- arg transformation... Not to worry, they probably are.
174 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
177 -> _scc_ "CoreStranal"
178 begin_pass "StrAnal" >>
179 case (saWwTopBinds us1 binds) of { binds2 ->
180 end_pass us2 binds2 simpl_stats "StrAnal" }
183 -> _scc_ "Specialise"
184 begin_pass "Specialise" >>
185 case (specProgram us1 binds) of { p ->
186 end_pass us2 p simpl_stats "Specialise"
189 CoreDoPrintCore -- print result of last pass
190 -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
191 (pprCoreBindings binds) >>
192 return (binds, us1, simpl_stats)
194 -------------------------------------------------
197 = if opt_D_show_passes
198 then hPutStr stderr ("*** Core2Core: "++what++"\n")
203 = -- Report verbosely, if required
204 dumpIfSet opt_D_verbose_core2core what
205 (pprCoreBindings binds2) >>
207 lintCoreBindings what True {- spec_done -} binds2 >>
208 -- The spec_done flag tells the linter to
209 -- complain about unboxed let-bindings
210 -- But we're not specialising unboxed types any more,
211 -- so its irrelevant.
214 (binds2, -- processed binds, possibly run thru CoreLint
215 us2, -- UniqSupply for the next guy
216 simpl_stats2 -- accumulated simplifier stats
220 -- here so it can be inlined...
221 foldl_mn f z [] = return z
222 foldl_mn f z (x:xs) = f z x >>= \ zz ->
228 %************************************************************************
230 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
232 %************************************************************************
234 Several tasks are done by @tidyCorePgm@
237 [March 98] Indirections are now elimianted by the occurrence analyser
238 -- 1. Eliminate indirections. The point here is to transform
240 -- x_exported = x_local
244 2. Make certain top-level bindings into Globals. The point is that
245 Global things get externally-visible labels at code generation
248 3. Make the representation of NoRep literals explicit, and
249 float their bindings to the top level
252 case x of {...; x' -> ...x'...}
254 case x of {...; _ -> ...x... }
255 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
257 5. *Mangle* cases involving fork# and par# in the discriminant. The
258 original templates for these primops (see @PrelVals.lhs@) constructed
259 case expressions with boolean results solely to fool the strictness
260 analyzer, the simplifier, and anyone else who might want to fool with
261 the evaluation order. At this point in the compiler our evaluation
262 order is safe. Therefore, we convert expressions of the form:
271 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
273 7. Do eta reduction for lambda abstractions appearing in:
274 - the RHS of case alternatives
276 These will otherwise turn into local bindings during Core->STG; better to
277 nuke them if possible. (In general the simplifier does eta expansion not
278 eta reduction, up to this point.)
280 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
281 for multi-constructor types.
283 9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
284 them lexically unique occ-names, so that we can safely print the OccNae only
285 in the interface file. [Bad idea to change the uniques, because the code
286 generator makes global labels from the uniques for local thunks etc.]
292 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
294 tidyCorePgm mod binds_in
295 = initTM mod nullIdEnv $
296 tidyTopBindings binds_in `thenTM` \ binds ->
297 returnTM (bagToList binds)
303 tidyTopBindings [] = returnTM emptyBag
304 tidyTopBindings (b:bs)
308 tidyTopBinding :: CoreBinding
309 -> TopTidyM (Bag CoreBinding)
310 -> TopTidyM (Bag CoreBinding)
312 tidyTopBinding (NonRec bndr rhs) thing_inside
313 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
314 mungeTopBinder bndr $ \ bndr' ->
315 thing_inside `thenTM` \ binds ->
316 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
318 tidyTopBinding (Rec pairs) thing_inside
319 = mungeTopBinders binders $ \ binders' ->
320 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
321 thing_inside `thenTM` \ binds_inside ->
322 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
324 (binders, rhss) = unzip pairs
332 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
335 tidyCoreExpr (Lit lit)
336 = litToRep lit `thenTM` \ (_, lit_expr) ->
339 tidyCoreExpr (App fun arg)
340 = tidyCoreExpr fun `thenTM` \ fun' ->
341 tidyCoreArg arg `thenTM` \ arg' ->
342 returnTM (App fun' arg')
344 tidyCoreExpr (Con con args)
345 = mapTM tidyCoreArg args `thenTM` \ args' ->
346 returnTM (Con con args')
348 tidyCoreExpr (Prim prim args)
349 = tidyPrimOp prim `thenTM` \ prim' ->
350 mapTM tidyCoreArg args `thenTM` \ args' ->
351 returnTM (Prim prim' args')
353 tidyCoreExpr (Lam (ValBinder v) body)
355 tidyCoreExpr body `thenTM` \ body' ->
356 returnTM (Lam (ValBinder v') body')
358 tidyCoreExpr (Lam (TyBinder tv) body)
359 = newTyVar tv $ \ tv' ->
360 tidyCoreExpr body `thenTM` \ body' ->
361 returnTM (Lam (TyBinder tv') body')
363 -- Try for let-to-case (see notes in Simplify.lhs for why
364 -- some let-to-case stuff is deferred to now).
365 tidyCoreExpr (Let (NonRec bndr rhs) body)
366 | willBeDemanded (getIdDemandInfo bndr) &&
367 not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
368 typeOkForCase (idType bndr)
369 = ASSERT( not (isUnpointedType (idType bndr)) )
370 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
372 rhs_is_whnf = case mkFormSummary rhs of
377 tidyCoreExpr (Let (NonRec bndr rhs) body)
378 = tidyCoreExpr rhs `thenTM` \ rhs' ->
379 newId bndr $ \ bndr' ->
380 tidyCoreExprEta body `thenTM` \ body' ->
381 returnTM (Let (NonRec bndr' rhs') body')
383 tidyCoreExpr (Let (Rec pairs) body)
384 = newIds bndrs $ \ bndrs' ->
385 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
386 tidyCoreExprEta body `thenTM` \ body' ->
387 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
389 (bndrs, rhss) = unzip pairs
391 tidyCoreExpr (Note (Coerce to_ty from_ty) body)
392 = tidyCoreExprEta body `thenTM` \ body' ->
393 tidyTy to_ty `thenTM` \ to_ty' ->
394 tidyTy from_ty `thenTM` \ from_ty' ->
395 returnTM (Note (Coerce to_ty' from_ty') body')
397 tidyCoreExpr (Note note body)
398 = tidyCoreExprEta body `thenTM` \ body' ->
399 returnTM (Note note body')
401 -- Wierd case for par, seq, fork etc. See notes above.
402 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
404 = tidyCoreExpr scrut `thenTM` \ scrut' ->
405 newId binder $ \ binder' ->
406 tidyCoreExprEta rhs `thenTM` \ rhs' ->
407 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
409 -- Eliminate polymorphic case, for which we can't generate code just yet
410 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
411 | not (typeOkForCase (idType deflt_bndr))
412 = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
414 Var v -> lookupId v `thenTM` \ v' ->
415 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
416 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
418 tidyCoreExpr (Case scrut alts)
419 = tidyCoreExpr scrut `thenTM` \ scrut' ->
420 tidy_alts scrut' alts `thenTM` \ alts' ->
421 returnTM (Case scrut' alts')
423 tidy_alts scrut (AlgAlts alts deflt)
424 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
425 tidy_deflt scrut deflt `thenTM` \ deflt' ->
426 returnTM (AlgAlts alts' deflt')
428 tidy_alts scrut (PrimAlts alts deflt)
429 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
430 tidy_deflt scrut deflt `thenTM` \ deflt' ->
431 returnTM (PrimAlts alts' deflt')
433 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
434 tidyCoreExprEta rhs `thenTM` \ rhs' ->
435 returnTM (con, bndrs', rhs')
437 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
440 -- We convert case x of {...; x' -> ...x'...}
442 -- case x of {...; _ -> ...x... }
444 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
445 -- It's quite easily done: simply extend the environment to bind the
446 -- default binder to the scrutinee.
448 tidy_deflt scrut NoDefault = returnTM NoDefault
449 tidy_deflt scrut (BindDefault bndr rhs)
450 = newId bndr $ \ bndr' ->
451 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
452 returnTM (BindDefault bndr' rhs')
454 extend_env = case scrut of
455 Var v -> extendEnvTM bndr v
458 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
459 returnTM (etaCoreExpr e')
465 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
467 tidyCoreArg (VarArg v)
468 = lookupId v `thenTM` \ v' ->
471 tidyCoreArg (LitArg lit)
472 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
474 Var v -> returnTM (VarArg v)
475 Lit l -> returnTM (LitArg l)
476 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
479 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
484 tidyPrimOp (CCallOp fn casm gc tys ty)
485 = mapTM tidyTy tys `thenTM` \ tys' ->
486 tidyTy ty `thenTM` \ ty' ->
487 returnTM (CCallOp fn casm gc tys' ty')
489 tidyPrimOp other_prim_op = returnTM other_prim_op
493 %************************************************************************
495 \subsection[coreToStg-lits]{Converting literals}
497 %************************************************************************
499 Literals: the NoRep kind need to be de-no-rep'd.
500 We always replace them with a simple variable, and float a suitable
501 binding out to the top level.
505 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
507 litToRep (NoRepStr s)
508 = returnTM (stringTy, rhs)
510 rhs = if (any is_NUL (_UNPK_ s))
512 then -- Must cater for NULs in literal string
513 mkGenApp (Var unpackCString2Id)
515 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
517 else -- No NULs in the string
518 App (Var unpackCStringId) (LitArg (MachStr s))
523 If an Integer is small enough (Haskell implementations must support
524 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
525 otherwise, wrap with @litString2Integer@.
528 litToRep (NoRepInteger i integer_ty)
529 = returnTM (integer_ty, rhs)
531 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
532 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
533 | i == 2 = Var integerPlusTwoId
534 | i == (-1) = Var integerMinusOneId
536 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
538 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
540 | otherwise -- Big, so start from a string
541 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
544 litToRep (NoRepRational r rational_ty)
545 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
546 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
547 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
549 (ratio_data_con, integer_ty)
550 = case (splitAlgTyConApp_maybe rational_ty) of
551 Just (tycon, [i_ty], [con])
552 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
555 _ -> (panic "ratio_data_con", panic "integer_ty")
557 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
561 funnyParallelOp SeqOp = True
562 funnyParallelOp ParOp = True
563 funnyParallelOp ForkOp = True
564 funnyParallelOp _ = False
568 %************************************************************************
570 \subsection{The monad}
572 %************************************************************************
575 type TidyM a state = Module
576 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
580 type TopTidyM a = TidyM a Unique
581 type NestTidyM a = TidyM a (Unique, -- Global names
582 Unique, -- Local names
583 Bag CoreBinding) -- Floats
586 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
588 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
590 = case m mod env initialTopTidyUnique of
591 (result, _) -> result
593 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
594 initNestedTM m mod env global_us
595 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
596 (result, (global_us', _, floats)) -> ((result, floats), global_us')
598 returnTM v mod env usf = (v, usf)
599 thenTM m k mod env usf = case m mod env usf of
600 (r, usf') -> k r mod env usf'
602 mapTM f [] = returnTM []
603 mapTM f (x:xs) = f x `thenTM` \ r ->
604 mapTM f xs `thenTM` \ rs ->
610 -- Need to extend the environment when we munge a binder, so that occurrences
611 -- of the binder will print the correct way (i.e. as a global not a local)
612 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
613 mungeTopBinder id thing_inside mod env us
614 = -- Give it a new print-name unless it's an exported thing
615 -- setNameVisibility also does the local/global thing
617 (id', us') | isExported id = (id, us)
619 = (setIdVisibility (Just mod) us id,
621 new_env = addToUFM env id (ValBinder id')
623 thing_inside id' mod new_env us'
625 mungeTopBinders [] k = k []
626 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
627 mungeTopBinders bs $ \ bs' ->
630 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
631 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
633 gus' = incrUnique gus
634 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
635 lit_id = setIdVisibility (Just mod) gus lit_local
637 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
639 lookupId :: Id -> TidyM Id state
640 lookupId v mod env usf
641 = case lookupUFM env v of
643 Just (ValBinder v') -> (v', usf)
645 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
646 extendEnvTM v v' m mod env usf
647 = m mod (addOneToIdEnv env v (ValBinder v')) usf
651 Making new local binders
652 ~~~~~~~~~~~~~~~~~~~~~~~~
654 newId id thing_inside mod env (gus, local_uniq, floats)
656 -- Give the Id a fresh print-name, *and* rename its type
657 local_uniq' = incrUnique local_uniq
658 name' = setNameVisibility Nothing local_uniq (getName id)
659 ty' = nmbr_ty env local_uniq' (idType id)
660 id' = mkUserId name' ty'
661 -- NB: This throws away the IdInfo of the Id, which we
662 -- no longer need. That means we don't need to
663 -- run over it with env, nor renumber it
665 -- NB: the Id's unique remains unchanged; it's only
666 -- its print name that is affected by local_uniq
668 env' = addToUFM env id (ValBinder id')
670 thing_inside id' mod env' (gus, local_uniq', floats)
672 newIds [] thing_inside
674 newIds (bndr:bndrs) thing_inside
675 = newId bndr $ \ bndr' ->
676 newIds bndrs $ \ bndrs' ->
677 thing_inside (bndr' : bndrs')
680 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
682 local_uniq' = incrUnique local_uniq
683 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
684 env' = addToUFM env tyvar (TyBinder tyvar')
686 thing_inside tyvar' mod env' (gus, local_uniq', floats)
692 tidyTy ty mod env usf@(_, local_uniq, _)
693 = (nmbr_ty env local_uniq ty, usf)
694 -- We can use local_uniq as a base for renaming forall'd variables
695 -- in the type; we don't need to know how many are consumed.
697 -- This little impedance-matcher calls nmbrType with the right arguments
699 = nmbrType tv_env uniq ty
701 tv_env :: TyVar -> TyVar
702 tv_env tyvar = case lookupUFM env tyvar of
703 Just (TyBinder tyvar') -> tyvar'