Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
61663f75
Commit
61663f75
authored
Oct 25, 2000
by
sewardj
Browse files
[project @ 2000-10-25 14:42:31 by sewardj]
Compile up to HscMain. Again :)
parent
243dedb8
Changes
7
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/coreSyn/CoreTidy.lhs
View file @
61663f75
...
...
@@ -76,7 +76,7 @@ tidyCorePgm dflags module_name binds_in orphans_in
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
doUsageSPInf dflags us binds_in
doUsageSPInf dflags us binds_in
else return binds_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
...
...
ghc/compiler/deSugar/Desugar.lhs
View file @
61663f75
...
...
@@ -24,6 +24,7 @@ import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module )
import Id ( Id )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
...
...
ghc/compiler/main/CodeOutput.lhs
View file @
61663f75
...
...
@@ -66,7 +66,7 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds
do let filenm = dopt_OutName dflags
stub_names <- outputForeignStubs dflags c_code h_code
case dopt_HscLang dflags of
HscInterprete
r
-> return stub_names
HscInterprete
d
-> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC ncg_uniqs
>> return stub_names
HscC -> outputC dflags filenm flat_abstractC
...
...
ghc/compiler/main/DriverPipeline.hs
View file @
61663f75
-----------------------------------------------------------------------------
-- $Id: DriverPipeline.hs,v 1.
5
2000/10/2
3 09:03:27 simonp
j Exp $
-- $Id: DriverPipeline.hs,v 1.
6
2000/10/2
5 14:42:32 seward
j Exp $
--
-- GHC Driver
--
...
...
@@ -731,11 +731,8 @@ data CompResult
-- summary and code; Nothing => compilation not reqd
-- (old summary and code are still valid)
PersistentCompilerState
-- updated PCS
(
Bag
WarnMsg
)
-- warnings
|
CompErrs
PersistentCompilerState
-- updated PCS
(
Bag
ErrMsg
)
-- errors
(
Bag
WarnMsg
)
-- warnings
compile
finder
summary
old_iface
hst
pcs
=
do
...
...
ghc/compiler/main/HscMain.lhs
View file @
61663f75
...
...
@@ -76,22 +76,65 @@ hscMain
-> IO HscResult
hscMain dflags core_cmds stg_cmds summary maybe_old_iface
output_filename mod_details pcs1
= do
source_unchanged :: Bool -- extracted from summary?
output_filename mod_details pcs
= do {
-- ????? source_unchanged :: Bool -- extracted from summary?
(ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface))
<- checkOldIface dflags finder hit hst pcs mod source_unchanged
maybe_old_iface;
if check_errs then
return (HscFail ch_pcs)
else do {
(pcs2, check_errs, (recomp_reqd,
maybe_checked_iface)
)
<- checkOldIface dflags finder hit hst pcs1 mod source_unchanged
maybe_old_iface
let no_old_iface = not (isJust
maybe_checked_iface)
what_next | recomp_reqd || no_old_iface = hscRecomp
| otherwise = hscNoRecomp
-- test check_errs and give up if a problem happened
what_next = if recomp_reqd then hscRecomp else hscNoRecomp
return (what_next dflags core_cmds stg_cmds summary hit hst
pcs2 maybe_checked_iface)
}}
return $
what_next dflags core_cmds stg_cmds summary hit hst
pcs2 maybe_checked_iface
hscNoRecomp = panic "hscNoRecomp"
hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
= do {
-- we definitely expect to have the old interface available
old_iface = case maybe_old_iface of
Just old_if -> old_if
Nothing -> panic "hscNoRecomp:old_iface"
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
<- closeIfaceDecls dflags finder hit hst pcs old_iface
if closure_errs then
return (HscFail cl_pcs)
else do {
-- TYPECHECK
maybe_tc_result
<- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls;
case maybe_tc_result of {
Nothing -> return (HscFail cl_pcs);
Just tc_result -> do {
let pcs_tc = tc_pcs tc_result
env_tc = tc_env tc_result
binds_tc = tc_binds tc_result
local_tycons = tc_tycons tc_result
local_classes = tc_classes tc_result
local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
-- create a new details from the closed, typechecked, old iface
let new_details = mkModDetailsFromIface env_tc local_insts local_rules
return (HscOK final_details
Nothing -- tells CM to use old iface and linkables
Nothing Nothing -- foreign export stuff
Nothing -- ibinds
pcs_tc)
}}}}
hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
= do {
...
...
@@ -119,22 +162,24 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
Just tc_result -> do {
let pcs_tc = tc_pcs tc_result
let env_tc = tc_env tc_result
let binds_tc = tc_binds tc_result
let local_tycons = tc_tycons tc_result
let local_classes = tc_classes tc_result
env_tc = tc_env tc_result
binds_tc = tc_binds tc_result
local_tycons = tc_tycons tc_result
local_classes = tc_classes tc_result
local_insts = tc_insts tc_result
-- DESUGAR, SIMPLIFY, TIDY-CORE
-- We grab the the unfoldings at this point.
(tidy_binds, orphan_rules, f
e_binders, h_code, c_code) -- return modDetails?
<- dsThenSimplThenTidy dflags mod tc_result
rule_base
ds_uniqs
(tidy_binds, orphan_rules, f
oreign_stuff)
<- dsThenSimplThenTidy dflags mod tc_result ds_uniqs
-- CONVERT TO STG
(stg_binds, cost_centre_info, top_level_ids)
<- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
-- cook up a new ModDetails now we (finally) have all the bits
let new_details = completeModDetails tc_env tidy_binds top_level_ids orphan_rules
let new_details = mkModDetails tc_env local_insts tidy_binds
top_level_ids orphan_rules
-- and possibly create a new ModIface
let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
...
...
@@ -143,7 +188,7 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
(maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename)
<- restOfCodeGeneration toInterp
this_mod imported_modules cost_centre_info
fe_binders
local_tycons local_classes
stg_binds
fe_binders
tc_env
stg_binds
-- and the answer is ...
return (HscOK new_details maybe_final_iface
...
...
@@ -184,10 +229,10 @@ myParseModule dflags summary
restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
f
e_binders local_tycons local_classes
stg_binds
f
oreign_stuff tc_env
stg_binds
| toInterp
= return (Nothing, Nothing,
stgToInterpSyn stg_binds local_tycons local_classes)
= return (Nothing, Nothing,
Just (stgToInterpSyn stg_binds local_tycons local_classes))
| otherwise
= do -------------------------- Code generation -------------------------------
show_pass "CodeGen"
...
...
@@ -199,19 +244,24 @@ restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
-------------------------- Code output -------------------------------
show_pass "CodeOutput"
-- _scc_ "CodeOutput"
let (fe_binders, h_code, c_code) = foreign_stuff
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput this_mod local_tycons local_classes
occ_anal_tidy_binds stg_binds2
c_code h_code abstractC ncg_uniqs
return (maybe_stub_h_name, maybe_stub_c_name, [{-UnlinkedIBind-}])
return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
where
local_tycons = tcEnvTyCons tc_env
local_classes = tcEnvClasses tc_env
dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
dsThenSimplThenTidy dflags mod tc_result
-- make up ds_uniqs here
= do -------------------------- Desugaring ----------------
-- _scc_ "DeSugar"
(desugared, rules, h_code, c_code, fe_binders)
<- deSugar this_mod ds_uniqs tc_result
s
<- deSugar this_mod ds_uniqs tc_result
-------------------------- Main Core-language transformations ----------------
-- _scc_ "Core2Core"
...
...
@@ -221,8 +271,7 @@ dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
(tidy_binds, tidy_orphan_rules)
<- tidyCorePgm this_mod simplified orphan_rules
return (tidy_binds, tidy_orphan_rules, fe_binders, h_code, c_code)
return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
...
...
ghc/compiler/rename/Rename.lhs
View file @
61663f75
...
...
@@ -4,7 +4,7 @@
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
module Rename ( renameModule ) where
module Rename ( renameModule
, closeIfaceDecls
) where
#include "HsVersions.h"
...
...
ghc/compiler/stgSyn/StgInterp.lhs
View file @
61663f75
...
...
@@ -9,7 +9,7 @@ module StgInterp (
ClosureEnv, ItblEnv,
linkIModules,
stgToInterpSyn,
runStgI -- tmp, for testing
--
runStgI -- tmp, for testing
) where
{- -----------------------------------------------------------------------------
...
...
@@ -64,7 +64,7 @@ import Module ( moduleNameFS )
#endif
import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
import Class ( Class )
import Class ( Class
, classTyCon
)
import InterpSyn
import StgSyn
import Addr
...
...
@@ -85,15 +85,10 @@ type ClosureEnv = FiniteMap RdrName HValue
-- Run our STG program through the interpreter
-- ---------------------------------------------------------------------------
#if 0
-- To be nuked at some point soon.
runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
#ifndef GHCI
runStgI = panic "StgInterp.runStgI: not implemented"
linkIModules = panic "StgInterp.linkIModules: not implemented"
#else
-- the bindings need to have a binding for stgMain, and the
-- body of it had better represent something of type Int# -> Int#
runStgI tycons classes stgbinds
...
...
@@ -128,6 +123,7 @@ runStgI tycons classes stgbinds
emptyUFM{-initial de-}
)
return result
#endif
-- ---------------------------------------------------------------------------
-- Convert STG to an unlinked interpretable
...
...
@@ -140,7 +136,7 @@ stgToInterpSyn :: [StgBinding]
stgToInterpSyn binds local_tycons local_classes
= do let ibinds = concatMap (translateBind emptyUniqSet) binds
let tycs = local_tycons ++ map classTyCon local_classes
itblenv <- m
akeIt
bls tycs
itblenv <- m
kIT
bls tycs
return (ibinds, itblenv)
...
...
@@ -421,7 +417,7 @@ linkIModules :: ClosureEnv -- incoming global closure env; returned updated
-> ItblEnv -- incoming global itbl env; returned updated
-> [([UnlinkedIBind], ItblEnv)]
-> IO ([LinkedIBind], ItblEnv, ClosureEnv)
linkIModules g
i
e g
c
e mods = do
linkIModules g
c
e g
i
e mods = do
let (bindss, ies) = unzip mods
binds = concat bindss
top_level_binders = map (toRdrName.binder) binds
...
...
@@ -431,9 +427,9 @@ linkIModules gie gce mods = do
new_gce = addListToFM gce (zip top_level_binders new_rhss)
new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
(
new_binds
, final_gce)
= linkIBinds final_gie new_gce binds
new_binds = linkIBinds final_gie new_gce binds
return (new_binds, final_gie,
final
_gce)
return (new_binds, final_gie,
new
_gce)
-- We're supposed to augment the environments with the values of any
...
...
@@ -1231,6 +1227,5 @@ load addr = do x <- peek addr
foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
#endif /* ndef GHCI */
\end{code}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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