-- Environment
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
- extendNameEnv_C, extendNameEnv,
+ extendNameEnv_C, extendNameEnv, foldNameEnv,
plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv,
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}
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
import Module ( Module )
import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
-import Class ( Class, classTyCon )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn )
[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
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
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 )
\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]
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
%************************************************************************
\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 */
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}
= 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
#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,
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
-- 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]
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}
%************************************************************************
\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
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
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
| 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
\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
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom,
nameOccName, nameModule,
- mkNameEnv, nameEnvElts, extendNameEnv
)
+import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
import RdrName ( elemRdrEnv )
import OccName ( occNameFlavour )
import NameSet
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 )
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, nameIsLocalOrFrom,
NamedThing(..),
- mkNameEnv, extendNameEnv
)
+import Name ( mkNameEnv, extendNameEnv )
import Module ( Module,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, nameUnique,
NamedThing(..),
- elemNameEnv
)
+import Name ( elemNameEnv )
import Module ( Module, ModuleEnv,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
)
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 )
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,
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 )
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
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 )
-- others:
import Maybes ( maybeToBool )
-import Name ( getOccString )
+import Name ( getOccString, getOccName )
import Outputable
import PprEnv
import Unique ( Uniquable(..) )
-- 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
projects / ghc-hetmet.git / commitdiff