[project @ 1996-06-26 10:26:00 by partain]

[ghc-hetmet.git] / ghc / compiler / main / Main.lhs

diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index ef89a61..8bd7f24 100644 (file)
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -8,9 +8,7 @@
 
 module Main ( main ) where
 
-import Ubiq{-uitous-}
-
-import PreludeGlaST    ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
+IMP_Ubiq(){-uitous-}
 
 import HsSyn
 
@@ -33,11 +31,11 @@ import Bag          ( emptyBag, isEmptyBag )
 import CmdLineOpts
 import ErrUtils                ( pprBagOfErrors, ghcExit )
 import Maybes          ( maybeToBool, MaybeErr(..) )
-import PrelInfo                ( builtinNameInfo )
 import RdrHsSyn                ( getRawExportees )
 import Specialise      ( SpecialiseData(..) )
 import StgSyn          ( pprPlainStgBinding, GenStgBinding )
 import TcInstUtil      ( InstInfo )
+import TyCon           ( isDataTyCon )
 import UniqSupply      ( mkSplitUniqSupply )
 
 import PprAbsC         ( dumpRealC, writeRealC )
@@ -66,10 +64,11 @@ main
 doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
 
 doIt (core_cmds, stg_cmds) input_pgm
-  = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >>
+  = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >>
 
     -- ******* READER
     show_pass "Reader" >>
+    _scc_     "Reader"
     rdModule           >>= \ (mod_name, rdr_module) ->
 
     doDump opt_D_dump_rdr "Reader:"
@@ -79,24 +78,22 @@ doIt (core_cmds, stg_cmds) input_pgm
        (pp_show (ppSourceStats rdr_module))    >>
 
     -- UniqueSupplies for later use (these are the only lower case uniques)
-    mkSplitUniqSupply 'r'      >>= \ rn_uniqs ->       -- renamer
-    mkSplitUniqSupply 't'      >>= \ tc_uniqs ->       -- typechecker
-    mkSplitUniqSupply 'd'      >>= \ ds_uniqs ->       -- desugarer
-    mkSplitUniqSupply 's'      >>= \ sm_uniqs ->       -- core-to-core simplifier
-    mkSplitUniqSupply 'c'      >>= \ c2s_uniqs ->      -- core-to-stg
-    mkSplitUniqSupply 'g'      >>= \ st_uniqs ->       -- stg-to-stg passes
-    mkSplitUniqSupply 'f'      >>= \ fl_uniqs ->       -- absC flattener
+    mkSplitUniqSupply 'r'      >>= \ rn_uniqs  -> -- renamer
+    mkSplitUniqSupply 'a'      >>= \ tc_uniqs  -> -- typechecker
+    mkSplitUniqSupply 'd'      >>= \ ds_uniqs  -> -- desugarer
+    mkSplitUniqSupply 's'      >>= \ sm_uniqs  -> -- core-to-core simplifier
+    mkSplitUniqSupply 'c'      >>= \ c2s_uniqs -> -- core-to-stg
+    mkSplitUniqSupply 'g'      >>= \ st_uniqs  -> -- stg-to-stg passes
+    mkSplitUniqSupply 'f'      >>= \ fl_uniqs  -> -- absC flattener
     mkSplitUniqSupply 'n'      >>= \ ncg_uniqs -> -- native-code generator
 
     -- ******* RENAMER
     show_pass "Renamer"                        >>
+    _scc_     "Renamer"
 
-    case builtinNameInfo
-    of { (wiredin_fm, key_fm, idinfo_fm) ->
-
-    renameModule wiredin_fm key_fm rn_uniqs rdr_module >>=
+    renameModule rn_uniqs rdr_module >>=
        \ (rn_mod, rn_env, import_names,
-          version_info, instance_modules,
+          export_fn, usage_stuff,
           rn_errs_bag, rn_warns_bag) ->
 
     if (not (isEmptyBag rn_errs_bag)) then
@@ -122,14 +119,19 @@ doIt (core_cmds, stg_cmds) input_pgm
     -- (the iface file is produced incrementally, as we have
     -- the information that we need...; we use "iface<blah>")
     -- "endIface" finishes the job.
+    let
+       (usages_map, version_info, instance_modules) = usage_stuff
+    in
     startIface mod_name                                    >>= \ if_handle ->
+    ifaceUsages                 if_handle usages_map       >>
     ifaceVersions       if_handle version_info     >>
-    ifaceExportList     if_handle rn_mod           >>
+    ifaceExportList     if_handle export_fn rn_mod >>
     ifaceFixities       if_handle rn_mod           >>
     ifaceInstanceModules if_handle instance_modules >>
 
     -- ******* TYPECHECKER
     show_pass "TypeCheck"                      >>
+    _scc_     "TypeCheck"
     case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
            Succeeded (stuff, warns)
                -> (emptyBag, warns, stuff)
@@ -156,8 +158,8 @@ doIt (core_cmds, stg_cmds) input_pgm
 
     case tc_results
     of {  (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
-          interface_stuff,
-          (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
+          interface_stuff@(_,local_tycons,_,_),
+          pragma_tycon_specs, ddump_deriv) ->
 
     doDump opt_D_dump_tc "Typechecked:"
        (pp_show (ppAboves [
@@ -176,6 +178,7 @@ doIt (core_cmds, stg_cmds) input_pgm
 
     -- ******* DESUGARER
     show_pass "DeSugar"                        >>
+    _scc_     "DeSugar"
     let
        (desugared,ds_warnings)
          = deSugar ds_uniqs mod_name typechecked_quint
@@ -192,8 +195,13 @@ doIt (core_cmds, stg_cmds) input_pgm
                                                >>
 
     -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
+    show_pass "Core2Core"                      >>
+    _scc_     "Core2Core"
+    let
+       local_data_tycons = filter isDataTyCon local_tycons
+    in
     core2core core_cmds mod_name pprStyle
-             sm_uniqs local_tycons pragma_tycon_specs desugared
+             sm_uniqs local_data_tycons pragma_tycon_specs desugared
                                                >>=
 
         \ (simplified, inlinings_env,
@@ -205,11 +213,13 @@ doIt (core_cmds, stg_cmds) input_pgm
 
     -- ******* STG-TO-STG SIMPLIFICATION
     show_pass "Core2Stg"                       >>
+    _scc_     "Core2Stg"
     let
        stg_binds   = topCoreBindsToStg c2s_uniqs simplified
     in
 
     show_pass "Stg2Stg"                        >>
+    _scc_     "Stg2Stg"
     stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds
                                                >>=
 
@@ -225,6 +235,7 @@ doIt (core_cmds, stg_cmds) input_pgm
 
     -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
     show_pass "CodeGen"                        >>
+    _scc_     "CodeGen"
     let
        abstractC      = codeGen mod_name     -- module name for CC labelling
                                 cost_centre_info
@@ -272,7 +283,7 @@ doIt (core_cmds, stg_cmds) input_pgm
     doOutput opt_ProduceC c_output_w           >>
 
     ghcExit 0
-    } ) } }
+    } ) }
   where
     -------------------------------------------------------------
     -- ****** printing styles and column width:
@@ -303,15 +314,9 @@ doIt (core_cmds, stg_cmds) input_pgm
       = case switch of
          Nothing -> return ()
          Just fname ->
-           fopen fname "a+"    `thenPrimIO` \ file ->
-           if (file == ``NULL'') then
-               error ("doOutput: failed to open:"++fname)
-           else
-               io_action file          >>=     \ () ->
-               fclose file             `thenPrimIO` \ status ->
-               if status == 0
-               then return ()
-               else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+           openFile fname WriteMode    >>= \ handle ->
+           io_action handle            >>
+           hClose handle
 
     doDump switch hdr string
       = if switch