module SimplStg ( stg2stg ) where
-IMPORT_Trace
+import Ubiq{-uitous-}
import StgSyn
-import StgFuns
+import StgUtils
import LambdaLift ( liftProgram )
+import Name ( isLocallyDefined )
import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
+import StgLint ( lintStgBindings )
+import StgSAT ( doStaticArgs )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
-import CmdLineOpts
-import Id ( unlocaliseId )
-import IdEnv
-import MainMonad
-import Maybes ( maybeToBool, Maybe(..) )
-import Outputable
-import Pretty
-import SplitUniq
-import StgLint ( lintStgBindings )
-import StgSAT ( doStaticArgs )
-import UniqSet
-import Unique
-import Util
+import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
+ opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+ StgToDo(..)
+ )
+import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
+ growIdEnvList, isNullIdEnv, IdEnv(..),
+ GenId{-instance Eq/Outputable -}
+ )
+import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
+import Maybes ( maybeToBool )
+import Name ( isExported )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
+import UniqSupply ( splitUniqSupply )
+import Util ( mapAccumL, panic, assertPanic )
+
+unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
\end{code}
\begin{code}
-stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
- -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
- -> FAST_STRING -- module name (profiling only)
- -> PprStyle -- printing style (for debugging only)
- -> SplitUniqSupply -- a name supply
- -> [PlainStgBinding] -- input...
+stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
+ -> FAST_STRING -- module name (profiling only)
+ -> PprStyle -- printing style (for debugging only)
+ -> UniqSupply -- a name supply
+ -> [StgBinding] -- input...
-> MainIO
- ([PlainStgBinding], -- output program...
- ([CostCentre], -- local cost-centres that need to be decl'd
- [CostCentre])) -- "extern" cost-centres
+ ([StgBinding], -- output program...
+ ([CostCentre], -- local cost-centres that need to be decl'd
+ [CostCentre])) -- "extern" cost-centres
-stg2stg stg_todos sw_chkr module_name ppr_style us binds
+stg2stg stg_todos module_name ppr_style us binds
= BSCC("Stg2Stg")
case (splitUniqSupply us) of { (us4now, us4later) ->
(if do_verbose_stg2stg then
writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
- writeMn stderr (ppShow 1000
+ writeMn stderr (ppShow 1000
(ppAbove (ppStr ("*** Core2Stg:"))
(ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
))
-- info. Also, setStgVarInfo decides about let-no-escape
-- things, which in turn do a better job if arities are
-- correct, which is done by satStgRhs.
- --
+ --
let
-- ToDo: provide proper flag control!
binds_to_mangle
}}
ESCC
where
- switch_is_on = switchIsOn sw_chkr
-
- do_let_no_escapes = switch_is_on StgDoLetNoEscapes
- do_verbose_stg2stg = switch_is_on D_verbose_stg2stg
+ do_let_no_escapes = opt_StgDoLetNoEscapes
+ do_verbose_stg2stg = opt_D_verbose_stg2stg
(do_unlocalising, unlocal_tag)
- = case (stringSwitchSet sw_chkr EnsureSplittableC) of
+ = case (opt_EnsureSplittableC) of
Nothing -> (False, panic "tag")
- Just tag -> (True, _PK_ tag)
+ Just tag -> (True, tag)
- grp_name = case (stringSwitchSet sw_chkr SccGroup) of
- Just xx -> _PK_ xx
+ grp_name = case (opt_SccGroup) of
+ Just xx -> xx
Nothing -> module_name -- default: module name
-------------
BSCC("ProfMassage")
let
(collected_CCs, binds3)
- = stgMassageForProfiling module_name grp_name us1 switch_is_on binds
+ = stgMassageForProfiling module_name grp_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
ESCC
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- writeMn stderr (ppShow 1000
+ writeMn stderr (ppShow 1000
(ppAbove (ppStr ("*** "++what++":"))
(ppAboves (map (ppr ppr_style) binds2))
))
Nothing -> id
Just new_id -> new_id
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding])
+unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
unlocaliseStgBinds mod uenv [] = (uenv, [])
------------------
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding)
+unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
unlocal_top_bind mod uenv bind@(StgNonRec binder _)
= let new_uenv = case unlocaliseId mod binder of
unlocal_top_bind mod uenv bind@(StgRec pairs)
= let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
- new_uenv = growIdEnvList uenv [ (b,new_b)
+ new_uenv = growIdEnvList uenv [ (b,new_b)
| (b, Just new_b) <- maybe_unlocaliseds]
in
(new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
Then blast the whole program (LHSs as well as RHSs) with it.
\begin{code}
-elimIndirections :: [PlainStgBinding] -> [PlainStgBinding]
+elimIndirections :: [StgBinding] -> [StgBinding]
elimIndirections binds_in
= if isNullIdEnv blast_env then
(blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
- try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding)
- try_bind env_so_far
- (StgNonRec exported_binder
- (StgRhsClosure _ _ _ _
+ try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
+ try_bind env_so_far
+ (StgNonRec exported_binder
+ (StgRhsClosure _ _ _ _
lambda_args
- (StgApp (StgVarAtom local_binder) fun_args _)
+ (StgApp (StgVarArg local_binder) fun_args _)
))
| isExported exported_binder && -- Only if this is exported
not (isExported local_binder) && -- Only if this one is defined in this
= (addOneToIdEnv env_so_far local_binder exported_binder,
Nothing)
- where
+ where
args_match [] [] = True
- args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas
+ args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
args_match _ _ = False
- try_bind env_so_far bind
+ try_bind env_so_far bind
= (env_so_far, Just bind)
in_dom env id = maybeToBool (lookupIdEnv env id)
@renameTopStgBind@ renames top level binders and all occurrences thereof.
\begin{code}
-renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
+renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
projects / ghc-hetmet.git / blobdiff