import IO ( hPutStr, stderr )
import HsSyn
-import BasicTypes ( NewOrData(..) )
import RdrHsSyn ( RdrNameHsModule )
-import FastString ( mkFastCharString, unpackFS )
+import FastString ( unpackFS )
import StringBuffer ( hGetStringBuffer )
import Parser ( parse )
-import Lex ( PState(..), P, ParseResult(..) )
+import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
import Rename ( renameModule )
-import RnMonad ( InterfaceDetails(..) )
-import MkIface ( startIface, ifaceDecls, endIface )
+import MkIface ( writeIface )
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
-import CoreLint ( endPass )
+import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
-import StgSyn ( collectFinalStgBinders, pprStgBindings )
+import StgSyn ( collectFinalStgBinders )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleNameUserString )
-import AbsCSyn ( absCNop )
import CmdLineOpts
import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
-import Maybes ( maybeToBool, MaybeErr(..) )
-import TyCon ( isDataTyCon )
-import Class ( classTyCon )
import UniqSupply ( mkSplitUniqSupply )
-import FiniteMap ( emptyFM )
import Outputable
import Char ( isSpace )
#if REPORT_TO_MOTHERLODE && __GLASGOW_HASKELL__ >= 303
import IOExts ( unsafePerformIO )
import NativeInfo ( os, arch )
#endif
-
+#ifdef GHCI
+import StgInterp ( runStgI )
+import CmStaticInfo ( Package(..) ) -- ToDo: maybe zap this?
+import CompManager
+import System ( getArgs ) -- tmp debugging hack; to be rm'd
+import Linker ( linkPrelude )
+#endif
\end{code}
\begin{code}
+#ifdef GHCI
+fptools = "/home/v-julsew/GHCI/fpt"
+main = stderr `seq` ghci_main
+
+ghci_main :: IO ()
+ghci_main
+ = do putStr "GHCI main\n"
+ args <- getArgs
+ if length args /= 2
+ then
+ do putStrLn "usage: ghci <path> ModuleName"
+ else
+ do pci_txt <- readFile (fptools ++ "/ghc/driver/package.conf.inplace")
+ let raw_package_info = read pci_txt :: [Package]
+ cmstate <- emptyCmState (args!!0) raw_package_info
+ junk <- cmLoadModule cmstate (args!!1)
+ return ()
+
+#else
main = stderr `seq` -- Bug fix. Sigh
-- _scc_ "main"
doIt classifyOpts
+#endif
\end{code}
\begin{code}
doIt (core_cmds, stg_cmds)
= doIfSet opt_Verbose
- (hPutStr stderr "Glasgow Haskell Compiler, version " >>
+ (hPutStr stderr "Glasgow Haskell Compiler, Version " >>
hPutStr stderr compiler_version >>
hPutStr stderr ", for Haskell 98, compiled by GHC version " >>
hPutStr stderr booter_version >>
hPutStr stderr "\n") >>
+#ifdef GHCI
+-- linkPrelude >>
+#endif
+
-------------------------- Reader ----------------
show_pass "Parser" >>
_scc_ "Parser"
reportCompile mod_name "Compilation NOT required!" >>
return ();
- Just (this_mod, rn_mod, iface_file_stuff@(InterfaceDetails _ _ _ deprecations),
- rn_name_supply, imported_modules) ->
+ Just (this_mod, rn_mod,
+ old_iface, new_iface,
+ rn_name_supply, fixity_env,
+ imported_modules) ->
-- Oh well, we've got to recompile for real
- -------------------------- Start interface file ----------------
- -- Safely past renaming: we can start the interface file:
- -- (the iface file is produced incrementally, as we have
- -- the information that we need...; we use "iface<blah>")
- -- "endIface" finishes the job.
- startIface this_mod iface_file_stuff >>= \ if_handle ->
-
-
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
typecheckModule tc_uniqs rn_name_supply
- iface_file_stuff rn_mod >>= \ maybe_tc_stuff ->
+ fixity_env rn_mod >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
tidyCorePgm tidy_uniqs this_mod
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
+ -- Run the occurrence analyser one last time, so that
+ -- dead binders get dead-binder info. This is exploited by
+ -- code generators to avoid spitting out redundant bindings.
+ -- The occurrence-zapping in Simplify.simplCaseBinder means
+ -- that the Simplifier nukes useful dead-var stuff especially
+ -- in case patterns.
+ let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
+
+ coreBindsSize occ_anal_tidy_binds `seq`
+-- TEMP: the above call zaps some space usage allocated by the
+-- simplifier, which for reasons I don't understand, persists
+-- thoroughout code generation
+
+
-------------------------- Convert to STG code -------------------------------
show_pass "Core2Stg" >>
_scc_ "Core2Stg"
let
- stg_binds = topCoreBindsToStg c2s_uniqs tidy_binds
+ stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
in
-------------------------- Simplify STG code -------------------------------
- show_pass "Stg2Stg" >>
+ show_pass "Stg2Stg" >>
_scc_ "Stg2Stg"
stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
+#ifdef GHCI
+ runStgI local_tycons local_classes
+ (map fst stg_binds2) >>= \ i_result ->
+ putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
+ >>
+#else
-------------------------- Interface file -------------------------------
-- Dump instance decls and type signatures into the interface file
_scc_ "Interface"
let
final_ids = collectFinalStgBinders (map fst stg_binds2)
in
- coreBindsSize tidy_binds `seq`
--- TEMP: the above call zaps some space usage allocated by the
--- simplifier, which for reasons I don't understand, persists
--- thoroughout code generation
-
- ifaceDecls if_handle local_tycons local_classes inst_info
- final_ids tidy_binds tidy_orphan_rules deprecations >>
- endIface if_handle >>
- -- We are definitely done w/ interface-file stuff at this point:
- -- (See comments near call to "startIface".)
+ writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids occ_anal_tidy_binds tidy_orphan_rules >>
-------------------------- Code generation -------------------------------
show_pass "CodeOutput" >>
_scc_ "CodeOutput"
codeOutput this_mod local_tycons local_classes
- tidy_binds stg_binds2
+ occ_anal_tidy_binds stg_binds2
c_code h_code abstractC
ncg_uniqs >>
-------------------------- Final report -------------------------------
reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
+#endif /* GHCI */
+
+
ghcExit 0
} }
where
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
sig_info (Sig _ _ _) = (1,0,0,0)
- sig_info (ClassOpSig _ _ _ _ _) = (0,1,0,0)
+ sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _ _) = (0,0,0,1)
sig_info (NoInlineSig _ _ _) = (0,0,0,1)
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ constrs derivs _ _)
- = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _ _)
+ = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _)
+ class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ )
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
projects / ghc-hetmet.git / blobdiff