Commit 6e42e208 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-26 07:19:52 by simonpj]

wibbles
parent b9827234
......@@ -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}
......
......@@ -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}
......@@ -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
......
......@@ -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}
......@@ -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}
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment