import DriverState ( v_HCHeader )
import DriverPhases ( isExtCore_file )
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
-import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( consBag, emptyBag )
import Name ( Name, nameModule, nameOccName, getName )
import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module )
+import FastString
+import Maybes ( expectJust )
+import Util ( seqList )
import IOExts ( newIORef, readIORef, writeIORef,
unsafePerformIO )
; case front_res of
Left flure -> return flure;
Right (this_mod, rdr_module,
- Just (dont_discard, new_iface, rn_result),
+ dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff) -> do {
+
+ let {
+ imported_module_names =
+ filter (/= gHC_PRIM_Name) $
+ map ideclName (hsModuleImports rdr_module);
+
+ imported_modules =
+ map (moduleNameToModule hit (pcs_PIT pcs_tc))
+ imported_module_names;
+ }
+
+ -- force this out now, so we don't keep a hold of rdr_module or pcs_tc
+ ; seqList imported_modules `seq` return ()
+
-------------------
-- FLATTENING
-------------------
-- foreign_stuff
-- ds_details
-- new_iface
+ -- imported_modules
-------------------
-- SIMPLIFY
local_tycons = typeEnvTyCons env_tc
local_classes = typeEnvClasses env_tc
- imported_module_names =
- filter (/= gHC_PRIM_Name) $
- map ideclName (hsModuleImports rdr_module)
- -- eek! doesn't this keep rdr_module live until code generation?
- -- SDM 3/2002
-
- mod_name_to_Module nm
- = do m <- findModule nm ; return (fst (fromJust m))
-
(h_code, c_code, headers, fe_binders) = foreign_stuff
-- turn the list of headers requested in foreign import
--
foreign_headers =
unlines
- . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"")
+ . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
. reverse
$ headers
; fhdrs <- readIORef v_HCHeader
; writeIORef v_HCHeader (fhdrs ++ foreign_headers)
- ; imported_modules <- mapM mod_name_to_Module imported_module_names
-
; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
<- if toInterp
#ifdef GHCI
-------------------
-- PARSE
-------------------
- ; inp <- readFile (unJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
+ ; inp <- readFile (expectJust "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 {
<- 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 {
+ Just (dont_discard, new_iface, rn_decls) -> do {
-------------------
-- TYPECHECK
-------------------
; maybe_tc_result
<- _scc_ "TypeCheck"
- typecheckCoreModule dflags pcs_rn hst new_iface (rr_decls rn_result)
+ typecheckCoreModule dflags pcs_rn hst new_iface rn_decls
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
- Just (pcs_tc, ty_env, core_binds) -> do {
+ Just (pcs_tc, tc_result) -> do {
-------------------
-- DESUGAR
-------------------
- ; (ds_details, foreign_stuff) <- deSugarCore ty_env core_binds
- ; return (Right (this_mod, rdr_module, maybe_rn_result,
+ ; (ds_details, foreign_stuff) <- deSugarCore tc_result
+ ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}
-- PARSE
-------------------
; maybe_parsed <- myParseModule dflags
- (unJust "hscRecomp:hspp" (ml_hspp_file location))
+ (expectJust "hscRecomp:hspp" (ml_hspp_file location))
; case maybe_parsed of {
Nothing -> return (Left (HscFail pcs_ch));
Just rdr_module -> do {
; (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,
+ ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}}
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
parrEF = dopt Opt_PArr dflags}
- loc = mkSrcLoc (_PK_ src_filename) 1
+ loc = mkSrcLoc (mkFastString src_filename) 1
case parseModule buf (mkPState loc exts) of {
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
parrEF = dopt Opt_PArr dflags}
- loc = mkSrcLoc SLIT("<interactive>") 1
+ loc = mkSrcLoc FSLIT("<interactive>") 1
case parseStmt buf (mkPState loc exts) of {
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
parrEF = dopt Opt_PArr dflags}
- loc = mkSrcLoc SLIT("<interactive>") 1
+ loc = mkSrcLoc FSLIT("<interactive>") 1
case parseIdentifier buf (mkPState loc exts) of