%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
%
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
import Rename ( renameModule )
+import PrelInfo ( wiredInThings )
+import PrelRules ( builtinRules )
import MkIface ( writeIface )
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import Outputable
import Char ( isSpace )
-#if REPORT_TO_MOTHERLODE && __GLASGOW_HASKELL__ >= 303
-import SocketPrim
-import BSD
-import IOExts ( unsafePerformIO )
-import NativeInfo ( os, arch )
-#endif
import StgInterp ( runStgI )
+import HscStats ( ppSourceStats )
\end{code}
+
+%************************************************************************
+%* *
+\subsection{The main compiler pipeline}
+%* *
+%************************************************************************
+
\begin{code}
+data HscResult
+ = HscOK ModDetails -- new details (HomeSymbolTable additions)
+ (Maybe ModIface) -- new iface (if any compilation was done)
+ (Maybe String) -- generated stub_h filename (in /tmp)
+ (Maybe String) -- generated stub_c filename (in /tmp)
+ (Maybe [UnlinkedIBind]) -- interpreted code, if any
+ PersistentCompilerState -- updated PCS
+ (Bag WarnMsg) -- warnings
+
+ | HscErrs PersistentCompilerState -- updated PCS
+ (Bag ErrMsg) -- errors
+ (Bag WarnMsg) -- warnings
+
hscMain
:: DynFlags
-> ModSummary -- summary, including source filename
-> IO HscResult
hscMain flags core_cmds stg_cmds summary maybe_old_iface
- output_filename mod_details pcs =
+ output_filename mod_details pcs1 =
-------------------------- Reader ----------------
show_pass "Parser" >>
_scc_ "Parser"
+ let src_filename -- name of the preprocessed source file
+ = case ms_ppsource summary of
+ Just (filename, fingerprint) -> filename
+ Nothing -> pprPanic "hscMain:summary is not of a source module"
+ (ppr summary)
+
buf <- hGetStringBuffer True{-expand tabs-} src_filename
let glaexts | opt_GlasgowExts = 1#
context = [], glasgow_exts = glaexts,
loc = mkSrcLoc src_filename 1 } of {
- PFailed err -> return (CompErrs pcs err);
+ PFailed err -> return (CompErrs pcs err)
POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
(ppSourceStats False rdr_module) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
- mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
- mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
- mkSplitUniqSupply 'u' >>= \ tidy_uniqs -> -- tidy up
mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
- typecheckModule tc_uniqs rn_name_supply
- fixity_env rn_mod >>= \ maybe_tc_stuff ->
+ typecheckModule dflags mod pcs hst hit pit rn_mod
+ -- tc_uniqs rn_name_supply
+ -- fixity_env rn_mod
+ >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
-------------------------- Main Core-language transformations ----------------
_scc_ "Core2Core"
- core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
+ core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
-- Do the final tidy-up
- tidyCorePgm tidy_uniqs this_mod
- simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
+ tidyCorePgm 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
= if opt_D_show_passes
then \ what -> hPutStr stderr ("*** "++what++":\n")
else \ what -> return ()
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Initial persistent state}
+%* *
+%************************************************************************
+
+\begin{code}
+initPersistentCompilerState :: PersistentCompilerState
+initPersistentCompilerState
+ = PCS { pcs_PST = initPackageDetails,
+ pcs_insts = emptyInstEnv,
+ pcs_rules = initRules,
+ pcs_PRS = initPersistentRenamerState }
+
+initPackageDetails :: PackageSymbolTable
+initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
+
+initPersistentRenamerState :: PersistentRenamerState
+ = PRS { prsOrig = Orig { origNames = initOrigNames,
+ origIParam = emptyFM },
+ prsDecls = emptyNameEnv,
+ prsInsts = emptyBag,
+ prsRules = emptyBag
+ }
+
+initOrigNames :: FiniteMap (ModuleName,OccName) Name
+initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
+ where
+ grab names = foldl add emptyFM names
+ add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
+
+
+initRules :: RuleEnv
+initRules = foldl add emptyVarEnv builtinRules
+ where
+ add env (name,rule) = extendNameEnv_C add1 env name [rule]
+ add1 rules _ = rule : rules
+\end{code}
+
+
+
+\begin{code}
+writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids tidy_binds tidy_orphan_rules
+ =
+ if isNothing opt_HiDir && isNothing opt_HiFile
+ then return () -- not producing any .hi file
+ else
+
+ let
+ hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
+ filename = case opt_HiFile of {
+ Just f -> f;
+ Nothing ->
+ case opt_HiDir of {
+ Just dir -> dir ++ '/':moduleUserString this_mod
+ ++ '.':hi_suf;
+ Nothing -> panic "writeIface"
+ }}
+ in
+
+ do maybe_final_iface <- checkIface old_iface full_new_iface
+ case maybe_final_iface of {
+ Nothing -> when opt_D_dump_rn_trace $
+ putStrLn "Interface file unchanged" ; -- No need to update .hi file
+
+ Just final_iface ->
+
+ do let mod_vers_unchanged = case old_iface of
+ Just iface -> pi_vers iface == pi_vers final_iface
+ Nothing -> False
+ when (mod_vers_unchanged && opt_D_dump_rn_trace) $
+ putStrLn "Module version unchanged, but usages differ; hence need new hi file"
-ppSourceStats short (HsModule name version exports imports decls _ src_loc)
- = (if short then hcat else vcat)
- (map pp_val
- [("ExportAll ", export_all), -- 1 if no export list
- ("ExportDecls ", export_ds),
- ("ExportModules ", export_ms),
- ("Imports ", import_no),
- (" ImpQual ", import_qual),
- (" ImpAs ", import_as),
- (" ImpAll ", import_all),
- (" ImpPartial ", import_partial),
- (" ImpHiding ", import_hiding),
- ("FixityDecls ", fixity_ds),
- ("DefaultDecls ", default_ds),
- ("TypeDecls ", type_ds),
- ("DataDecls ", data_ds),
- ("NewTypeDecls ", newt_ds),
- ("DataConstrs ", data_constrs),
- ("DataDerivings ", data_derivs),
- ("ClassDecls ", class_ds),
- ("ClassMethods ", class_method_ds),
- ("DefaultMethods ", default_method_ds),
- ("InstDecls ", inst_ds),
- ("InstMethods ", inst_method_ds),
- ("TypeSigs ", bind_tys),
- ("ValBinds ", val_bind_ds),
- ("FunBinds ", fn_bind_ds),
- ("InlineMeths ", method_inlines),
- ("InlineBinds ", bind_inlines),
--- ("SpecialisedData ", data_specs),
--- ("SpecialisedInsts ", inst_specs),
- ("SpecialisedMeths ", method_specs),
- ("SpecialisedBinds ", bind_specs)
- ])
+ if_hdl <- openFile filename WriteMode
+ printForIface if_hdl (pprIface final_iface)
+ hClose if_hdl
+ }
where
- pp_val (str, 0) = empty
- pp_val (str, n)
- | not short = hcat [text str, int n]
- | otherwise = hcat [text (trim str), equals, int n, semi]
+ full_new_iface = completeIface new_iface local_tycons local_classes
+ inst_info final_ids tidy_binds
+ tidy_orphan_rules
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Printing the interface}
+%* *
+%************************************************************************
+
+\begin{code}
+pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
+ pi_usages = usages, pi_exports = exports,
+ pi_fixity = (fix_vers, fixities),
+ pi_insts = insts, pi_decls = decls,
+ pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
+ = vcat [ ptext SLIT("__interface")
+ <+> doubleQuotes (ptext opt_InPackage)
+ <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
+ <+> (if orphan then char '!' else empty)
+ <+> int opt_HiVersion
+ <+> ptext SLIT("where")
+ , vcat (map pprExport exports)
+ , vcat (map pprUsage usages)
+ , pprFixities fixities
+ , vcat [ppr i <+> semi | i <- insts]
+ , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
+ , pprRules rules
+ , pprDeprecs deprecs
+ ]
+ where
+ ppr_vers v | v == initialVersion = empty
+ | otherwise = int v
+ pp_sub_vers
+ | fix_vers == initialVersion && rule_vers == initialVersion = empty
+ | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
+\end{code}
+
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+
+\begin{code}
+pprExport :: ExportItem -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
+ where
+ upp_avail :: RdrAvailInfo -> SDoc
+ upp_avail (Avail name) = pprOccName name
+ upp_avail (AvailTC name []) = empty
+ upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+ where
+ bang | name `elem` ns = empty
+ | otherwise = char '|'
+ ns' = filter (/= name) ns
- trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
-
- fixity_ds = length [() | FixD d <- decls]
- -- NB: this omits fixity decls on local bindings and
- -- in class decls. ToDo
-
- tycl_decls = [d | TyClD d <- decls]
- (class_ds, data_ds, newt_ds, type_ds) = countTyClDecls tycl_decls
-
- inst_decls = [d | InstD d <- decls]
- inst_ds = length inst_decls
- default_ds = length [() | DefD _ <- decls]
- val_decls = [d | ValD d <- decls]
-
- real_exports = case exports of { Nothing -> []; Just es -> es }
- n_exports = length real_exports
- export_ms = length [() | IEModuleContents _ <- real_exports]
- export_ds = n_exports - export_ms
- export_all = case exports of { Nothing -> 1; other -> 0 }
-
- (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
- = count_binds (foldr ThenBinds EmptyBinds val_decls)
-
- (import_no, import_qual, import_as, import_all, import_partial, import_hiding)
- = foldr add6 (0,0,0,0,0,0) (map import_info imports)
- (data_constrs, data_derivs)
- = foldr add2 (0,0) (map data_info tycl_decls)
- (class_method_ds, default_method_ds)
- = foldr add2 (0,0) (map class_info tycl_decls)
- (inst_method_ds, method_specs, method_inlines)
- = foldr add3 (0,0,0) (map inst_info inst_decls)
-
-
- count_binds EmptyBinds = (0,0,0,0,0)
- count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
- count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
- ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
-
- count_monobinds EmptyMonoBinds = (0,0)
- count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
- count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
- count_monobinds (PatMonoBind p r _) = (0,1)
- count_monobinds (FunMonoBind f _ m _) = (0,1)
-
- 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 (SpecSig _ _ _) = (0,0,1,0)
- sig_info (InlineSig _ _ _) = (0,0,0,1)
- sig_info (NoInlineSig _ _ _) = (0,0,0,1)
- sig_info _ = (0,0,0,0)
-
- import_info (ImportDecl _ _ qual as spec _)
- = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
- qual_info False = 0
- qual_info True = 1
- as_info Nothing = 0
- as_info (Just _) = 1
- spec_info Nothing = (0,0,0,1,0,0)
- spec_info (Just (False, _)) = (0,0,0,0,1,0)
- spec_info (Just (True, _)) = (0,0,0,0,0,1)
-
- 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 _ _ _ )
- = case count_sigs meth_sigs of
- (_,classops,_,_) ->
- (classops, addpr (count_monobinds def_meths))
- class_info other = (0,0)
-
- inst_info (InstDecl _ inst_meths inst_sigs _ _)
- = case count_sigs inst_sigs of
- (_,_,ss,is) ->
- (addpr (count_monobinds inst_meths), ss, is)
-
- addpr :: (Int,Int) -> Int
- add1 :: Int -> Int -> Int
- add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
- add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int)
- add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
- add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
- add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
-
- addpr (x,y) = x+y
- add1 x1 y1 = x1+y1
- add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
- add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
- add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
- add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
- add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
+ upp_export [] = empty
+ upp_export names = braces (hsep (map pprOccName names))
\end{code}
+
\begin{code}
+pprUsage :: ImportVersion OccName -> SDoc
+pprUsage (m, has_orphans, is_boot, whats_imported)
+ = hsep [ptext SLIT("import"), pprModuleName m,
+ pp_orphan, pp_boot,
+ upp_import_versions whats_imported
+ ] <> semi
+ where
+ pp_orphan | has_orphans = char '!'
+ | otherwise = empty
+ pp_boot | is_boot = char '@'
+ | otherwise = empty
+
+ -- Importing the whole module is indicated by an empty list
+ upp_import_versions NothingAtAll = empty
+ upp_import_versions (Everything v) = dcolon <+> int v
+ upp_import_versions (Specifically vm vf vr nvs)
+ = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
\end{code}
+
\begin{code}
-reportCompile :: ModuleName -> String -> IO ()
-#if REPORT_TO_MOTHERLODE && __GLASGOW_HASKELL__ >= 303
-reportCompile mod_name info
- | not opt_ReportCompile = return ()
- | otherwise = (do
- sock <- udpSocket 0
- addr <- motherShip
- sendTo sock (moduleNameUserString mod_name ++ ';': compiler_version ++
- ';': os ++ ';':arch ++ '\n':' ':info ++ "\n") addr
- return ()) `catch` (\ _ -> return ())
-
-motherShip :: IO SockAddr
-motherShip = do
- he <- getHostByName "laysan.dcs.gla.ac.uk"
- case (hostAddresses he) of
- [] -> IOERROR (userError "No address!")
- (x:_) -> return (SockAddrInet motherShipPort x)
-
---magick
-motherShipPort :: PortNumber
-motherShipPort = mkPortNumber 12345
-
--- creates a socket capable of sending datagrams,
--- binding it to a port
--- ( 0 => have the system pick next available port no.)
-udpSocket :: Int -> IO Socket
-udpSocket p = do
- pr <- getProtocolNumber "udp"
- s <- socket AF_INET Datagram pr
- bindSocket s (SockAddrInet (mkPortNumber p) iNADDR_ANY)
- return s
-#else
-reportCompile _ _ = return ()
-#endif
+pprFixities [] = empty
+pprFixities fixes = hsep (map ppr fixes) <> semi
+
+pprRules [] = empty
+pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
+pprDeprecs [] = empty
+pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
+ where
+ guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
+ | Deprecation ie txt _ <- deps ]
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff