From: simonpj Date: Thu, 26 Oct 2000 07:19:53 +0000 (+0000) Subject: [project @ 2000-10-26 07:19:52 by simonpj] X-Git-Tag: Approximately_9120_patches~3505 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6e42e208ebcc405ef38f2ebc94837dae946c56a0 [project @ 2000-10-26 07:19:52 by simonpj] wibbles --- diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index f14ecab..5ad6264 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -22,7 +22,7 @@ import StgSyn import AbsCUtils ( getAmodeRep ) import CgBindery ( getArgAmodes, bindNewToNode, - bindArgsToRegs, newTempAmodeAndIdInfo, + bindArgsToRegs, idInfoToAmode, stableAmodeIdInfo, heapIdInfo, CgIdInfo, bindNewToStack ) @@ -31,7 +31,6 @@ import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots, ) import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp, getSpRelOffset ) -import CgClosure ( cgTopRhsClosure ) import CgRetConv ( assignRegs ) import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE, mIN_UPD_SIZE ) @@ -39,23 +38,22 @@ import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall, mkUnboxedTupleReturnCode ) import CLabel ( mkClosureLabel ) -import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, +import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon, layOutDynClosure, layOutStaticClosure, closureSize ) import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) -import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon, +import DataCon ( DataCon, dataConName, dataConTag, isUnboxedTupleCon, isNullaryDataCon, dataConId, dataConWrapId ) -import Id ( Id, idName, idType, idPrimRep ) -import Name ( nameModule, isLocallyDefinedName ) +import Id ( Id, idName, idPrimRep ) import Literal ( Literal(..) ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Uniquable(..) ) import Util -import Panic ( assertPanic, trace ) +import Outputable \end{code} %************************************************************************ @@ -170,8 +168,6 @@ buildDynCon binder cc con [arg_amode] | maybeIntLikeCon con && in_range_int_lit arg_amode = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con)) where - (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con) - in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE in_range_int_lit _other_amode = False @@ -179,8 +175,6 @@ buildDynCon binder cc con [arg_amode] | maybeCharLikeCon con && in_range_char_lit arg_amode = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con)) where - (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con) - in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE in_range_char_lit _other_amode = False \end{code} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2b64b83..6872138 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -106,12 +106,12 @@ hscMain dflags core_cmds stg_cmds summary maybe_old_iface what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp ; - return (what_next dflags core_cmds stg_cmds summary hit hst + return (what_next dflags finder core_cmds stg_cmds summary hit hst pcs2 maybe_checked_iface) }} -hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface +hscNoRecomp dflags finder core_cmds stg_cmds summary hit hst pcs maybe_old_iface = do { -- we definitely expect to have the old interface available let old_iface = case maybe_old_iface of @@ -135,8 +135,6 @@ hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface let pcs_tc = tc_pcs tc_result env_tc = tc_env tc_result binds_tc = tc_binds tc_result - local_tycons = tc_tycons tc_result - local_classes = tc_classes tc_result local_insts = tc_insts tc_result local_rules = tc_rules tc_result ; @@ -151,7 +149,7 @@ hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface }}}} -hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface +hscRecomp dflags finder core_cmds stg_cmds summary hit hst pcs maybe_old_iface = do { -- what target are we shooting for? let toInterp = dopt_HscLang dflags == HscInterpreted @@ -179,8 +177,6 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface let pcs_tc = tc_pcs tc_result env_tc = tc_env tc_result binds_tc = tc_binds tc_result - local_tycons = tc_tycons tc_result - local_classes = tc_classes tc_result local_insts = tc_insts tc_result ; -- DESUGAR, SIMPLIFY, TIDY-CORE @@ -190,7 +186,7 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface ; -- CONVERT TO STG (stg_binds, cost_centre_info, top_level_ids) - <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds + <- myCoreToStg finder c2s_uniqs st_uniqs this_mod tidy_binds ; -- cook up a new ModDetails now we (finally) have all the bits let new_details = mkModDetails tc_env local_insts tidy_binds @@ -199,6 +195,11 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface -- and possibly create a new ModIface let maybe_final_iface = completeIface maybe_old_iface new_iface new_details ; + + -- Write the interface file + writeIface finder maybe_final_iface + ; + -- do the rest of code generation/emission (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename) <- restOfCodeGeneration toInterp @@ -309,61 +310,6 @@ myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds let final_ids = collectFinalStgBinders (map fst stg_binds2) return (stg_binds2, cost_centre_info, final_ids) - -#if 0 --- BEGIN old stuff - -- UniqueSupplies for later use (these are the only lower case uniques) - mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer - mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules - mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg - mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes - mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator - - -------------------------- Interface file ------------------------------- - -- Dump instance decls and type signatures into the interface file - _scc_ "Interface" - let - final_ids = collectFinalStgBinders (map fst stg_binds2) - in - 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 "CodeGen" >> - _scc_ "CodeGen" - codeGen this_mod imported_modules - cost_centre_info - fe_binders - local_tycons local_classes - stg_binds2 >>= \ abstractC -> - - - -------------------------- Code output ------------------------------- - show_pass "CodeOutput" >> - _scc_ "CodeOutput" - codeOutput this_mod local_tycons local_classes - occ_anal_tidy_binds stg_binds2 - c_code h_code abstractC - ncg_uniqs >> - - - -------------------------- Final report ------------------------------- - reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >> - - ghcExit 0 - } } - where - ------------------------------------------------------------- - -- ****** help functions: - - show_pass - = if opt_D_show_passes - then \ what -> hPutStr stderr ("*** "++what++":\n") - else \ what -> return () --- END old stuff -#endif \end{code} @@ -413,146 +359,3 @@ initRules = foldl add emptyVarEnv builtinRules 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" - - if_hdl <- openFile filename WriteMode - printForIface if_hdl (pprIface final_iface) - hClose if_hdl - } - where - full_new_iface = completeIface new_iface local_tycons local_classes - inst_info final_ids tidy_binds - tidy_orphan_rules - isNothing = not . isJust -\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 - - 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"), ppr (moduleName 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} -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} - - diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 9a97728..9550ac6 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -293,16 +293,19 @@ initialVersionInfo = VersionInfo { vers_module = initialVersion, vers_decls = emptyNameEnv } data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome (NameEnv DeprecTxt) -- Some things deprecated - -- Just "big" names + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated + -- Just "big" names + -- We keep the Name in the range, so we can print them out lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt lookupDeprec iface name = case mi_deprecs iface of NoDeprecs -> Nothing DeprecAll txt -> Just txt - DeprecSome env -> lookupNameEnv env name + DeprecSome env -> case lookupNameEnv env name of + Just (_, txt) -> Just txt + Nothing -> Nothing type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 14abda7..1172df3 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -21,8 +21,9 @@ import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) import TcHsSyn ( TypecheckedRuleDecl ) import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..), TyThing(..), DFunId, TypeEnv, isTyClThing, Avails, - WhatsImported(..), GenAvailInfo(..), RdrAvailInfo, - ImportVersion + WhatsImported(..), GenAvailInfo(..), + ImportVersion, AvailInfo, Deprecations(..), + Finder, ModuleLocation(..) ) import CmdLineOpts @@ -602,14 +603,24 @@ diffDecls old_vers old_fixities new_fixities old new %************************************************************************ \begin{code} ---writeIface :: Finder -> ModIface -> IO () -writeIface {-finder-} mod_iface - = do { let filename = error "... find the right file..." +writeIface :: Finder -> Maybe ModIface -> IO () +writeIface finder Nothing + = return () + +writeIface finder (Just mod_iface) + = do { maybe_found <- finder mod_name ; + ; case maybe_found of { + Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ; + Just (_, locn) -> + + do { let filename = hi_file locn ; if_hdl <- openFile filename WriteMode ; printForIface if_hdl (pprIface mod_iface) ; hClose if_hdl - } - + }}} + where + mod_name = moduleName (mi_module mod_iface) + pprIface iface = vcat [ ptext SLIT("__interface") <+> doubleQuotes (ptext opt_InPackage) @@ -619,7 +630,7 @@ pprIface iface <+> int opt_HiVersion <+> ptext SLIT("where") - , pprExport (mi_exports iface) + , vcat (map pprExport (mi_exports iface)) , vcat (map pprUsage (mi_usages iface)) , pprIfaceDecls (vers_decls version_info) @@ -647,24 +658,27 @@ pprExport :: (ModuleName, Avails) -> SDoc pprExport (mod, items) = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi where - pp_avail :: RdrAvailInfo -> SDoc - pp_avail (Avail name) = pprOccName name + ppr_name :: Name -> SDoc -- Print the occurrence name only + ppr_name n = ppr (nameOccName n) + + pp_avail :: AvailInfo -> SDoc + pp_avail (Avail name) = ppr_name name pp_avail (AvailTC name []) = empty - pp_avail (AvailTC name ns) = hcat [pprOccName name, bang, pp_export ns'] + pp_avail (AvailTC name ns) = hcat [ppr_name name, bang, pp_export ns'] where bang | name `elem` ns = empty | otherwise = char '|' ns' = filter (/= name) ns pp_export [] = empty - pp_export names = braces (hsep (map pprOccName names)) + pp_export names = braces (hsep (map ppr_name names)) \end{code} \begin{code} pprUsage :: ImportVersion Name -> SDoc pprUsage (m, has_orphans, is_boot, whats_imported) - = hsep [ptext SLIT("import"), ppr (moduleName m), + = hsep [ptext SLIT("import"), ppr m, pp_orphan, pp_boot, pp_versions whats_imported ] <> semi @@ -701,20 +715,24 @@ pprIfaceDecls version_map fixity_map decls Just v -> int v -- Print fixities relevant to the decl - ppr_fixes d = vcat (map ppr_fix d) - ppr_fix d = [ ppr fix <+> ppr n <> semi - | n <- tyClDeclNames d, - [Just fix] <- lookupNameEnv fixity_map n - ] + ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi + | (n,_) <- tyClDeclNames d, + Just fix <- [lookupNameEnv fixity_map n] + ] \end{code} \begin{code} pprRules [] = empty pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (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 ] +pprDeprecs NoDeprecs = empty +pprDeprecs deprecs = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}") + where + guts = case deprecs of + DeprecAll txt -> ptext txt + DeprecSome env -> pp_deprecs env + +pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) + where + pp_deprec (name, txt) = pprOccName (nameOccName name) <+> ptext txt \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index f246a55..59039e99 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -339,7 +339,7 @@ rnDeprecs gbl_env Nothing decls = pushSrcLocRn loc $ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name -> case maybe_name of - Just n -> returnRn (Just (n,txt)) + Just n -> returnRn (Just (n,(n,txt))) Nothing -> returnRn Nothing \end{code} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 9b01c3e..fb26ab7 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -407,7 +407,7 @@ loadDeprecs m (Just (Right prs)) = setModuleRn m $ loadDeprec deprec_env (n, txt) = lookupOrigName n `thenRn` \ name -> traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env name txt) + returnRn (extendNameEnv deprec_env name (name,txt)) \end{code} @@ -493,7 +493,7 @@ findAndReadIface doc_str mod_name hi_boot_file case maybe_found of Right (Just (mod,locn)) - | hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot") + | hi_boot_file -> readIface mod (hi_file locn ++ "-boot") | otherwise -> readIface mod (hi_file locn) -- Can't find it