X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=d8ead0bcaa24d4c03741f85b918b9ec4a6610fcb;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=129afc12ef0bea28f2d0de4aded37cb22f25f2d6;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 129afc1..d8ead0b 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -18,55 +18,49 @@ module MkIface ( ifacePragmas ) where -import Ubiq{-uitous-} +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, dataConSig, dataConFieldLabels, +import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing/Outputable-} ) -import Name ( nameOrigName, origName, nameOf, +import Maybes ( maybeToBool ) +import Name ( origName, nameOf, moduleOf, exportFlagOn, nameExportFlag, ExportFlag(..), - ltLexical, isExported, getExportFlag, - isLexSym, isLocallyDefined, + isLexSym, isLexCon, isLocallyDefined, isWiredInName, RdrName(..){-instance Outputable-}, + OrigName(..){-instance Ord-}, Name{-instance NamedThing-} ) import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) +--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) ppr_tyvar tv = prettyToUn (ppr PprInterface tv) ppr_name n - = let - on = origName n - s = nameOf on - pp = prettyToUn (ppr PprInterface on) - in - (if isLexSym s then uppParens else id) pp -ppr_unq_name n - = let - on = origName n - s = nameOf on - pp = uppPStr s - in - (if isLexSym s then uppParens else id) pp + = case (origName "ppr_name" n) of { OrigName m s -> + uppBesides [uppPStr m, uppChar '.', uppPStr s] } \end{code} We have a function @startIface@ to open the output file and put @@ -91,7 +85,8 @@ ifaceVersions -> IO () ifaceExportList :: Maybe Handle - -> RenamedHsModule + -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)])) + -> RnEnv -> IO () ifaceFixities :: Maybe Handle @@ -120,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 () @@ -137,14 +132,19 @@ 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 = 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... upp_uses (m, (mv, versions)) - = uppBesides [uppPStr m, uppSP, uppPStr SLIT(" :: "), + = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), upp_versions (fmToList versions), uppSemi] upp_versions nvs - = uppIntersperse upp'SP{-'-} [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] + = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] \end{code} \begin{code} @@ -156,6 +156,10 @@ ifaceVersions (Just if_hdl) version_info | otherwise = hPutStr if_hdl "\n__versions__\n" >> hPutStr if_hdl (uppShow 0 (upp_versions version_list)) + -- NB: when compiling Prelude.hs, this will spew out + -- stuff for [], (), (,), etc. [i.e., builtins], which + -- we'd rather it didn't. The version-mangling in + -- the driver will ignore them. where version_list = fmToList version_info @@ -174,61 +178,88 @@ 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 (Name, 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 (Name, ExportFlag) -> RnName -> Bag (Name, 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` (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,_) = nameOrigName n1 < nameOrigName n2 + lexical_lt (n1,_) (n2,_) = n1 < n2 -------------- - upp_pair (n, ef) - = uppBeside (ppr_name n) (upp_export ef) + upp_pair (OrigName m n, ef) + = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef] where upp_export ExportAll = uppPStr SLIT("(..)") upp_export ExportAbs = uppNil @@ -239,34 +270,44 @@ ifaceFixities Nothing{-no iface handle-} _ = return () ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) = let - local_fixities = filter from_here fixities + pp_fixities = foldr go [] fixities in - if null local_fixities then + if null pp_fixities then return () else hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities))) + hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities)) where - from_here (InfixL v _) = isLocallyDefined v - from_here (InfixR v _) = isLocallyDefined v - from_here (InfixN v _) = isLocallyDefined v + go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc + go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc + go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc + + print_fix suff prec var + = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi] \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, _) - = let --- exported_classes = filter isExported classes --- exported_tycons = filter isExported tycons - exported_vals = filter isExported vals - - sorted_classes = sortLt ltLexical classes - sorted_tycons = sortLt ltLexical tycons - sorted_vals = sortLt ltLexical exported_vals + = ASSERT(all isLocallyDefined vals) + ASSERT(all isLocallyDefined tycons) + ASSERT(all isLocallyDefined classes) + let + nonwired_classes = filter non_wired classes + nonwired_tycons = filter non_wired tycons + nonwired_vals = filter non_wired vals + + lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b + + sorted_classes = sortLt lt_lexical nonwired_classes + sorted_tycons = sortLt lt_lexical nonwired_tycons + 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" >> @@ -281,17 +322,17 @@ ifaceInstances Nothing{-no iface handle-} _ = return () ifaceInstances (Just if_hdl) (_, _, _, insts) = let - exported_insts = filter is_exported_inst (bagToList insts) + togo_insts = filter is_togo_inst (bagToList insts) - sorted_insts = sortLt lt_inst exported_insts + sorted_insts = sortLt lt_inst togo_insts in - if null exported_insts then + if null togo_insts then return () else hPutStr if_hdl "\n__instances__\n" >> hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts))) where - is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) + is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) = from_here -- && ... ------- @@ -301,10 +342,10 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) tycon1 = fst (getAppTyCon ty1) tycon2 = fst (getAppTyCon ty2) in - case (origName clas1 `cmp` origName clas2) of + case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of LT_ -> True GT_ -> False - EQ_ -> origName tycon1 < origName tycon2 + EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2 ------- pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _) @@ -312,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} %************************************************************************ @@ -329,25 +371,27 @@ ppr_class c case (initNmbr (nmbrClass c)) of { -- renumber it! Class _ n tyvar super_classes sdsels ops sels defms insts links -> - uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes, + uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes, ppr_name n, ppr_tyvar tyvar, if null ops then uppSemi else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] } where - ppr_theta :: TyVar -> [Class] -> Unpretty + ppr_context :: TyVar -> [Class] -> Unpretty - ppr_theta tv [] = uppNil - ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) - ppr_theta tv super_classes - = uppBesides [uppLparen, + ppr_context tv [] = uppNil +-- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) + ppr_context tv super_classes + = uppBesides [uppStr "{{", uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), - uppStr ") =>"] + uppStr "}} =>"] ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] - ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty + clas_mod = moduleOf (origName "ppr_class" c) + + ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty \end{code} \begin{code} @@ -356,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} @@ -365,7 +413,7 @@ ppr_tycon tycon ppr_tc (initNmbr (nmbrTyCon tycon)) ------------------------ -ppr_tc (PrimTyCon _ n _) +ppr_tc (PrimTyCon _ n _ _) = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] ppr_tc FunTyCon @@ -386,7 +434,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) ppr_context ctxt, ppr_name n, uppIntersperse uppSP (map ppr_tyvar tvs), - pp_unabstract_condecls, + uppEquals, pp_condecls, uppSemi] -- NB: we do not print deriving info in interfaces where @@ -395,21 +443,11 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) NewType -> uppPStr SLIT("newtype") ppr_context [] = uppNil - ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] +-- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] ppr_context cs - = uppBesides[uppLparen, + = uppBesides[uppStr "{{", uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - uppRparen, uppPStr SLIT(" =>")] - - yes_we_print_condecls - = case (getExportFlag n) of - ExportAbs -> False - other -> True - - pp_unabstract_condecls - = if yes_we_print_condecls - then uppCat [uppEquals, pp_condecls] - else uppNil + uppStr "}}", uppPStr SLIT(" =>")] pp_condecls = let @@ -421,11 +459,11 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) ppr_con con = let - (_, _, con_arg_tys, _) = dataConSig con + con_arg_tys = dataConRawArgTys con labels = dataConFieldLabels con -- none if not a record strict_marks = dataConStrictMarks con in - uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys] + uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys] ppr_fields labels strict_marks con_arg_tys = if null labels then -- not a record thingy @@ -440,7 +478,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) (prettyToUn (pprParendType PprInterface t)) ppr_field l b t - = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "), + = uppBesides [ppr_name l, uppPStr SLIT(" :: "), case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, ppr_ty t] \end{code}