X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=d8ead0bcaa24d4c03741f85b918b9ec4a6610fcb;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=a1cb9f79b013a6127a5aeda8f293dc7ea5b87e9f;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a1cb9f7..d8ead0b 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -19,21 +19,22 @@ module MkIface ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..))) -import Bag ( emptyBag, snocBag, bagToList ) +import Bag ( bagToList ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) import CmdLineOpts ( opt_ProduceHi ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) -import FiniteMap ( fmToList ) +import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap ) import HsSyn -import Id ( idType, dataConRawArgTys, dataConFieldLabels, +import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing/Outputable-} ) +import Maybes ( maybeToBool ) import Name ( origName, nameOf, moduleOf, exportFlagOn, nameExportFlag, ExportFlag(..), - isExported, getExportFlag, - isLexSym, isLocallyDefined, isWiredInName, + isLexSym, isLexCon, isLocallyDefined, isWiredInName, RdrName(..){-instance Outputable-}, OrigName(..){-instance Ord-}, Name{-instance NamedThing-} @@ -42,15 +43,17 @@ import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) -import PrelMods ( modulesWithBuiltins ) +--import PrelMods ( modulesWithBuiltins ) +import PrelInfo ( builtinValNamesMap, builtinTcNamesMap ) import Pretty ( prettyToUn ) import Unpretty -- ditto -import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) -import TcModule ( TcIfaceInfo(..) ) +import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) ) +import RnUtils ( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} ) +import TcModule ( SYN_IE(TcIfaceInfo) ) import TcInstUtil ( InstInfo(..) ) import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon ) -import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) +import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} ) uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util ppr_ty ty = prettyToUn (pprType PprInterface ty) @@ -82,7 +85,8 @@ ifaceVersions -> IO () ifaceExportList :: Maybe Handle - -> RenamedHsModule + -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)])) + -> RnEnv -> IO () ifaceFixities :: Maybe Handle @@ -111,7 +115,7 @@ startIface mod Nothing -> return Nothing -- not producing any .hi file Just fn -> openFile fn WriteMode >>= \ if_hdl -> - hPutStr if_hdl ("interface "++ _UNPK_ mod) >> + hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >> return (Just if_hdl) endIface Nothing = return () @@ -128,12 +132,12 @@ ifaceUsages (Just if_hdl) usages = hPutStr if_hdl "\n__usages__\n" >> hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) where - usages_list = filter has_no_builtins (fmToList usages) + usages_list = fmToList usages -- NO: filter has_no_builtins (...) - has_no_builtins (m, _) - = m `notElem` modulesWithBuiltins - -- Don't *have* to do this; save gratuitous spillage in - -- every interface. Could be flag-controlled... +-- has_no_builtins (m, _) +-- = m `notElem` modulesWithBuiltins +-- -- Don't *have* to do this; save gratuitous spillage in +-- -- every interface. Could be flag-controlled... upp_uses (m, (mv, versions)) = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), @@ -174,54 +178,81 @@ ifaceInstanceModules (Just if_hdl) imods Export list: grab the Names of things that are marked Exported, sort (so the interface file doesn't ``wobble'' from one compilation to the -next...), and print. Note that the ``module'' now contains all the -imported things that we are dealing with, thus including any entities -that we are re-exporting from somewhere else. +next...), and print. We work from the renamer's final ``RnEnv'', +which has all the names we might possibly be interested in. +(Note that the ``module X'' export items can cause a lot of grief.) \begin{code} -ifaceExportList Nothing{-no iface handle-} _ = return () +ifaceExportList Nothing{-no iface handle-} _ _ = return () ifaceExportList (Just if_hdl) - (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) + (export_fn, (dotdot_vals, dotdot_tcs)) + rn_env@((qual, unqual, tc_qual, tc_unqual), _) = let - name_flag_pairs :: Bag (OrigName, ExportFlag) + name_flag_pairs :: FiniteMap OrigName ExportFlag name_flag_pairs - = foldr from_ty - (foldr from_cls - (foldr from_sig - (from_binds binds emptyBag{-init accum-}) - sigs) - classdecls) - typedecls - - sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs) + = foldr (from_wired True{-val-ish-}) + (foldr (from_wired False{-tycon-ish-}) + (foldr (from_dotdot True{-val-ish-}) + (foldr (from_dotdot False{-tycon-ish-}) + (foldr from_val + (foldr from_val + (foldr from_tc + (foldr from_tc emptyFM{-init accum-} + (eltsFM tc_unqual)) + (eltsFM tc_qual)) + (eltsFM unqual)) + (eltsFM qual)) + dotdot_tcs) + dotdot_vals) + (eltsFM builtinTcNamesMap)) + (eltsFM builtinValNamesMap) + + sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs) in + --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $ hPutStr if_hdl "\n__exports__\n" >> hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs))) where - from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TySynonym n _ _ _) acc = maybe_add acc n - - from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n + from_val rn acc + | fun_looking rn && exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + ef = export_fn n -- NB: using the export fn! + n = getName rn + on = origName "from_val" n - from_sig (Sig n _ _ _) acc = maybe_add acc n + -- fun_looking: must avoid class ops and data constructors + -- and record fieldnames + fun_looking (RnName _) = True + fun_looking (WiredInId i) = not (isDataCon i) + fun_looking _ = False - from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) + from_tc rn acc + | exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + ef = export_fn n -- NB: using the export fn! + n = getName rn + on = origName "from_tc" n - -------------- - maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag) + from_dotdot is_valish (n,ef) acc + | is_valish && isLexCon str = acc + | exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + on = origName "from_dotdot" n + (OrigName _ str) = on - maybe_add acc rn - | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef) + from_wired is_val_ish rn acc + | is_val_ish && not (fun_looking rn) + = acc -- these things don't cause export-ery + | exportFlagOn ef = addToFM acc on ef | otherwise = acc where n = getName rn - ef = nameExportFlag n - - -------------- - maybe_add_list acc [] = acc - maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n + ef = export_fn n + on = origName "from_wired" n -------------- lexical_lt (n1,_) (n2,_) = n1 < n2 @@ -256,6 +287,8 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) \end{code} \begin{code} +non_wired x = not (isWiredInName (getName x)) --ToDo:move? + ifaceDecls Nothing{-no iface handle-} _ = return () ifaceDecls (Just if_hdl) (vals, tycons, classes, _) @@ -263,8 +296,6 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _) ASSERT(all isLocallyDefined tycons) ASSERT(all isLocallyDefined classes) let - non_wired x = not (isWiredInName (getName x)) - nonwired_classes = filter non_wired classes nonwired_tycons = filter non_wired tycons nonwired_vals = filter non_wired vals @@ -276,7 +307,7 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _) sorted_vals = sortLt lt_lexical nonwired_vals in if (null sorted_classes && null sorted_tycons && null sorted_vals) then - -- You could have a module with just instances in it + -- You could have a module with just (re-)exports/instances in it return () else hPutStr if_hdl "\n__declarations__\n" >> @@ -322,7 +353,8 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) renumbered_ty = initNmbr (nmbrType forall_ty) in - uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi] + case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) -> + uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] } \end{code} %************************************************************************ @@ -368,7 +400,11 @@ ppr_val v ty -- renumber the type first! pp_sig v (initNmbr (nmbrType ty)) pp_sig op ty - = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi] + = case (splitForAllTy ty) of { (tvs, rho_ty) -> + uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] } + +ppr_forall [] = uppNil +ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ] \end{code} \begin{code}