Commit 5f67848a authored by simonpj's avatar simonpj

[project @ 2000-10-31 12:07:43 by simonpj]

Improve MkIface; get ready for NameEnv.lhs
parent bad73fe5
......@@ -29,7 +29,7 @@ module Name (
-- Environment
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv,
extendNameEnv_C, extendNameEnv, foldNameEnv,
plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv,
......@@ -49,8 +49,8 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
import Maybes ( expectJust )
import FastTypes
import Maybes ( expectJust )
import UniqFM
import Outputable
\end{code}
......@@ -430,8 +430,10 @@ unitNameEnv :: Name -> a -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b
foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
extendNameEnv_C = addToUFM_C
......
......@@ -38,7 +38,6 @@ import Id ( Id, idName )
import Module ( Module )
import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
import Class ( Class, classTyCon )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn )
......@@ -55,12 +54,12 @@ codeGen :: DynFlags
[CostCentre], -- "extern" cost-centres needing declaring
[CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
-> [Id] -- foreign-exported binders
-> [TyCon] -> [Class] -- Local tycons and classes
-> [TyCon] -- Local tycons, including ones from classes
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
codeGen dflags mod_name imported_modules cost_centre_info fe_binders
tycons classes stg_binds
tycons stg_binds
= mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
let
datatype_stuff = genStaticConBits cinfo data_tycons
......@@ -82,9 +81,7 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
return flat_abstractC
where
data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
-- Generate info tables for the data constrs arising
-- from class decls as well
data_tycons = filter isDataTyCon tycons
maybe_split = if opt_EnsureSplittableC
then CSplitMarker
......
......@@ -38,7 +38,8 @@ import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import Util ( zipWithEqual )
import Name ( Name, lookupNameEnv )
import Name ( Name )
import Name ( lookupNameEnv )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
TyThing(..), TypeEnv, lookupType )
import CmdLineOpts ( DynFlags )
......
......@@ -47,16 +47,15 @@ import IO ( IOMode(..), hClose, openFile, Handle )
\begin{code}
codeOutput :: DynFlags
-> Module
-> [TyCon] -> [Class] -- Local tycons and classes
-> [TyCon] -- Local tycons
-> [CoreBind] -- Core bindings
-> [(StgBinding,[Id])] -- The STG program with SRTs
-> SDoc -- C stubs for foreign exported functions
-> SDoc -- Header file prototype for foreign exported functions
-> AbstractC -- Compiled abstract C
-> UniqSupply
-> IO (Maybe FilePath, Maybe FilePath)
codeOutput dflags mod_name tycons classes core_binds stg_binds
c_code h_code flat_abstractC ncg_uniqs
codeOutput dflags mod_name tycons core_binds stg_binds
c_code h_code flat_abstractC
= -- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
-- flat_abstractC. WDP 94/10]
......@@ -67,7 +66,7 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds
stub_names <- outputForeignStubs dflags c_code h_code
case dopt_HscLang dflags of
HscInterpreted -> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC ncg_uniqs
HscAsm -> outputAsm dflags filenm flat_abstractC
>> return stub_names
HscC -> outputC dflags filenm flat_abstractC
>> return stub_names
......@@ -104,15 +103,18 @@ outputC dflags filenm flat_absC
%************************************************************************
\begin{code}
outputAsm dflags filenm flat_absC ncg_uniqs
outputAsm dflags filenm flat_absC
#ifndef OMIT_NATIVE_CODEGEN
= do dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
= do ncg_uniqs <- mkSplitUniqSupply 'n'
let
(stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
in
dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
doOutput filenm ( \f -> printForAsm f ncg_output_d)
where
(stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
#else /* OMIT_NATIVE_CODEGEN */
......
......@@ -57,7 +57,8 @@ import InterpSyn ( UnlinkedIBind )
import StgInterp ( ItblEnv )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, emptyNameEnv, nameOccName, getName )
import Name ( Name, nameModule, nameOccName, getName )
import Name ( emptyNameEnv )
import Module ( Module, lookupModuleEnvByName )
\end{code}
......@@ -258,22 +259,22 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
= do (ibinds,itbl_env)
<- stgToInterpSyn (map fst stg_binds) local_tycons local_classes
return (Nothing, Nothing, Just (ibinds,itbl_env))
| otherwise
= do -------------------------- Code generation -------------------------------
show_pass dflags "CodeGen"
-- _scc_ "CodeGen"
abstractC <- codeGen dflags this_mod imported_modules
cost_centre_info fe_binders
local_tycons local_classes stg_binds
local_tycons stg_binds
-------------------------- Code output -------------------------------
show_pass dflags "CodeOutput"
-- _scc_ "CodeOutput"
ncg_uniqs <- mkSplitUniqSupply 'n'
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput dflags this_mod local_tycons local_classes
<- codeOutput dflags this_mod local_tycons
oa_tidy_binds stg_binds
c_code h_code abstractC ncg_uniqs
c_code h_code abstractC
return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
where
......
......@@ -45,11 +45,9 @@ module HscTypes (
#include "HsVersions.h"
import RdrName ( RdrNameEnv, emptyRdrEnv )
import Name ( Name, NameEnv, NamedThing,
emptyNameEnv, extendNameEnv,
lookupNameEnv, emptyNameEnv, nameEnvElts,
isLocallyDefined, getName, nameModule,
nameSrcLoc )
import Name ( Name, NamedThing, isLocallyDefined,
getName, nameModule, nameSrcLoc )
import Name -- Env
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
......
......@@ -42,10 +42,9 @@ import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
import Name ( isLocallyDefined, getName,
Name, NamedThing(..),
plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
extendNameEnv, lookupNameEnv_NF, nameEnvElts
Name, NamedThing(..)
)
import Name -- Env
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
......@@ -84,6 +83,14 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
-- a) keeping the types and classes
-- b) removing all Ids, and Ids with correct IdInfo
-- gotten from the bindings
-- From (b) we keep only those Ids with Global names, plus Ids
-- accessible from them (notably via unfoldings)
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
--
-- However, we do keep things like constructors, which should not appear
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
`plusNameEnv`
mkNameEnv [(idName id, AnId id) | id <- final_ids]
......@@ -136,7 +143,7 @@ completeIface maybe_old_iface new_iface mod_details
dcl_rules = rule_dcls }
inst_dcls = map ifaceInstance (md_insts mod_details)
ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
rule_dcls = map ifaceRule (md_rules mod_details)
\end{code}
......@@ -148,19 +155,21 @@ completeIface maybe_old_iface new_iface mod_details
%************************************************************************
\begin{code}
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
= ClassDecl (toHsContext sc_theta)
(getName clas)
(toHsTyVars clas_tyvars)
(toHsFDs clas_fds)
(map toClassOpSig op_stuff)
EmptyMonoBinds
[] noSrcLoc
ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
ifaceTyCls (AClass clas) so_far
= cls_decl : so_far
where
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
cls_decl = ClassDecl (toHsContext sc_theta)
(getName clas)
(toHsTyVars clas_tyvars)
(toHsFDs clas_fds)
(map toClassOpSig op_stuff)
EmptyMonoBinds
[] noSrcLoc
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
toClassOpSig (sel_id, def_meth)
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
where
......@@ -170,22 +179,26 @@ ifaceTyCls (AClass clas)
GenDefMeth -> GenDefMeth
DefMeth id -> DefMeth (getName id)
ifaceTyCls (ATyCon tycon)
| isSynTyCon tycon
= TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
where
(tyvars, ty) = getSynTyConDefn tycon
ifaceTyCls (ATyCon tycon)
| isAlgTyCon tycon
= TyData new_or_data (toHsContext (tyConTheta tycon))
(getName tycon)
(toHsTyVars tyvars)
(map ifaceConDecl (tyConDataCons tycon))
(tyConFamilySize tycon)
Nothing noSrcLoc (panic "gen1") (panic "gen2")
ifaceTyCls (ATyCon tycon) so_far
= ty_decl : so_far
where
tyvars = tyConTyVars tycon
ty_decl | isSynTyCon tycon
= TySynonym (getName tycon)(toHsTyVars tyvars)
(toHsType syn_ty) noSrcLoc
| isAlgTyCon tycon
= TyData new_or_data (toHsContext (tyConTheta tycon))
(getName tycon)
(toHsTyVars tyvars)
(map ifaceConDecl (tyConDataCons tycon))
(tyConFamilySize tycon)
Nothing noSrcLoc (panic "gen1") (panic "gen2")
| otherwise = pprPanic "ifaceTyCls" (ppr tycon)
tyvars = tyConTyVars tycon
(_, syn_ty) = getSynTyConDefn tycon
new_or_data | isNewTyCon tycon = NewType
| otherwise = DataType
......@@ -212,11 +225,12 @@ ifaceTyCls (ATyCon tycon)
mk_field strict_mark field_label
= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
ifaceTyCls (AnId id)
= IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
ifaceTyCls (AnId id) so_far
| omitIfaceSigForId id = so_far
| otherwise = iface_sig : so_far
where
iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
id_type = idType id
id_info = idInfo id
......@@ -326,17 +340,11 @@ bindsToIds needed_ids codegen_ids binds
| otherwise = emitted
go needed (NonRec id rhs : binds) emitted
| need_id needed id
= if omitIfaceSigForId id then
go (needed `delVarSet` id) binds (id:emitted)
else
go ((needed `unionVarSet` extras) `delVarSet` id)
binds
(new_id:emitted)
| otherwise
= go needed binds emitted
| need_id needed id = go new_needed binds (new_id:emitted)
| otherwise = go needed binds emitted
where
(new_id, extras) = mkFinalId codegen_ids False id rhs
new_needed = (needed `unionVarSet` extras) `delVarSet` id
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
......@@ -369,12 +377,15 @@ bindsToIds needed_ids codegen_ids binds
\begin{code}
mkFinalId :: IdSet -- The Ids with arity info from the code generator
-> Bool -- True <=> recursive, so don't include unfolding
-> Bool -- True <=> recursive, so don't include unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
-> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
mkFinalId codegen_ids is_rec id rhs
| omitIfaceSigForId id
= (id, emptyVarSet) -- An optimisation for top-level constructors and suchlike
| otherwise
= (id `setIdInfo` new_idinfo, new_needed_ids)
where
core_idinfo = idInfo id
......
......@@ -39,8 +39,8 @@ import Module ( Module, ModuleName, WhereFrom(..),
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom,
nameOccName, nameModule,
mkNameEnv, nameEnvElts, extendNameEnv
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
import RdrName ( elemRdrEnv )
import OccName ( occNameFlavour )
import NameSet
......
......@@ -22,9 +22,9 @@ import Name ( Name, NamedThing(..),
getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
extendNameEnv_C, plusNameEnv_C, nameEnvElts,
setNameModuleAndLoc
)
import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
......
......@@ -42,8 +42,8 @@ import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, nameIsLocalOrFrom,
NamedThing(..),
mkNameEnv, extendNameEnv
)
import Name ( mkNameEnv, extendNameEnv )
import Module ( Module,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
......
......@@ -38,8 +38,8 @@ import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, nameUnique,
NamedThing(..),
elemNameEnv
)
import Name ( elemNameEnv )
import Module ( Module, ModuleEnv,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
......
......@@ -54,10 +54,9 @@ import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
nameOccName,
decode, mkLocalName, mkKnownKeyGlobal,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
decode, mkLocalName, mkKnownKeyGlobal
)
import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
import Module ( Module, ModuleName, ModuleSet, emptyModuleSet )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
......
......@@ -43,9 +43,8 @@ import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..), isFrom,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
plusNameEnv, nameEnvElts )
import Name ( Name, NamedThing(..), isFrom )
import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
......
......@@ -60,10 +60,9 @@ import Class ( Class, ClassOpItem, ClassContext )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
isLocalName, nameModule_maybe,
NameEnv, lookupNameEnv, nameEnvElts,
extendNameEnvList, emptyNameEnv
isLocalName, nameModule_maybe
)
import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
import Module ( Module )
......
......@@ -43,9 +43,8 @@ import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idUnfolding )
import Module ( Module )
import Name ( Name, isLocallyDefined,
toRdrName, nameEnvElts, lookupNameEnv,
)
import Name ( Name, isLocallyDefined, toRdrName )
import Name ( nameEnvElts, lookupNameEnv )
import TyCon ( tyConGenInfo )
import Maybes ( thenMaybe )
import Util
......
......@@ -39,9 +39,8 @@ import DataCon ( isNullaryDataCon )
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, NamedThing(..), NameEnv, getSrcLoc,
mkNameEnv, lookupNameEnv_NF, isTyVarName
)
import Name ( Name, NamedThing(..), getSrcLoc, isTyVarName )
import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF )
import NameSet
import Outputable
import Maybes ( mapMaybe )
......
......@@ -36,7 +36,7 @@ import Class ( Class )
-- others:
import Maybes ( maybeToBool )
import Name ( getOccString )
import Name ( getOccString, getOccName )
import Outputable
import PprEnv
import Unique ( Uniquable(..) )
......@@ -121,11 +121,10 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
-- type constructor (must be Boxed, Unboxed, AnyBox)
-- Otherwise print as (Type x)
case ty1 of
TyConApp bx [] -> ppr bx
TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified
other -> maybeParen ctxt_prec tYCON_PREC
(sep [ppr tycon, nest 4 tys_w_spaces])
-- TUPLE CASE (boxed and unboxed)
| isTupleTyCon tycon
&& length tys == tyConArity tycon -- no magic if partially applied
......
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