From: sof Date: Fri, 13 Jun 1997 04:12:00 +0000 (+0000) Subject: [project @ 1997-06-13 04:11:47 by sof] X-Git-Tag: Approximately_1000_patches_recorded~301 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=44f98be5b3bc7aaf2c5961667b16ee8eca3e67c1;p=ghc-hetmet.git [project @ 1997-06-13 04:11:47 by sof] Simplified auto annotation of scc on toplevs --- diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 209a8f9..8a4c46c 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -28,7 +28,8 @@ import DsBinds ( dsBinds ) import DsUtils import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting, opt_SccGroup ) +import BasicTypes ( SYN_IE(Module) ) +import CmdLineOpts ( opt_DoCoreLinting, opt_SccGroup, opt_SccProfilingOn ) import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) @@ -43,7 +44,7 @@ start. \begin{code} deSugar :: UniqSupply -- name supply - -> FAST_STRING -- module name + -> Module -- module name -> (TypecheckedHsBinds, -- input: recsel, class, instance, and value TypecheckedHsBinds, -- bindings; see "tcModule" (which produces @@ -63,30 +64,30 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst (us3, us3a) = splitUniqSupply us2a (us4, us5) = splitUniqSupply us3a + module_and_group = (mod_name, grp_name) - module_and_group = (mod_name, grp_name) grp_name = case opt_SccGroup of Just xx -> _PK_ xx Nothing -> mod_name -- default: module name (core_const_binds, shadows1) - = initDs us0 nullIdEnv mod_name (dsBinds Nothing const_inst_binds) + = initDs us0 nullIdEnv module_and_group (dsBinds False const_inst_binds) core_const_prs = pairsFromCoreBinds core_const_binds (core_clas_binds, shadows2) - = initDs us1 nullIdEnv mod_name (dsBinds Nothing clas_binds) + = initDs us1 nullIdEnv module_and_group (dsBinds False clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 nullIdEnv mod_name (dsBinds Nothing inst_binds) + = initDs us2 nullIdEnv module_and_group (dsBinds False inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 nullIdEnv mod_name (dsBinds (Just module_and_group) val_binds) + = initDs us3 nullIdEnv module_and_group (dsBinds opt_SccProfilingOn val_binds) core_val_pairs = pairsFromCoreBinds core_val_binds (core_recsel_binds, shadows5) - = initDs us4 nullIdEnv mod_name (dsBinds Nothing recsel_binds) + = initDs us4 nullIdEnv module_and_group (dsBinds False recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds diff --git a/ghc/compiler/deSugar/DsBinds.hi-boot b/ghc/compiler/deSugar/DsBinds.hi-boot index 9de9237..d1313e8 100644 --- a/ghc/compiler/deSugar/DsBinds.hi-boot +++ b/ghc/compiler/deSugar/DsBinds.hi-boot @@ -2,4 +2,4 @@ _interface_ DsBinds 1 _exports_ DsBinds dsBinds; _declarations_ -1 dsBinds _:_ PrelBase.Maybe (BasicTypes.Module, FastString.FastString) -> TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;; +1 dsBinds _:_ PrelBase.Bool -> TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;; diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index abffcb1..adc4e55 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -58,16 +58,17 @@ that some of the binders are of unboxed type. This is sorted out when the caller wraps the bindings round an expression. \begin{code} -type Group = FAST_STRING -dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: Bool -- if candidate, auto add scc's on toplevs ? + -> TypecheckedHsBinds + -> DsM [CoreBinding] dsBinds _ EmptyBinds = returnDs [] -dsBinds mb_mod_grp (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds mb_mod_grp binds_1) (dsBinds mb_mod_grp binds_2) +dsBinds auto_scc (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) -dsBinds mb_mod_grp (MonoBind binds sigs is_rec) - = dsMonoBinds mb_mod_grp is_rec binds `thenDs` \ prs -> +dsBinds auto_scc (MonoBind binds sigs is_rec) + = dsMonoBinds auto_scc is_rec binds `thenDs` \ prs -> returnDs (if is_rec then [Rec prs] else @@ -83,15 +84,15 @@ dsBinds mb_mod_grp (MonoBind binds sigs is_rec) %************************************************************************ \begin{code} -dsMonoBinds :: Maybe (Module, Group) -- Nothing => don't (auto-)annotate scc on toplevs. +dsMonoBinds :: Bool -- False => don't (auto-)annotate scc on toplevs. -> RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)] dsMonoBinds _ is_rec EmptyMonoBinds = returnDs [] -dsMonoBinds mb_mod_grp is_rec (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds mb_mod_grp is_rec binds_1) (dsMonoBinds mb_mod_grp is_rec binds_2) +dsMonoBinds auto_scc is_rec (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds auto_scc is_rec binds_1) (dsMonoBinds auto_scc is_rec binds_2) dsMonoBinds _ is_rec (CoreMonoBind var core_expr) = returnDs [(var, core_expr)] @@ -105,37 +106,40 @@ dsMonoBinds _ is_rec (VarMonoBind var expr) returnDs [(var, core_expr')] -dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn) +dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)] + addAutoScc auto_scc (fun, mkValLam args body) `thenDs` \ pair -> + returnDs [pair] where error_string = "function " ++ showForErr fun -dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> mkSelectorBinds pat body_expr -- Common special case: no type or dictionary abstraction -dsMonoBinds mb_mod_grp is_rec (AbsBinds [] [] exports binds) - = dsMonoBinds Nothing is_rec binds `thenDs` \ prs -> - returnDs (prs ++ [ addAutoScc mb_mod_grp (global, Var local) | (_, global, local) <- exports]) +dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds) + = dsMonoBinds False is_rec binds `thenDs` \ prs -> + mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' -> + returnDs (prs ++ exports') -- Another common case: one exported variable -- All non-recursive bindings come through this way -dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) +dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) = ASSERT( all (`elem` tyvars) all_tyvars ) - dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs -> + dsMonoBinds False is_rec binds `thenDs` \ core_prs -> let core_binds | is_rec = [Rec core_prs] | otherwise = [NonRec b e | (b,e) <- core_prs] in - returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $ - mkCoLetsAny core_binds (Var local))] + addAutoScc auto_scc (global, mkLam tyvars dicts $ + mkCoLetsAny core_binds (Var local)) `thenDs` \ global' -> + returnDs [global'] -dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds) - = dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs -> +dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) + = dsMonoBinds False is_rec binds `thenDs` \ core_prs -> let core_binds | is_rec = [Rec core_prs] | otherwise = [NonRec b e | (b,e) <- core_prs] @@ -154,10 +158,10 @@ dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds) = -- Need to make fresh locals to bind in the selector, because -- some of the tyvars will be bound to voidTy newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' -> - returnDs (addAutoScc mb_mod_grp $ - (global, mkLam tyvars dicts $ - mkTupleSelector locals' (locals' !! n) $ - mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)) + addAutoScc auto_scc + (global, mkLam tyvars dicts $ + mkTupleSelector locals' (locals' !! n) $ + mkValApp (mkTyApp (Var tup_id) ty_args) dict_args) where mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = voidTy @@ -177,18 +181,17 @@ dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds) %************************************************************************ \begin{code} -addAutoScc :: Maybe (Module, Group) -- Module and group +addAutoScc :: Bool -- if needs be, decorate toplevs? -> (Id, CoreExpr) - -> (Id, CoreExpr) - -addAutoScc mb_mod_grp pair@(bndr, core_expr) - = case mb_mod_grp of - Just (mod,grp) - | worthSCC core_expr && - (opt_AutoSccsOnAllToplevs || - (isExported bndr && opt_AutoSccsOnExportedToplevs)) - -> (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr) - _ -> pair -- no auto-annotation. + -> DsM (Id, CoreExpr) + +addAutoScc auto_scc_candidate pair@(bndr, core_expr) + | auto_scc_candidate && worthSCC core_expr && + (opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs)) + = getModuleAndGroupDs `thenDs` \ (mod,grp) -> + returnDs (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr) + | otherwise + = returnDs pair worthSCC (SCC _ _) = False worthSCC (Con _ _) = False diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 49329ab..1478d68 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -266,7 +266,7 @@ dsExpr expr@(HsCase discrim matches src_loc) returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) dsExpr (HsLet binds expr) - = dsBinds Nothing binds `thenDs` \ core_binds -> + = dsBinds False binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) @@ -654,7 +654,7 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty VarArg (mkValLam [ignored_result_id] rest)] go (LetStmt binds : stmts ) - = dsBinds Nothing binds `thenDs` \ binds2 -> + = dsBinds False binds `thenDs` \ binds2 -> go stmts `thenDs` \ rest -> returnDs (mkCoLetsAny binds2 rest) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index bf670d5..63c41d7 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -59,7 +59,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds -> DsM CoreExpr dsGuarded (GRHSsAndBindsOut grhss binds err_ty) - = dsBinds Nothing binds `thenDs` \ core_binds -> + = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) @@ -138,8 +138,8 @@ matchGuard (GuardStmt expr _ : stmts) body_result returnDs (MatchResult CanFail ty expr_fn cxt) matchGuard (LetStmt binds : stmts) body_result - = matchGuard stmts body_result `thenDs` \ match_result -> - dsBinds Nothing binds `thenDs` \ core_binds -> + = matchGuard stmts body_result `thenDs` \ match_result -> + dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds -> returnDs (mkCoLetsMatchResult core_binds match_result) matchGuard (BindStmt pat rhs _ : stmts) body_result diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 5f55784..7147a4a 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -132,8 +132,8 @@ deListComp (GuardStmt guard locn : quals) list -- rule B above -- [e | let B, qs] = let B in [e | qs] deListComp (LetStmt binds : quals) list - = dsBinds Nothing binds `thenDs` \ core_binds -> - deListComp quals list `thenDs` \ core_rest -> + = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds -> + deListComp quals list `thenDs` \ core_rest -> returnDs (mkCoLetsAny core_binds core_rest) deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above @@ -200,8 +200,8 @@ dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals) dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals) -- new in 1.3, local bindings - = dsBinds Nothing binds `thenDs` \ core_binds -> - dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> returnDs (mkCoLetsAny core_binds core_rest) dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi index 9f87596..d38d04e 100644 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ b/ghc/compiler/deSugar/DsLoop.lhi @@ -27,6 +27,6 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it does -> DsM CoreExpr -dsBinds :: Maybe (FastString, FastString) -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] dsExpr :: TypecheckedHsExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index ce408a4..3428be6 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -29,7 +29,8 @@ module DsMonad ( IMP_Ubiq() import Bag ( emptyBag, snocBag, bagToList, Bag ) -import CmdLineOpts ( opt_SccGroup, opt_PprUserLength ) +import BasicTypes ( SYN_IE(Module) ) +import CmdLineOpts ( opt_PprUserLength ) import CoreSyn ( SYN_IE(CoreExpr) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) @@ -59,8 +60,8 @@ presumably include source-file location information: \begin{code} type DsM result = UniqSupply - -> SrcLoc -- to put in pattern-matching error msgs - -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling + -> SrcLoc -- to put in pattern-matching error msgs + -> (Module, Group) -- module + group name : for SCC profiling -> DsIdEnv -> DsWarnings -> (result, DsWarnings) @@ -68,6 +69,9 @@ type DsM result = type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) -- The desugarer reports matches which are -- completely shadowed or incomplete patterns + +type Group = FAST_STRING + {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -76,17 +80,12 @@ type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) initDs :: UniqSupply -> DsIdEnv - -> FAST_STRING -- module name: for profiling; (group name: from switches) + -> (Module, Group) -- module name: for profiling; (group name: from switches) -> DsM a -> (a, DsWarnings) -initDs init_us env mod_name action +initDs init_us env module_and_group action = action init_us noSrcLoc module_and_group env emptyBag - where - module_and_group = (mod_name, grp_name) - grp_name = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index d0ce737..a0cdb44 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -613,14 +613,14 @@ matchWrapper kind [(PatMatch (VarPat var) match)] error_string returnDs (var:vars, core_expr) matchWrapper kind [(PatMatch (WildPat ty) match)] error_string - = newSysLocalDs ty `thenDs` \ var -> + = newSysLocalDs ty `thenDs` \ var -> matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> returnDs (var:vars, core_expr) matchWrapper kind [(GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds Nothing binds `thenDs` \ core_binds -> - dsExpr expr `thenDs` \ core_expr -> + = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> + dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) ---------------------------------------------------------------------------- @@ -718,7 +718,7 @@ flattenMatches kind (match : matches) = flatten_match (pat:pats_so_far) match flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds Nothing binds `thenDs` \ core_binds -> + = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> dsGRHSs ty kind pats grhss `thenDs` \ match_result -> returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where