Commit acc784b5 authored by sof's avatar sof
Browse files

[project @ 2002-04-05 15:18:25 by sof]

Cleaned up the way the External Core front-end was
integrated with the rest of the compiler;
guided by detailed and helpful feedback from Simon PJ.

Input files ending in ".hcr" are now assumed to contain
external core -- still working on getting the renamer
to slurp in interface files (implicitly) referred to
in the Core source.
parent a32726a1
......@@ -4,15 +4,17 @@
\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
......@@ -58,7 +60,7 @@ deSugar dflags pcs hst mod_name unqual
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'
......@@ -69,15 +71,16 @@ deSugar dflags pcs hst mod_name unqual
(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))
......@@ -159,6 +162,25 @@ ppr_ds_rules rules
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
--
......@@ -18,7 +18,8 @@ module DriverPhases (
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
......@@ -102,6 +103,7 @@ haskellish_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "ra
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" ])
......@@ -114,3 +116,5 @@ haskellish_src_file = haskellish_src_suffix . getFileSuffix
cish_file = cish_suffix . getFileSuffix
objish_file = objish_suffix . getFileSuffix
hsbootish_file = hsbootish_suffix . getFileSuffix
isExtCore_file = extcoreish_suffix . getFileSuffix
......@@ -18,7 +18,7 @@ import Interpreter
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,
......@@ -47,7 +47,8 @@ import Parser
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 )
......@@ -70,6 +71,7 @@ import CodeOutput ( codeOutput, outputForeignStubs )
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 )
......@@ -204,50 +206,23 @@ hscRecomp ghci_mode dflags have_object
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
-------------------
......@@ -421,19 +396,92 @@ hscRecomp ghci_mode dflags have_object
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,
......
......@@ -75,7 +75,6 @@ lexName cont cstr cs = cont (cstr name) rest
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
......
......@@ -25,7 +25,6 @@ import SrcLoc
%token
'%module' { TKmodule }
'%import' { TKimport }
'%data' { TKdata }
'%newtype' { TKnewtype }
'%forall' { TKforall }
......@@ -65,15 +64,8 @@ import SrcLoc
%%
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 -} {[]}
......
......@@ -17,7 +17,6 @@ failP s s' _ = FailP (s ++ ":" ++ s')
data Token =
TKmodule
| TKimport
| TKdata
| TKnewtype
| TKforall
......
......@@ -4,10 +4,17 @@
\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"
......@@ -49,7 +56,7 @@ import Module ( Module, ModuleName, WhereFrom(..),
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 )
......@@ -195,6 +202,58 @@ renameRdrName dflags hit hst pcs ic rdr_names =
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}
......@@ -363,7 +422,7 @@ rename ghci_mode this_module
-- 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 ->
......
......@@ -72,13 +72,13 @@ Checks the @(..)@ etc constraints in the export list.
%*********************************************************
\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)
......
......@@ -106,7 +106,7 @@ type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
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}
......@@ -792,13 +792,14 @@ zonkRule (IfaceRuleOut fun rule)
\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
......
......@@ -6,7 +6,7 @@
\begin{code}
module TcModule (
typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
typecheckExtraDecls,
typecheckExtraDecls, typecheckCoreModule,
TcResults(..)
) where
......@@ -353,7 +353,6 @@ data TcResults
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.
}
......@@ -405,7 +404,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
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 $
......@@ -461,7 +459,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
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_`
......@@ -480,7 +477,6 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
tc_insts = map iDFunId inst_info,
tc_binds = all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_cbinds = core_binds',
tc_rules = src_rules'
}
)
......@@ -679,6 +675,57 @@ addIfaceRules rule_base 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}
%************************************************************************
%* *
......
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