\section[Desugar]{@deSugar@: the main function}
\begin{code}
-module Desugar ( deSugar, deSugarExpr ) where
+module Desugar ( deSugar, deSugarExpr,
+ deSugarCore ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
-import HscTypes ( ModDetails(..) )
+import HscTypes ( ModDetails(..), TypeEnv )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr )
+import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr,
+ TypecheckedCoreBind )
import TcModule ( TcResults(..) )
import Id ( Id )
import CoreSyn
tc_binds = all_binds,
tc_insts = insts,
tc_rules = rules,
- tc_cbinds = core_binds,
+-- tc_cbinds = core_binds,
tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
(ds_binds, ds_rules, foreign_stuff) = ds_result
+{-
addCoreBinds ls =
case core_binds of
[] -> ls
cs -> (Rec cs) : ls
-
+-}
mod_details = ModDetails { md_types = type_env,
md_insts = insts,
md_rules = ds_rules,
- md_binds = addCoreBinds ds_binds }
+ md_binds = ds_binds }
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
pprIdRules rules
\end{code}
+Simplest thing in the world, desugaring External Core:
+
+\begin{code}
+deSugarCore :: TypeEnv -> [TypecheckedCoreBind]
+ -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
+deSugarCore type_env cs = do
+ let
+ mod_details
+ = ModDetails { md_types = type_env
+ , md_insts = []
+ , md_rules = []
+ , md_binds = [Rec (map (\ (lhs,_,rhs) -> (lhs,rhs)) cs)]
+ }
+
+ no_foreign_stuff = (empty,empty,[],[])
+ return (mod_details, no_foreign_stuff)
+
+\end{code}
+
%************************************************************************
%* *
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.17 2002/03/29 21:39:37 sof Exp $
+-- $Id: DriverPhases.hs,v 1.18 2002/04/05 15:18:26 sof Exp $
--
-- GHC Driver
--
haskellish_src_file, haskellish_src_suffix,
hsbootish_file, hsbootish_suffix,
objish_file, objish_suffix,
- cish_file, cish_suffix
+ cish_file, cish_suffix,
+ isExtCore_file
) where
import DriverUtil
haskellish_src_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr"])
cish_suffix = (`elem` [ "c", "cpp", "C", "cc", "cxx", "s", "S" ])
hsbootish_suffix = (`elem` [ "hs-boot" ])
+extcoreish_suffix = (`elem` [ "hcr" ])
#if mingw32_TARGET_OS || cygwin32_TARGET_OS
objish_suffix = (`elem` [ "o", "O", "obj", "OBJ" ])
cish_file = cish_suffix . getFileSuffix
objish_file = objish_suffix . getFileSuffix
hsbootish_file = hsbootish_suffix . getFileSuffix
+
+isExtCore_file = extcoreish_suffix . getFileSuffix
import ByteCodeGen ( byteCodeGen )
import TidyPgm ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
-import Rename ( renameStmt, renameRdrName, slurpIface )
+import Rename ( renameStmt, renameRdrName, slurpIface )
import RdrName ( rdrNameOcc, setRdrNameOcc )
import RdrHsSyn ( RdrNameStmt )
import OccName ( dataName, tcClsName,
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
import Finder ( findModule )
-import Rename ( checkOldIface, renameModule, closeIfaceDecls )
+import Rename ( checkOldIface, renameModule, renameExtCore,
+ closeIfaceDecls, RnResult(..) )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelRules ( builtinRules )
import Module ( ModuleName, moduleName, mkHomeModule )
import CmdLineOpts
import DriverState ( v_HCHeader )
+import DriverPhases ( isExtCore_file )
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
mod location maybe_checked_iface hst hit pcs_ch
= do {
-- what target are we shooting for?
- ; let toInterp = dopt_HscLang dflags == HscInterpreted
+ ; let toInterp = dopt_HscLang dflags == HscInterpreted
; let toNothing = dopt_HscLang dflags == HscNothing
+ ; let toCore = isJust (ml_hs_file location) &&
+ isExtCore_file (fromJust (ml_hs_file location))
; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
hPutStrLn stderr ("Compiling " ++
showModMsg (not toInterp) mod location);
-
- -------------------
- -- PARSE
- -------------------
- ; maybe_parsed <- myParseModule dflags
- (unJust "hscRecomp:hspp" (ml_hspp_file location))
- ; case maybe_parsed of {
- Nothing -> return (HscFail pcs_ch);
- Just rdr_module -> do {
- ; let this_mod = mkHomeModule (hsModuleName rdr_module)
-
- -------------------
- -- RENAME
- -------------------
- ; (pcs_rn, print_unqual, maybe_rn_result)
- <- _scc_ "Rename"
- renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module
- ; case maybe_rn_result of {
- Nothing -> return (HscFail pcs_ch);
- Just (dont_discard, new_iface, rn_result) -> do {
-
- -------------------
- -- TYPECHECK
- -------------------
- ; maybe_tc_result
- <- _scc_ "TypeCheck"
- typecheckModule dflags pcs_rn hst print_unqual rn_result
- ; case maybe_tc_result of {
- Nothing -> return (HscFail pcs_ch);
- Just (pcs_tc, tc_result) -> do {
-
- -------------------
- -- DESUGAR
- -------------------
- ; (ds_details, foreign_stuff)
- <- _scc_ "DeSugar"
- deSugar dflags pcs_tc hst this_mod print_unqual tc_result
-
+
+ ; front_res <-
+ (if toCore then hscCoreFrontEnd else hscFrontEnd)
+ ghci_mode dflags location hst hit pcs_ch
+ ; case front_res of
+ Left flure -> return flure;
+ Right (this_mod, rdr_module,
+ Just (dont_discard, new_iface, rn_result),
+ pcs_tc, ds_details, foreign_stuff) -> do {
-------------------
-- FLATTENING
-------------------
final_iface
stub_h_exists stub_c_exists
maybe_bcos)
- }}}}}}}
+ }}
+
+hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; inp <- readFile (unJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
+ ; case parseCore inp 1 of
+ FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
+ OkP rdr_module -> do {
+ ; let this_mod = mkHomeModule (hsModuleName rdr_module)
+
+ -------------------
+ -- RENAME
+ -------------------
+ ; (pcs_rn, print_unqual, maybe_rn_result)
+ <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module
+ ; case maybe_rn_result of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just (dont_discard, new_iface, rn_result) -> do {
+
+ -------------------
+ -- TYPECHECK
+ -------------------
+ ; maybe_tc_result
+ <- _scc_ "TypeCheck"
+ typecheckCoreModule dflags pcs_rn hst new_iface (rr_decls rn_result)
+ ; case maybe_tc_result of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just (pcs_tc, ty_env, core_binds) -> do {
+
+ -------------------
+ -- DESUGAR
+ -------------------
+ ; (ds_details, foreign_stuff) <- deSugarCore ty_env core_binds
+ ; return (Right (this_mod, rdr_module, maybe_rn_result,
+ pcs_tc, ds_details, foreign_stuff))
+ }}}}}}
+
+
+hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; maybe_parsed <- myParseModule dflags
+ (unJust "hscRecomp:hspp" (ml_hspp_file location))
+ ; case maybe_parsed of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just rdr_module -> do {
+ ; let this_mod = mkHomeModule (hsModuleName rdr_module)
+
+ -------------------
+ -- RENAME
+ -------------------
+ ; (pcs_rn, print_unqual, maybe_rn_result)
+ <- _scc_ "Rename"
+ renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module
+ ; case maybe_rn_result of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just (dont_discard, new_iface, rn_result) -> do {
+
+ -------------------
+ -- TYPECHECK
+ -------------------
+ ; maybe_tc_result
+ <- _scc_ "TypeCheck"
+ typecheckModule dflags pcs_rn hst print_unqual rn_result
+ ; case maybe_tc_result of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just (pcs_tc, tc_result) -> do {
+
+ -------------------
+ -- DESUGAR
+ -------------------
+ ; (ds_details, foreign_stuff)
+ <- _scc_ "DeSugar"
+ deSugar dflags pcs_tc hst this_mod print_unqual tc_result
+ ; return (Right (this_mod, rdr_module, maybe_rn_result,
+ pcs_tc, ds_details, foreign_stuff))
+ }}}}}}}
+
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
showPass dflags "Parser"
_scc_ "Parser" do
- if dopt_HscLang dflags == HscCore
- then do
- inp <- readFile src_filename
- case parseCore inp 1 of
- OkP m -> return (Just m)
- FailP s -> hPutStrLn stderr s >> return Nothing
- else do
buf <- hGetStringBuffer src_filename
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
lexKeyword cont cs =
case span isKeywordChar cs of
("module",rest) -> cont TKmodule rest
- ("import",rest) -> cont TKimport rest
("data",rest) -> cont TKdata rest
("newtype",rest) -> cont TKnewtype rest
("forall",rest) -> cont TKforall rest
%token
'%module' { TKmodule }
- '%import' { TKimport }
'%data' { TKdata }
'%newtype' { TKnewtype }
'%forall' { TKforall }
%%
module :: { RdrNameHsModule }
- : '%module' modid imports tdefs vdefgs
- { HsModule $2 Nothing Nothing $3 ($4 ++ concat $5) Nothing noSrcLoc}
-
-imports :: { [ImportDecl RdrName] }
- : {- empty -} { [] }
- | imp ';' imports { $1 : $3 }
-
-imp :: { ImportDecl RdrName }
- : '%import' modid { ImportDecl $2 ImportByUser True{-qual-} Nothing Nothing noSrcLoc }
+ : '%module' modid tdefs vdefgs
+ { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}
tdefs :: { [RdrNameHsDecl] }
: {- empty -} {[]}
data Token =
TKmodule
- | TKimport
| TKdata
| TKnewtype
| TKforall
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
-module Rename (
- renameModule, RnResult(..), renameStmt, renameRdrName, mkGlobalContext,
- closeIfaceDecls, checkOldIface, slurpIface
- ) where
+module Rename
+ ( renameModule
+ , RnResult(..)
+ , renameStmt
+ , renameRdrName
+ , renameExtCore
+ , mkGlobalContext
+ , closeIfaceDecls
+ , checkOldIface
+ , slurpIface
+ ) where
#include "HsVersions.h"
import Name ( Name, nameModule, isExternalName )
import NameEnv
import NameSet
-import RdrName ( foldRdrEnv, isQual )
+import RdrName ( foldRdrEnv, isQual, emptyRdrEnv )
import PrelNames ( iNTERACTIVE, pRELUDE_Name )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass,
printErrorsAndWarnings, errorsFound )
vcat (map ppr decls)]))
\end{code}
+\begin{code}
+renameExtCore :: DynFlags
+ -> HomeIfaceTable -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> Module
+ -> RdrNameHsModule
+ -> IO (PersistentCompilerState, PrintUnqualified,
+ Maybe (IsExported, ModIface, RnResult))
+
+ -- Nothing => some error occurred in the renamer
+renameExtCore dflags hit hst pcs this_module
+ rdr_module@(HsModule _ _ exports imports local_decls mod_deprec loc)
+ -- Rename the (Core) module
+ = renameSource dflags hit hst pcs this_module $
+ pushSrcLocRn loc $
+ -- RENAME THE SOURCE
+ rnSourceDecls emptyRdrEnv emptyAvailEnv
+ emptyLocalFixityEnv
+ InterfaceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
+ closeDecls rn_local_decls source_fvs `thenRn` \ final_decls ->
+ -- print everything qualified.
+ let print_unqualified = const False in
+ -- Bail out if we fail
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ returnRn (print_unqualified, Nothing)
+ else
+ let
+ mod_iface = ModIface { mi_module = this_module,
+ mi_package = opt_InPackage,
+ mi_version = initialVersionInfo,
+ mi_usages = [],
+ mi_boot = False,
+ mi_orphan = panic "is_orphan",
+ mi_exports = [],
+ mi_globals = Nothing,
+ mi_fixities = mkNameEnv [],
+ mi_deprecs = NoDeprecs,
+ mi_decls = panic "mi_decls"
+ }
+
+ rn_result = RnResult { rr_mod = this_module,
+ rr_fixities = mkNameEnv [],
+ rr_decls = final_decls,
+ rr_main = Nothing }
+
+ is_exported _ = True
+ in
+ returnRn (print_unqualified, Just (is_exported, mod_iface, rn_result))
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Make up an interactive context}
-- RENAME THE SOURCE
rnSourceDecls gbl_env global_avail_env
- local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
+ local_fixity_env SourceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
-- GET ANY IMPLICIT FREE VARIALBES
getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs ->
%*********************************************************
\begin{code}
-rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
+rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> RnMode
-> [RdrNameHsDecl]
-> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
-rnSourceDecls gbl_env avails local_fixity_env decls
- = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
+rnSourceDecls gbl_env avails local_fixity_env mode decls
+ = initRnMS gbl_env avails emptyRdrEnv local_fixity_env mode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
-type TypecheckedCoreBind = (Id, CoreExpr)
+type TypecheckedCoreBind = (Id, Type, CoreExpr)
\end{code}
\begin{code}
\end{code}
\begin{code}
-zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)]
+zonkCoreBinds :: [TypecheckedCoreBind] -> NF_TcM [TypecheckedCoreBind]
zonkCoreBinds ls = mapNF_Tc zonkOne ls
where
zonkOne (i, t, e) =
zonkIdOcc i `thenNF_Tc` \ i' ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (i',e')
+ returnNF_Tc (i',t',e')
-- needed?
zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
\begin{code}
module TcModule (
typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
- typecheckExtraDecls,
+ typecheckExtraDecls, typecheckCoreModule,
TcResults(..)
) where
tc_insts :: [DFunId], -- Instances
tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
tc_binds :: TypecheckedMonoBinds, -- Bindings
- tc_cbinds :: [TypecheckedCoreBind], -- (external)Core value decls/bindings.
tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
}
traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
- tcCoreBinds core_binds `thenTc` \ core_binds' ->
-- Second pass over class and instance declarations,
-- plus rules and foreign exports, to generate bindings
tcSetEnv env2 $
in
traceTc (text "Tc7") `thenNF_Tc_`
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
- zonkCoreBinds core_binds' `thenNF_Tc` \ core_binds' ->
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
traceTc (text "Tc8") `thenNF_Tc_`
tc_insts = map iDFunId inst_info,
tc_binds = all_binds',
tc_fords = foi_decls ++ foe_decls',
- tc_cbinds = core_binds',
tc_rules = src_rules'
}
)
add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
\end{code}
+\begin{code}
+typecheckCoreModule
+ :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> ModIface -- Iface for this module (just module & fixities)
+ -> [RenamedHsDecl]
+ -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedCoreBind]))
+typecheckCoreModule dflags pcs hst mod_iface decls
+ = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
+ (tcCoreDecls this_mod decls `thenTc` \ (env,bs) ->
+ zonkCoreBinds bs `thenNF_Tc` \ bs' ->
+ returnTc (env, bs'))
+
+-- ; printIfaceDump dflags maybe_tc_stuff
+
+ -- Q: Is it OK not to extend PCS here?
+ -- (in the event that it needs to be, I'm returning the PCS passed in.)
+ ; case maybe_tc_stuff of
+ Nothing -> return Nothing
+ Just (e,bs) -> return (Just (pcs, e, bs)) }
+ where
+ this_mod = mi_module mod_iface
+ core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
+
+tcCoreDecls :: Module
+ -> [RenamedHsDecl] -- All interface-file decls
+ -> TcM (TypeEnv, [TypecheckedCoreBind])
+tcCoreDecls this_mod decls
+-- The decls are all TyClD declarations coming from External Core input.
+ = let
+ tycl_decls = [d | TyClD d <- decls]
+ core_decls = filter isCoreDecl tycl_decls
+ in
+ fixTc (\ ~(unf_env, _) ->
+ -- This fixTc follows the same general plan as tcImports,
+ -- which is better commented.
+ -- [ Q: do we need to tie a knot for External Core? ]
+ tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+ tcCoreBinds tycl_decls `thenTc` \ core_binds ->
+ tcGetEnv `thenTc` \ env ->
+ returnTc (env, core_binds)
+ ) `thenTc` \ ~(final_env,bs) ->
+ let
+ src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
+ in
+ returnTc (mkTypeEnv src_things, bs)
+
+\end{code}
+
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff