Commit 83eef621 authored by simonpj's avatar simonpj

[project @ 2000-11-24 17:02:01 by simonpj]

1. Make the new version machinery work.
   I think it does now!

2. Consequence of (1): Move the generation of
   default method names to one place (namely
   in RdrHsSyn.mkClassOpSigDM

3. Major clean up on HsDecls.TyClDecl
   These big constructors should have been records
   ages ago, and they are now.  At last.
parent 4166dff8
......@@ -26,9 +26,9 @@ module Id (
externallyVisibleId,
isIP,
isSpecPragmaId, isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
isDataConId, isDataConId_maybe, isDataConWrapId,
isDataConWrapId_maybe,
isPrimOpId, isPrimOpId_maybe, isDictFunId,
isDataConId, isDataConId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
isExportedId, isLocalId,
hasNoBinding,
......@@ -244,6 +244,10 @@ hasNoBinding id = case idFlavour id of
-- binding, even though it is defined in this module. Notably,
-- the constructors of a dictionary are in this situation.
isDictFunId id = case idFlavour id of
DictFunId -> True
other -> False
-- Don't drop a binding for an exported Id,
-- if it otherwise looks dead.
-- Perhaps a better name would be isDiscardableId
......@@ -295,7 +299,12 @@ omitIfaceSigForId' id
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
other -> False -- Don't omit!
ConstantId -> False -- Ordinary Ids
DictFunId -> False
ExportedId -> False -- I don't think these happen
VanillaId -> False -- ditto
SpecPragmaId -> False -- ditto
\end{code}
\begin{code}
......
......@@ -244,8 +244,11 @@ data IdFlavour
| ExportedId -- Locally defined, exported
| SpecPragmaId -- Locally defined, RHS holds specialised call
| ConstantId -- Imported from elsewhere, or a dictionary function,
-- default method Id.
| ConstantId -- Imported from elsewhere, or a default method Id.
| DictFunId -- We flag dictionary functions so that we can
-- conveniently extract the DictFuns from a set of
-- bindings when building a module's interface
| DataConId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
......@@ -262,6 +265,7 @@ ppFlavourInfo VanillaId = empty
ppFlavourInfo ExportedId = ptext SLIT("[Exported]")
ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
ppFlavourInfo ConstantId = ptext SLIT("[Constant]")
ppFlavourInfo DictFunId = ptext SLIT("[DictFun]")
ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]")
ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]")
......
......@@ -632,7 +632,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
= mkId dfun_name dfun_ty info
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
info = constantIdInfo `setTyGenInfo` TyGenNever
info = mkIdInfo DictFunId `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
......
......@@ -44,7 +44,7 @@ module Name (
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
import FastTypes
......
......@@ -326,17 +326,9 @@ mkSuperDictSelOcc index cls_occ
\begin{code}
mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe"
-> Int -- Unique to distinguish dfuns which share the previous two
-- eg 3
-- The requirement is that the (string,index) pair be unique in this module
-> OccName -- "$fOrdMaybe"
-> OccName -- "$fOrdMaybe3"
mkDFunOcc string index
= mk_deriv VarName "$f" (show_index ++ string)
where
show_index | index == 0 = ""
| otherwise = show index
mkDFunOcc string = mk_deriv VarName "$f" string
\end{code}
We used to add a '$m' to indicate a method, but that gives rise to bad
......
......@@ -20,7 +20,7 @@ import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
mkVanillaId, mkId, isLocalId,
mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
setIdStrictness, setIdDemandInfo,
)
import IdInfo ( constantIdInfo,
......@@ -293,7 +293,11 @@ tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs
tidyTopBinder :: Module -> IdEnv Bool
-> TopTidyEnv -> CoreExpr
-> TopTidyEnv -> Id -> (TopTidyEnv, Id)
tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id
tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
| omitIfaceSigForId id -- Don't mess with constructors,
= (env, id) -- record selectors, and the like
| otherwise
-- This function is the heart of Step 2
-- The second env is the one to use for the IdInfo
-- It's necessary because when we are dealing with a recursive
......@@ -321,7 +325,6 @@ tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id
| otherwise = noUnfolding
tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't
= constantIdInfo
......
#! /usr/local/bin/perl
#! /usr/bin/perl
#
%DirCount = ();
%ModCount = ();
......@@ -8,7 +8,7 @@
foreach $f ( @ARGV ) {
if ( $f =~ /\.lhs$/ ) {
open(INF, "unlit $f - |") || die "Couldn't unlit $f!\n";
open(INF, "/home/simonpj/builds/slpj/ghc/utils/unlit/unlit $f - |") || die "Couldn't unlit $f!\n";
} else {
open(INF, "< $f") || die "Couldn't open $f!\n";
}
......
......@@ -240,9 +240,12 @@ data Sig name
(HsType name)
SrcLoc
| ClassOpSig name -- Selector name
(Maybe (DefMeth name)) -- Nothing for source-file class signatures
-- Gives DefMeth info for interface files sigs
| ClassOpSig name -- Selector name
(DefMeth name) -- (Just dm_name) for source-file class signatures
-- The name may not be used, if there isn't a
-- generic default method, but it's there if we
-- need it
-- Gives DefMeth info for interface files sigs
(HsType name)
SrcLoc
......@@ -340,15 +343,9 @@ ppr_sig (ClassOpSig var dm ty _)
= sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
where
pp_dm = case dm of
Just (DefMeth _) -> equals -- Default method indicator
Just GenDefMeth -> semi -- Generic method indicator
Just NoDefMeth -> empty -- No Method at all
-- Not convinced this is right...
-- Not used in interface file output hopefully
-- but needed for ddump-rn ??
other -> dot
-- empty -- No method at all
DefMeth _ -> equals -- Default method indicator
GenDefMeth -> semi -- Generic method indicator
NoDefMeth -> empty -- No Method at all
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
......
......@@ -160,38 +160,43 @@ Plan of attack:
\begin{code}
data TyClDecl name pat
= IfaceSig name -- It may seem odd to classify an interface-file signature
(HsType name) -- as a 'TyClDecl', but it's very convenient. These three
[HsIdInfo name] -- are the kind that appear in interface files.
SrcLoc
| TyData NewOrData
(HsContext name) -- context
name -- type constructor
[HsTyVarBndr name] -- type variables
[ConDecl name] -- data constructors (empty if abstract)
Int -- Number of data constructors (valid even if type is abstract)
(Maybe [name]) -- derivings; Nothing => not specified
= IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three
tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files.
tcdLoc :: SrcLoc
}
| TyData { tcdND :: NewOrData,
tcdCtxt :: HsContext name, -- context
tcdName :: name, -- type constructor
tcdTyVars :: [HsTyVarBndr name], -- type variables
tcdCons :: [ConDecl name], -- data constructors (empty if abstract)
tcdNCons :: Int, -- Number of data constructors (valid even if type is abstract)
tcdDerivs :: Maybe [name], -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
-- expect...
SrcLoc
name -- generic converter functions
name -- generic converter functions
| TySynonym name -- type constructor
[HsTyVarBndr name] -- type variables
(HsType name) -- synonym expansion
SrcLoc
| ClassDecl (HsContext name) -- context...
name -- name of the class
[HsTyVarBndr name] -- the class type variables
[FunDep name] -- functional dependencies
[Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
(ClassDeclSysNames name)
SrcLoc
tcdSysNames :: DataSysNames name, -- Generic converter functions
tcdLoc :: SrcLoc
}
| TySynonym { tcdName :: name, -- type constructor
tcdTyVars :: [HsTyVarBndr name], -- type variables
tcdSynRhs :: HsType name, -- synonym expansion
tcdLoc :: SrcLoc
}
| ClassDecl { tcdCtxt :: HsContext name, -- Context...
tcdName :: name, -- Name of the class
tcdTyVars :: [HsTyVarBndr name], -- The class type variables
tcdFDs :: [FunDep name], -- Functional dependencies
tcdSigs :: [Sig name], -- Methods' signatures
tcdMeths :: Maybe (MonoBinds name pat), -- Default methods
-- Nothing for imported class decls
-- Just bs for source class decls
tcdSysNames :: ClassSysNames name,
tcdLoc :: SrcLoc
}
\end{code}
Simple classifiers
......@@ -199,17 +204,17 @@ Simple classifiers
\begin{code}
isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isIfaceSigDecl (IfaceSig _ _ _ _) = True
isIfaceSigDecl other = False
isIfaceSigDecl (IfaceSig {}) = True
isIfaceSigDecl other = False
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isSynDecl (TySynonym {}) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isDataDecl (TyData {}) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
isClassDecl (ClassDecl {}) = True
isClassDecl other = False
\end{code}
Dealing with names
......@@ -217,11 +222,7 @@ Dealing with names
\begin{code}
--------------------------------
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
tyClDeclName tycl_decl = tcdName tycl_decl
--------------------------------
tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
......@@ -230,33 +231,43 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
tyClDeclNames (TySynonym name _ _ loc)
= [(name,loc)]
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl _ cls_name _ _ sigs _ _ loc)
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
= (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _)
tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
= (tc_name,loc) : conDeclsNames cons
tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)]
--------------------------------
-- The "system names" are extra implicit names.
-- They are kept in a list rather than a tuple
-- to make the renamer easier.
type ClassSysNames name = [name]
-- For class decls they are:
-- [tycon, datacon wrapper, datacon worker,
-- superclass selector 1, ..., superclass selector n]
type DataSysNames name = [name]
-- For data decls they are
-- [from, to]
-- where from :: T -> Tring
-- to :: Tring -> T
tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
-- Similar to tyClDeclNames, but returns the "implicit"
-- or "system" names of the declaration
tyClDeclSysNames (ClassDecl _ _ _ _ _ _ names loc) = [(n,loc) | n <- names]
tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _) = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
tyClDeclSysNames decl = []
tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc})
= [(n,loc) | n <- names]
tyClDeclSysNames (TyData {tcdCons = cons, tcdSysNames = names, tcdLoc = loc})
= [(n,loc) | n <- names] ++
[(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
tyClDeclSysNames decl = []
--------------------------------
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
-- superclass selector 1, ..., superclass selector n]
-- They are kept in a list rather than a tuple to make the
-- renamer easier.
mkClassDeclSysNames :: (name, name, name, [name]) -> [name]
getClassDeclSysNames :: [name] -> (name, name, name, [name])
......@@ -267,30 +278,31 @@ getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\begin{code}
instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
-- Used only when building interface files
(==) (IfaceSig n1 t1 i1 _)
(IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
(==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
(TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
= n1 == n2 &&
nd1 == nd2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
eq_hsContext env cxt1 cxt2 &&
eqListBy (eq_ConDecl env) cons1 cons2
)
(==) (TySynonym n1 tvs1 ty1 _)
(TySynonym n2 tvs2 ty2 _)
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
(==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ )
(ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ )
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
eq_hsContext env cxt1 cxt2 &&
eqListBy (eq_hsFD env) fds1 fds2 &&
eqListBy (eq_cls_sig env) sigs1 sigs2
(==) d1@(IfaceSig {}) d2@(IfaceSig {})
= tcdName d1 == tcdName d2 &&
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
(==) d1@(TyData {}) d2@(TyData {})
= tcdName d1 == tcdName d2 &&
tcdND d1 == tcdND d2 &&
eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) &&
eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2)
)
(==) d1@(TySynonym {}) d2@(TySynonym {})
= tcdName d1 == tcdName d2 &&
eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2)
)
(==) d1@(ClassDecl {}) d2@(ClassDecl {})
= tcdName d1 == tcdName d2 &&
eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) &&
eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) &&
eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2)
)
(==) _ _ = False -- default case
......@@ -305,11 +317,10 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
-- This is used for comparing declarations before putting
-- them into interface files, and the name of the default
-- method isn't relevant
Nothing `eq_dm` Nothing = True
(Just NoDefMeth) `eq_dm` (Just NoDefMeth) = True
(Just GenDefMeth) `eq_dm` (Just GenDefMeth) = True
(Just (DefMeth _)) `eq_dm` (Just (DefMeth _)) = True
dm1 `eq_dm` dm2 = False
NoDefMeth `eq_dm` NoDefMeth = True
GenDefMeth `eq_dm` GenDefMeth = True
DefMeth _ `eq_dm` DefMeth _ = True
dm1 `eq_dm` dm2 = False
\end{code}
......@@ -318,27 +329,28 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
= (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls],
length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls],
length [() | IfaceSig _ _ _ _ <- decls])
= (length [() | ClassDecl {} <- decls],
length [() | TySynonym {} <- decls],
length [() | IfaceSig {} <- decls],
length [() | TyData {tcdND = DataType} <- decls],
length [() | TyData {tcdND = NewType} <- decls])
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
=> Outputable (TyClDecl name pat) where
ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
= hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ppr (TySynonym tycon tyvars mono_ty src_loc)
ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
ppr (TyData new_or_data context tycon tyvars condecls ncons
derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
= pp_tydecl
(ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
tcdDerivs = derivings})
= pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
(pp_condecls condecls ncons)
derivings
where
......@@ -346,7 +358,8 @@ instance (NamedThing name, Outputable name, Outputable pat)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc)
ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods})
| null sigs -- No "where" part
= top_matter
......
......@@ -16,6 +16,9 @@ module HscMain ( HscResult(..), hscMain,
import RdrHsSyn ( RdrNameHsExpr )
import CoreToStg ( coreToStgExpr )
import StringBuffer ( stringToStringBuffer, freeStringBuffer )
import Unique ( Uniquable(..) )
import Type ( splitTyConApp_maybe )
import PrelNames ( ioTyConKey )
#endif
import HsSyn
......@@ -32,7 +35,6 @@ import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
writeIface, pprIface )
import TcModule
import Type
import TcHsSyn
import InstEnv ( emptyInstEnv )
import Desugar
import SimplCore
......@@ -48,8 +50,6 @@ import Module ( ModuleName, moduleName, mkHomeModule )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
import Unique ( Uniquable(..) )
import PrelNames ( ioTyConKey )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
......@@ -62,7 +62,6 @@ import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
import Type ( splitTyConApp_maybe )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
......@@ -160,11 +159,10 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
Just (pcs_tc, tc_result) -> do {
let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
-- create a new details from the closed, typechecked, old iface
let new_details = mkModDetailsFromIface env_tc local_insts local_rules
let new_details = mkModDetailsFromIface env_tc local_rules
;
return (HscNoRecomp pcs_tc new_details old_iface)
}}}}
......@@ -206,8 +204,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
Nothing -> return (HscFail pcs_rn);
Just (pcs_tc, tc_result) -> do {
; let env_tc = tc_env tc_result
local_insts = tc_insts tc_result
; let env_tc = tc_env tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
......@@ -227,7 +224,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
; let new_details = mkModDetails env_tc local_insts tidy_binds
; let new_details = mkModDetails env_tc tidy_binds
top_level_ids orphan_rules
; final_iface <- mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface new_details
......@@ -359,16 +356,16 @@ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
myCoreToStg dflags this_mod tidy_binds
= do
() <- coreBindsSize occ_anal_tidy_binds `seq` return ()
() <- coreBindsSize tidy_binds `seq` return ()
-- TEMP: the above call zaps some space usage allocated by the
-- simplifier, which for reasons I don't understand, persists
-- thoroughout code generation
-- _scc_ "Core2Stg"
stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds
stg_binds <- topCoreBindsToStg dflags this_mod tidy_binds
-- _scc_ "Stg2Stg"
(stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
(stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
let final_ids = collectFinalStgBinders (map fst stg_binds2)
return (stg_binds2, cost_centre_info, final_ids)
......
......@@ -104,6 +104,9 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
count_monobinds (PatMonoBind p r _) = (0,1)
count_monobinds (FunMonoBind f _ m _) = (0,1)
count_mb_monobinds (Just mbs) = count_monobinds mbs
count_mb_monobinds Nothing = (0,0)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
sig_info (Sig _ _ _) = (1,0,0,0)
......@@ -123,14 +126,14 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _)
data_info (TyData {tcdNCons = nconstrs, tcdDerivs = derivs})
= (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ )
= case count_sigs meth_sigs of
class_info decl@(ClassDecl {})
= case count_sigs (tcdSigs decl) of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
(classops, addpr (count_mb_monobinds (tcdMeths decl)))
class_info other = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs _ _)
......
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.33 2000/11/24 09:51:39 simonpj Exp $
-- $Id: Main.hs,v 1.34 2000/11/24 17:02:02 simonpj Exp $
--
-- GHC Driver program
--
......@@ -19,7 +19,11 @@ module Main (main) where
#ifdef GHCI
import Interpreter
import InteractiveUI
#endif
#ifndef mingw32_TARGET_OS
import Dynamic
import Posix
#endif
import CompManager
......@@ -40,9 +44,6 @@ import Util
import Concurrent
#ifndef mingw32_TARGET_OS
import Posix
#endif
import Directory
import IOExts
import Exception
......
......@@ -22,15 +22,15 @@ import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import TcHsSyn ( TypecheckedRuleDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
TyThing(..), DFunId, TypeEnv, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
extendTypeEnvList
)
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId,
idSpecialisation, setIdInfo, isLocalId
import Id ( Id, idType, idInfo, omitIfaceSigForId, isDictFunId,
idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
)
import Var ( isId )
import VarSet
......@@ -40,7 +40,7 @@ import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule,
isBuiltinRule, rulesRules,
bindersOf, bindersOfBinds
)
import CoreFVs ( ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreFVs ( ruleSomeLhsFreeVars )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
import Name ( getName, nameModule, Name, NamedThing(..) )
import Name -- Env
......@@ -66,38 +66,44 @@ import IO ( IOMode(..), openFile, hClose )
%************************************************************************
\begin{code}
mkModDetails :: TypeEnv -> [DFunId] -- From typechecker
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
-> [IdCoreRule] -- Tidy orphan rules
mkModDetails :: TypeEnv -- From typechecker
-> [CoreBind] -- Final bindings
-> [Id] -- Top-level Ids from the code generator;
-- they have authoritative arity info
-> [IdCoreRule] -- Tidy orphan rules
-> ModDetails
mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
mkModDetails type_env tidy_binds stg_ids orphan_rules
= ModDetails { md_types = new_type_env,
md_rules = rule_dcls,
md_insts = dfun_ids }
md_insts = filter isDictFunId final_ids }
where
-- The competed type environment is gotten from
-- a) keeping the types and classes