Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
9a32e538
Commit
9a32e538
authored
Mar 04, 2006
by
David Himmelstrup
Browse files
Comments and esthetical changes.
parent
e5ea30e6
Changes
2
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/main/DriverPipeline.hs
View file @
9a32e538
...
...
@@ -171,10 +171,10 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
=
do
stub_o
<-
compileStub
dflags'
this_mod
location
return
[
DotO
stub_o
]
handleMake
(
New
HscNoRecomp
,
iface
,
details
)
handleMake
(
HscNoRecomp
,
iface
,
details
)
=
ASSERT
(
isJust
maybe_old_linkable
)
return
(
CompOK
details
iface
maybe_old_linkable
)
handleMake
(
New
HscRecomp
hasStub
,
iface
,
details
)
handleMake
(
HscRecomp
hasStub
,
iface
,
details
)
|
isHsBoot
src_flavour
=
return
(
CompOK
details
iface
Nothing
)
|
otherwise
...
...
@@ -757,13 +757,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
case
mbResult
of
Nothing
->
throwDyn
(
PhaseFailed
"hsc"
(
ExitFailure
1
))
Just
New
HscNoRecomp
Just
HscNoRecomp
->
do
SysTools
.
touch
dflags'
"Touching object file"
o_file
-- The .o file must have a later modification date
-- than the source file (else we wouldn't be in HscNoRecomp)
-- but we touch it anyway, to keep 'make' happy (we think).
return
(
StopLn
,
dflags'
,
Just
location4
,
o_file
)
Just
(
New
HscRecomp
hasStub
)
Just
(
HscRecomp
hasStub
)
->
do
when
hasStub
$
do
stub_o
<-
compileStub
dflags'
mod_name
location4
consIORef
v_Ld_inputs
stub_o
...
...
ghc/compiler/main/HscMain.lhs
View file @
9a32e538
...
...
@@ -168,14 +168,16 @@ data HscChecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
-- Status of a compilation to hard-code or nothing.
data HscStatus
= NewHscNoRecomp
| NewHscRecomp Bool -- Has stub files.
-- This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we
-- just return True if we want the caller to compile
-- it for us.
= HscNoRecomp
| HscRecomp Bool -- Has stub files.
-- This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we
-- just return True if we want the caller to compile
-- it for us.
-- Status of a compilation to byte-code.
data InteractiveStatus
= InteractiveNoRecomp
| InteractiveRecomp Bool -- Same as HscStatus
...
...
@@ -195,6 +197,9 @@ type Compiler result = HscEnv
-> IO (Maybe result)
-- This functions checks if recompilation is necessary and
-- then combines the FrontEnd, BackEnd and CodeGen to a
-- working compiler.
hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required.
-> FrontEnd core
-> BackEnd core prepCore
...
...
@@ -222,11 +227,15 @@ hscMkCompiler norecomp frontend backend codegen
result <- codegen hsc_env mod_summary prepCore
return (Just result)
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
hscCompileOneShot hsc_env mod_summary =
compiler hsc_env mod_summary
where mkComp = hscMkCompiler (norecompOneShot
New
HscNoRecomp)
where mkComp = hscMkCompiler (norecompOneShot HscNoRecomp)
compiler
= case ms_hsc_src mod_summary of
ExtCoreFile
...
...
@@ -236,7 +245,7 @@ hscCompileOneShot hsc_env mod_summary =
-> mkComp hscFileFrontEnd hscNewBackEnd hscCodeGenOneShot
HsBootFile
-> mkComp hscFileFrontEnd hscNewBootBackEnd
(hscCodeGenConst (
New
HscRecomp False))
(hscCodeGenConst (HscRecomp False))
-- Compile Haskell, boot and extCore in --make mode.
hscCompileMake :: Compiler (HscStatus, ModIface, ModDetails)
...
...
@@ -244,7 +253,7 @@ hscCompileMake hsc_env mod_summary
= compiler hsc_env mod_summary
where mkComp = hscMkCompiler norecompMake
backend = case hscTarget (hsc_dflags hsc_env) of
HscNothing -> hscCodeGenSimple (\(i, d, g) -> (
New
HscRecomp False, i, d))
HscNothing -> hscCodeGenSimple (\(i, d, g) -> (HscRecomp False, i, d))
_other -> hscCodeGenMake
compiler
= case ms_hsc_src mod_summary of
...
...
@@ -268,6 +277,10 @@ hscCompileInteractive hsc_env mod_summary =
bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
"Use 'hscCompileMake' instead."
--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------
norecompOneShot :: a -> NoRecomp a
norecompOneShot a hsc_env mod_summary
have_object old_iface
...
...
@@ -278,7 +291,7 @@ norecompOneShot a hsc_env mod_summary
return a
norecompMake :: NoRecomp (HscStatus, ModIface, ModDetails)
norecompMake = norecompWorker
New
HscNoRecomp
norecompMake = norecompWorker HscNoRecomp
norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
norecompInteractive = norecompWorker InteractiveNoRecomp
...
...
@@ -295,6 +308,83 @@ norecompWorker a hsc_env mod_summary have_object
dumpIfaceStats hsc_env
return (a, old_iface, new_details)
--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------
hscCoreFrontEnd :: FrontEnd ModGuts
hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do {
-------------------
-- PARSE
-------------------
; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
; case parseCore inp 1 of
FailP s -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
return Nothing
OkP rdr_module -> do {
-------------------
-- RENAME and TYPECHECK
-------------------
; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
tcRnExtCore hsc_env rdr_module
; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
; case maybe_tc_result of
Nothing -> return Nothing
Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
}}
hscFileFrontEnd :: FrontEnd ModGuts
hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
-------------------
-- DISPLAY PROGRESS MESSAGE
-------------------
; let dflags = hsc_dflags hsc_env
one_shot = isOneShot (ghcMode dflags)
toInterp = hscTarget dflags == HscInterpreted
; when (not one_shot) $
compilationProgressMsg dflags $
(showModuleIndex mb_mod_index ++
"Compiling " ++ showModMsg (not toInterp) mod_summary)
-------------------
-- PARSE
-------------------
; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
hspp_buf = ms_hspp_buf mod_summary
; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
; case maybe_parsed of {
Left err -> do { printBagOfErrors dflags (unitBag err)
; return Nothing } ;
Right rdr_module -> do {
-------------------
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
<- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
Nothing -> return Nothing ;
Just tc_result -> do {
-------------------
-- DESUGAR
-------------------
; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
deSugar hsc_env tc_result
; printBagOfWarnings dflags warns
; return maybe_ds_result
}}}}}
--------------------------------------------------------------
-- BackEnds
--------------------------------------------------------------
hscNewBootBackEnd :: BackEnd ModGuts (HscStatus, ModIface, ModDetails)
hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result
= do details <- mkBootModDetails hsc_env ds_result
...
...
@@ -304,7 +394,7 @@ hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result
writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
-- And the answer is ...
dumpIfaceStats hsc_env
return (
New
HscRecomp False, new_iface, details)
return (HscRecomp False, new_iface, details)
hscNewBackEnd :: BackEnd ModGuts (ModIface, ModDetails, CgGuts)
hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result
...
...
@@ -379,22 +469,26 @@ hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result
; return (new_iface, details, cg_guts)
}
--------------------------------------------------------------
-- Code generators
--------------------------------------------------------------
-- Don't output any code.
hscCodeGenNothing :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
hscCodeGenNothing hsc_env mod_summary (iface, details, cgguts)
= return (
New
HscRecomp False, iface, details)
= return (HscRecomp False, iface, details)
-- Generate code and return both the new ModIface and the ModDetails.
hscCodeGenMake :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
hscCodeGenMake hsc_env mod_summary (iface, details, cgguts)
= do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
return (
New
HscRecomp hasStub, iface, details)
return (HscRecomp hasStub, iface, details)
-- Here we don't need the ModIface and ModDetails anymore.
hscCodeGenOneShot :: CodeGen (ModIface, ModDetails, CgGuts) HscStatus
hscCodeGenOneShot hsc_env mod_summary (_, _, cgguts)
= do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
return (
New
HscRecomp hasStub)
return (HscRecomp hasStub)
hscCodeGenCompile :: CodeGen CgGuts Bool
hscCodeGenCompile hsc_env mod_summary cgguts
...
...
@@ -478,74 +572,6 @@ hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts)
#endif
hscCoreFrontEnd :: FrontEnd ModGuts
hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do {
-------------------
-- PARSE
-------------------
; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
; case parseCore inp 1 of
FailP s -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
OkP rdr_module -> do {
-------------------
-- RENAME and TYPECHECK
-------------------
; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
tcRnExtCore hsc_env rdr_module
; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
; case maybe_tc_result of
Nothing -> return Nothing
Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
}}
hscFileFrontEnd :: FrontEnd ModGuts
hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
-------------------
-- DISPLAY PROGRESS MESSAGE
-------------------
; let dflags = hsc_dflags hsc_env
one_shot = isOneShot (ghcMode dflags)
toInterp = hscTarget dflags == HscInterpreted
; when (not one_shot) $
compilationProgressMsg dflags $
(showModuleIndex mb_mod_index ++
"Compiling " ++ showModMsg (not toInterp) mod_summary)
-------------------
-- PARSE
-------------------
; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
hspp_buf = ms_hspp_buf mod_summary
; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
; case maybe_parsed of {
Left err -> do { printBagOfErrors dflags (unitBag err)
; return Nothing } ;
Right rdr_module -> do {
-------------------
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
<- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
Nothing -> return Nothing ;
Just tc_result -> do {
-------------------
-- DESUGAR
-------------------
; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
deSugar hsc_env tc_result
; printBagOfWarnings dflags warns
; return maybe_ds_result
}}}}}
------------------------------
hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment