\section[Desugar]{@deSugar@: the main function}
\begin{code}
-module Desugar ( deSugar ) where
+module Desugar ( deSugar, deSugarExpr ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn ( TypecheckedRuleDecl )
+import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr )
import TcModule ( TcResults(..) )
import Id ( Id )
import CoreSyn
-import PprCore ( pprIdCoreRule )
+import PprCore ( pprIdCoreRule, pprCoreExpr )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
-- depends on DsExpr.hi-boot.
import Module ( Module )
import Id ( Id )
+import Name ( lookupNameEnv )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
-import HscTypes ( HomeSymbolTable )
+import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, )
\end{code}
%************************************************************************
\begin{code}
deSugar :: DynFlags
+ -> PersistentCompilerState -> HomeSymbolTable
-> Module -> PrintUnqualified
- -> HomeSymbolTable
-> TcResults
-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
-deSugar dflags mod_name unqual hst
- (TcResults {tc_env = global_val_env,
- tc_pcs = pcs,
+deSugar dflags pcs hst mod_name unqual
+ (TcResults {tc_env = local_type_env,
tc_binds = all_binds,
tc_rules = rules,
tc_fords = fo_decls})
; us <- mkSplitUniqSupply 'd'
-- Do desugaring
- ; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name
+ ; let (result, ds_warns) = initDs dflags us lookup mod_name
(dsProgram mod_name all_binds rules fo_decls)
(ds_binds, ds_rules, _, _, _) = result
; return result
}
--- deSugarExpr dflags unqual hst tc_expr
--- = do {
+ where
+ -- The lookup function passed to initDs is used for well-known Ids,
+ -- such as fold, build, cons etc, so the chances are
+ -- it'll be found in the package symbol table. That's
+ -- why we don't merge all these tables
+ pte = pcs_PTE pcs
+ lookup n = case lookupType hst pte n of {
+ Just (AnId v) -> v ;
+ other ->
+ case lookupNameEnv local_type_env n of
+ Just (AnId v) -> v ;
+ other -> pprPanic "Desugar: lookup:" (ppr n)
+ }
+
+deSugarExpr :: DynFlags
+ -> PersistentCompilerState -> HomeSymbolTable
+ -> Module -> PrintUnqualified
+ -> TypecheckedHsExpr
+ -> IO CoreExpr
+deSugarExpr dflags pcs hst mod_name unqual tc_expr
+ = do { showPass dflags "Desugar"
+ ; us <- mkSplitUniqSupply 'd'
+
+ -- Do desugaring
+ ; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr)
+
+ -- Display any warnings
+ ; doIfSet (not (isEmptyBag ds_warns))
+ (printErrs unqual (pprBagOfWarnings ds_warns))
+
+ -- Dump output
+ ; let do_dump_ds = dopt Opt_D_dump_ds dflags
+ ; doIfSet do_dump_ds (printDump (pprCoreExpr core_expr))
+
+ ; return core_expr
+ }
+ where
+ pte = pcs_PTE pcs
+ lookup n = case lookupType hst pte n of
+ Just (AnId v) -> v
+ other -> pprPanic "Desugar: lookup:" (ppr n)
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
import Unique ( Unique )
import Util ( zipWithEqual )
import Name ( Name )
-import Name ( lookupNameEnv )
-import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
- TyThing(..), TypeEnv, lookupType )
import CmdLineOpts ( DynFlags )
infixr 9 `thenDs`
initDs :: DynFlags
-> UniqSupply
- -> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
+ -> (Name -> Id)
-> Module -- module name: for profiling
-> DsM a
-> (a, DsWarnings)
-initDs dflags init_us (hst,pcs,local_type_env) mod action
+initDs dflags init_us lookup mod action
= action dflags init_us lookup noSrcLoc mod emptyBag
- where
- -- This lookup is used for well-known Ids,
- -- such as fold, build, cons etc, so the chances are
- -- it'll be found in the package symbol table. That's
- -- why we don't merge all these tables
- pte = pcs_PTE pcs
- lookup n = case lookupType hst pte n of {
- Just (AnId v) -> v ;
- other ->
- case lookupNameEnv local_type_env n of
- Just (AnId v) -> v ;
- other -> pprPanic "initDS: lookup:" (ppr n)
- }
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
let old_iface = case maybe_checked_iface of
Just old_if -> old_if
Nothing -> panic "hscNoRecomp:old_iface"
- this_mod = mi_module old_iface
;
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
else do {
-- TYPECHECK
- maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst
+ maybe_tc_result <- typecheckModule dflags pcs_cl hst
old_iface alwaysQualify cl_hs_decls;
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
- Just tc_result -> do {
+ Just (pcs_tc, tc_result) -> do {
- let pcs_tc = tc_pcs tc_result
- env_tc = tc_env tc_result
+ let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
<- renameModule dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
Nothing -> return (HscFail pcs_rn);
- Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do {
+ Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
-------------------
-- TYPECHECK
-------------------
- ; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface
+ ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface
print_unqualified rn_hs_decls
; case maybe_tc_result of {
Nothing -> do { hPutStrLn stderr "Typecheck failed"
; return (HscFail pcs_rn) } ;
- Just tc_result -> do {
+ Just (pcs_tc, tc_result) -> do {
- ; let pcs_tc = tc_pcs tc_result
- env_tc = tc_env tc_result
+ ; let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
-------------------
-- We grab the the unfoldings at this point.
- ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod
- print_unqualified is_exported tc_result hst
+ ; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod
+ print_unqualified is_exported tc_result
; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-------------------
(ppr nm)
-dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result hst
+dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
= do -------------------------- Desugaring ----------------
-- _scc_ "DeSugar"
(desugared, rules, h_code, c_code, fe_binders)
- <- deSugar dflags this_mod print_unqual hst tc_result
+ <- deSugar dflags pcs hst this_mod print_unqual tc_result
-------------------------- Main Core-language transformations ----------------
-- _scc_ "Core2Core"
(simplified, orphan_rules)
- <- core2core dflags rule_base hst is_exported desugared rules
+ <- core2core dflags pcs hst is_exported desugared rules
-- Do the final tidy-up
(tidy_binds, tidy_orphan_rules)
hscExpr dflags hst hit pcs this_module expr
= do { -- Parse it
+ let unqual = unQualInScope
; maybe_parsed <- myParseExpr dflags expr
; case maybe_parsed of {
Nothing -> return (HscFail pcs_ch);
(new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
; case maybe_renamed_expr of {
Nothing -> FAIL
- Just renamed_expr ->
+ Just (print_unqual, rn_expr) ->
-- Typecheck it
- maybe_tc_expr <- typecheckExpr dflags pcs hst unqual renamed_expr
+ maybe_tc_expr <- typecheckExpr dflags pcs hst print_unqual rn_expr
; case maybe_tc_expr of
Nothing -> FAIL
- Just typechecked_expr ->
+ Just tc_expr ->
+
+ -- Desugar it
+ ; ds_expr <- deSugarExpr dflags pcs hst this_module print_unqual tc_expr
+
+ -- Simplify it
+ ; simpl_expr <- simplifyExpr dflags pcs hst ds_expr
+
+ ; return I'M NOT SURE
+ }
-- a) the orphan rules
-- b) rules embedded in the top-level Ids
rule_dcls | opt_OmitInterfacePragmas = []
- | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
+ | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| (_, rule) <- orphan_rules]
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
-- Nothing => some error occurred in the renamer
renameModule dflags hit hst pcs this_module rdr_module
- = renameSource dflags hit hst pcs this_module get_unqual $
+ = renameSource dflags hit hst pcs this_module $
rename this_module rdr_module
- where
- get_unqual (Just (unqual, _, _, _)) = unqual
- get_unqual Nothing = alwaysQualify
\end{code}
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
- -> IO (PersistentCompilerState, Maybe RenamedHsExpr)
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr))
renameExpr dflags hit hst pcs this_module expr
| Just iface <- lookupModuleEnv hit this_module
= do { let rdr_env = mi_globals iface
- ; let get_unqual _ = unQualInScope rdr_env
+ ; let print_unqual = unQualInScope rdr_env
- ; renameSource dflags hit hst pcs this_module get_unqual $
+ ; renameSource dflags hit hst pcs this_module $
initRnMS rdr_env emptyLocalFixityEnv SourceMode $
- (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just e))
+ (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just (print_unqual, e)))
}
| otherwise
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module
- -> (Maybe r -> PrintUnqualified)
- -> RnMG (Maybe r)
- -> IO (PersistentCompilerState, Maybe r)
+ -> RnMG (Maybe (PrintUnqualified, r))
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r))
-- Nothing => some error occurred in the renamer
-renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
+renameSource dflags hit hst old_pcs this_module thing_inside
= do { showPass dflags "Renamer"
-- Initialise the renamer monad
; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside
-- Print errors from renaming
- ; printErrorsAndWarnings (get_unqual maybe_rn_stuff) msgs ;
+ ; let print_unqual = case maybe_rn_stuff of
+ Just (unqual, _) -> unqual
+ Nothing -> alwaysQualify
+
+ ; printErrorsAndWarnings print_unqual msgs ;
-- Return results. No harm in updating the PCS
; if errorsFound msgs then
\end{code}
\begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
+rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
= pushSrcLocRn loc $
imports global_avail_env
source_fvs export_avails rn_imp_decls `thenRn_`
- returnRn (Just (print_unqualified, is_exported, mod_iface, final_decls))
+ returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls)))
where
mod_name = moduleName this_module
\end{code}
\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
import CoreLint ( showPass, endPass )
import CoreSyn
import CoreFVs ( ruleRhsFreeVars )
-import HscTypes ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) )
+import HscTypes ( PersistentCompilerState(..),
+ PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
+ )
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
extendRuleBaseList, addRuleBaseFVs )
import Module ( moduleEnvElts )
import CoreUnfold
-import PprCore ( pprCoreBindings, pprIdCoreRule )
+import PprCore ( pprCoreBindings, pprIdCoreRule, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( etaReduceExpr, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
\begin{code}
core2core :: DynFlags -- includes spec of what core-to-core passes to do
- -> PackageRuleBase -- Rule-base accumulated from imported packages
+ -> PersistentCompilerState
-> HomeSymbolTable
-> IsExported
-> [CoreBind] -- Binds in
-> [IdCoreRule] -- Rules in
-> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
-core2core dflags pkg_rule_base hst is_exported binds rules
+core2core dflags pcs hst is_exported binds rules
= do
- let core_todos = dopt_CoreToDo dflags
+ let core_todos = dopt_CoreToDo dflags
+ let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages
+
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
return (processed_binds, orphan_rules)
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> CoreExpr
+ -> IO CoreExpr
+simplifyExpr dflags pcs hst expr
+ = do {
+ ; us <- mkSplitUniqSupply 's'
+
+ ; let (expr', counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all
+ (simplExpr expr)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplfied expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
+ where
+ sw_chkr any = SwBool False -- A bit bogus
+ black_list_all v = True -- Black list everything
+
+
doCorePasses :: DynFlags
-> RuleBase -- the main rule base
-> SimplCount -- simplifier stats
-- Convenient type synonyms first:
data TcResults
= TcResults {
- tc_pcs :: PersistentCompilerState, -- Augmented with imported information,
- -- (but not stuff from this module)
-
-- All these fields have info *just for this module*
tc_env :: TypeEnv, -- The top level TypeEnv
tc_insts :: [DFunId], -- Instances
---------------
typecheckModule
:: DynFlags
- -> Module
-> PersistentCompilerState
-> HomeSymbolTable
-> ModIface -- Iface for this module
-> PrintUnqualified -- For error printing
-> [RenamedHsDecl]
- -> IO (Maybe TcResults)
+ -> IO (Maybe (PersistentCompilerState, TcResults))
+ -- The new PCS is Augmented with imported information,
+ -- (but not stuff from this module)
+
-typecheckModule dflags this_mod pcs hst mod_iface unqual decls
+typecheckModule dflags pcs hst mod_iface unqual decls
= do { maybe_tc_result <- typecheck dflags pcs hst unqual $
- tcModule pcs hst get_fixity this_mod decls
+ tcModule pcs hst get_fixity this_mod decls
; printTcDump dflags maybe_tc_result
; return maybe_tc_result }
where
+ this_mod = mi_module mod_iface
fixity_env = mi_fixities mod_iface
get_fixity :: Name -> Maybe Fixity
-> TcM r
-> IO (Maybe r)
-typecheck dflags pcs hst unqual thing_inside
- = do { showPass dflags "Typechecker";
+typecheck dflags pcs hst unqual thing_inside
+ = do { showPass dflags "Typechecker";
; env <- initTcEnv hst (pcs_PTE pcs)
; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
-> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
- -> TcM TcResults
+ -> TcM (PersistentCompilerState, TcResults)
tcModule pcs hst get_fixity this_mod decls
= -- Type-check the type and class decls
}
in
-- traceTc (text "Tc10") `thenNF_Tc_`
- returnTc (TcResults { tc_pcs = final_pcs,
- tc_env = local_type_env,
+ returnTc (final_pcs,
+ TcResults { tc_env = local_type_env,
tc_binds = all_binds',
tc_insts = map iDFunId local_inst_info,
tc_fords = foi_decls ++ foe_decls',
\begin{code}
printTcDump dflags Nothing = return ()
-printTcDump dflags (Just results)
+printTcDump dflags (Just (_, results))
= do dumpIfSet_dyn dflags Opt_D_dump_types
"Type signatures" (dump_sigs results)
dumpIfSet_dyn dflags Opt_D_dump_tc
projects / ghc-hetmet.git / commitdiff