Commit 490cba33 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-11-16 14:43:05 by simonpj]

Add stuff to support hscExpr
parent 9e9d8b05
......@@ -4,18 +4,18 @@
\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 )
......@@ -25,6 +25,7 @@ import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module )
import Id ( Id )
import Name ( lookupNameEnv )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
......@@ -32,7 +33,7 @@ import CoreLint ( showPass, endPass )
import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import HscTypes ( HomeSymbolTable )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, )
\end{code}
%************************************************************************
......@@ -46,14 +47,13 @@ start.
\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})
......@@ -61,7 +61,7 @@ deSugar dflags mod_name unqual hst
; 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
......@@ -79,8 +79,47 @@ deSugar dflags mod_name unqual hst
; 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 ->
......
......@@ -39,9 +39,6 @@ import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
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`
......@@ -71,26 +68,13 @@ type DsWarnings = Bag WarnMsg -- The desugarer reports matches which a
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
......
......@@ -120,7 +120,6 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
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)
......@@ -130,14 +129,13 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
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
;
......@@ -175,28 +173,27 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
<- 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
-------------------
......@@ -316,16 +313,16 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
(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)
......@@ -375,6 +372,7 @@ hscExpr
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);
......@@ -384,13 +382,22 @@ hscExpr dflags hst hit pcs this_module expr
(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
}
......
......@@ -103,7 +103,7 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
-- 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]
......
......@@ -87,15 +87,12 @@ renameModule :: DynFlags
-> 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}
......@@ -104,16 +101,16 @@ renameExpr :: DynFlags
-> 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
......@@ -134,19 +131,22 @@ renameSource :: DynFlags
-> 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
......@@ -157,7 +157,7 @@ renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
\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 $
......@@ -249,7 +249,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
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}
......
......@@ -4,7 +4,7 @@
\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
module SimplCore ( core2core ) where
module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
......@@ -15,13 +15,15 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
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 )
......@@ -56,16 +58,18 @@ import List ( partition )
\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
......@@ -90,6 +94,28 @@ core2core dflags pkg_rule_base hst is_exported binds rules
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
......
......@@ -65,9 +65,6 @@ Outside-world interface:
-- 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
......@@ -79,20 +76,23 @@ data TcResults
---------------
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
......@@ -121,8 +121,8 @@ typecheck :: DynFlags
-> 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
......@@ -143,7 +143,7 @@ tcModule :: PersistentCompilerState
-> (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
......@@ -283,8 +283,8 @@ tcModule pcs hst get_fixity this_mod 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',
......@@ -305,7 +305,7 @@ get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment