Commit 01e0566e authored by simonpj's avatar simonpj
Browse files

[project @ 2000-11-07 13:12:21 by simonpj]

More small changes
parent f5448f5c
......@@ -40,7 +40,7 @@ module OccName (
#include "HsVersions.h"
import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
import Char ( isDigit, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
import Util ( thenCmp )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
import Outputable
......
......@@ -16,8 +16,6 @@ module PprEnv (
#include "HsVersions.h"
import {-# SOURCE #-} DataCon ( DataCon )
import Var ( Id, TyVar )
import CostCentre ( CostCentre )
import Type ( Type )
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.46 2000/09/06 12:21:15 simonmar Exp $
% $Id: CgCase.lhs,v 1.47 2000/11/07 13:12:22 simonpj Exp $
%
%********************************************************
%* *
......@@ -33,7 +33,7 @@ import CgBindery ( getVolatileRegs, getArgAmodes,
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import CgHeapery ( altHeapCheck, yield )
import CgHeapery ( altHeapCheck )
import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
......@@ -41,13 +41,12 @@ import CgStackery ( allocPrimStack, allocStackTop,
deAllocStackTop, freeStackSlots, dataStackSlots
)
import CgTailCall ( tailCallFun )
import CgUsages ( getSpRelOffset, getRealSp )
import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
mkErrorStdEntryLabel, mkClosureTblLabel
import CgUsages ( getSpRelOffset )
import CLabel ( mkVecTblLabel, mkClosureTblLabel,
mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
)
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CmdLineOpts ( opt_SccProfilingOn )
import Id ( Id, idPrimRep, isDeadBinder )
import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
isUnboxedTupleCon )
......@@ -57,7 +56,7 @@ import PrimOp ( primOpOutOfLine, PrimOp(..) )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
isFunTyCon, isPrimTyCon,
)
import Type ( Type, typePrimRep, splitAlgTyConApp,
splitTyConApp_maybe, repType )
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.36 2000/10/03 08:43:00 simonpj Exp $
% $Id: CgExpr.lhs,v 1.37 2000/11/07 13:12:22 simonpj Exp $
%
%********************************************************
%* *
......@@ -39,11 +39,9 @@ import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
import Id ( idPrimRep, idType, Id )
import VarSet
import DataCon ( DataCon, dataConTyCon )
import PrimOp ( primOpOutOfLine, ccallMayGC,
getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import DataCon ( dataConTyCon )
import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
import PrimRep ( PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
......
......@@ -56,7 +56,6 @@ import Constants ( sTD_HDR_SIZE, pROF_HDR_SIZE,
sTD_ITBL_SIZE, pROF_ITBL_SIZE,
gRAN_ITBL_SIZE, tICKY_ITBL_SIZE )
import Outputable
import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) )
\end{code}
%************************************************************************
......
......@@ -16,7 +16,7 @@ module HsDecls (
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames
) where
......@@ -36,7 +36,7 @@ import CallConv ( CallConv, pprCallConv )
-- others:
import FunDeps ( pprFundeps )
import Class ( FunDep )
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc )
......@@ -296,13 +296,17 @@ eq_hsFD env (ns1,ms1) (ns2,ms2)
eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
= n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
where
-- Ignore the name of the default method.
-- Ignore the name of the default method for (DefMeth id)
-- This is used for comparing declarations before putting
-- them into interface files, and the name of the default
-- method isn't relevant
(Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2
Nothing `eq_dm` Nothing = True
dm1 `eq_dm` dm2 = False
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
\end{code}
\begin{code}
......@@ -424,7 +428,7 @@ conDeclsNames cons
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
(ConDecl n2 _ tvs2 cxt2 cds2 _)
= n1 == n2 &&
(eqWithHsTyVars tvs1 tvs2 $ \ env ->
(eq_hsTyVars env tvs1 tvs2 $ \ env ->
eq_hsContext env cxt1 cxt2 &&
eq_ConDetails env cds1 cds2)
......@@ -642,6 +646,11 @@ data RuleDecl name pat
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
ifaceRuleDeclName :: RuleDecl name pat -> name
ifaceRuleDeclName (IfaceRule _ _ n _ _ _) = n
ifaceRuleDeclName (IfaceRuleOut n r) = n
ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
data RuleBndr name
= RuleBndr name
| RuleBndrSig name (HsType name)
......
......@@ -17,7 +17,7 @@ module HsTypes (
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
, eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsType, eq_hsContext, eqListBy
, eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsTyVars, eq_hsType, eq_hsContext, eqListBy
-- Converting from Type to HsType
, toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs
......
......@@ -81,11 +81,6 @@ clazz = \mfs -> \n -> \x -> \is -> \ms ->
$$ indent ms
$$ text "}"
staticblock = \ss ->
text "static" <+> text "{"
$$ indent ss
$$ text "}"
modifiers mfs = hsep (map modifier mfs)
modifier mf = text $ map toLower (show mf)
......
......@@ -341,10 +341,6 @@ lookup_def_int sw def = case (lookup_str sw) of
Nothing -> def -- Use default
Just xx -> read xx
lookup_def_char sw def = case (lookup_str sw) of
Just (xx:_) -> xx
_ -> def -- Use default
lookup_def_float sw def = case (lookup_str sw) of
Nothing -> def -- Use default
Just xx -> read xx
......@@ -604,11 +600,6 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
|| sw `is_elem` ss
\end{code}
Default settings for simplifier switches
\begin{code}
defaultSimplSwitches = [MaxSimplifierIterations 1]
\end{code}
%************************************************************************
%* *
......
......@@ -31,7 +31,6 @@ import ErrUtils ( dumpIfSet_dyn )
import Outputable
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import TmpFiles ( newTempName )
import UniqSupply ( mkSplitUniqSupply )
import IO ( IOMode(..), hClose, openFile, Handle )
\end{code}
......
......@@ -13,7 +13,7 @@ module HscTypes (
lookupIface, lookupIfaceByModName,
emptyModIface,
IfaceDecls(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
VersionInfo(..), initialVersionInfo,
......@@ -60,7 +60,7 @@ import TyCon ( TyCon )
import BasicTypes ( Version, initialVersion, Fixity )
import HsSyn ( DeprecTxt )
import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
......@@ -71,7 +71,7 @@ import Bag ( Bag )
import Maybes ( seqMaybe )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp )
import Util ( thenCmp, sortLt )
import UniqSupply ( UniqSupply )
\end{code}
......@@ -144,6 +144,32 @@ data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
dcl_rules :: [RenamedRuleDecl], -- Sorted
dcl_insts :: [RenamedInstDecl] } -- Unsorted
mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls
mkIfaceDecls tycls rules insts
= IfaceDecls { dcl_tycl = sortLt lt_tycl tycls,
dcl_rules = sortLt lt_rule rules,
dcl_insts = insts }
where
d1 `lt_tycl` d2 = nameOccName (tyClDeclName d1) < nameOccName (tyClDeclName d2)
r1 `lt_rule` r2 = nameOccName (ifaceRuleDeclName r1) < nameOccName (ifaceRuleDeclName r2)
-- I wanted to sort just by the Name, but there's a problem: we are comparing
-- the old version of an interface with the new version. The latter will use
-- local names like 'lvl23' that were constructed not by the renamer but by
-- the simplifier. So the unqiues aren't going to line up.
--
-- It's ok to compare by OccName because this comparison only drives the
-- computation of new version numbers.
--
-- Better solutions: Compare in a way that is insensitive to the name used
-- for local things. This would decrease the wobbles due
-- to 'lvl23' changing to 'lvl24'.
--
-- NB: there's a related comparision on MkIface.diffDecls!
-- typechecker should only look at this, not ModIface
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
......
......@@ -20,7 +20,8 @@ import BasicTypes ( Fixity(..), NewOrData(..),
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import TcHsSyn ( TypecheckedRuleDecl )
import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..)
......@@ -136,10 +137,7 @@ completeIface :: Maybe ModIface -- The old interface, if we have it
completeIface maybe_old_iface new_iface mod_details
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
where
new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls,
dcl_insts = inst_dcls,
dcl_rules = rule_dcls }
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance (md_insts mod_details)
ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
rule_dcls = map ifaceRule (md_rules mod_details)
......@@ -585,7 +583,7 @@ diffDecls old_vers old_fixities new_fixities old new
diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
diff ok_so_far pp new_vers (od:ods) (nd:nds)
= case od_name `compare` nd_name of
= case nameOccName od_name `compare` nameOccName nd_name of
LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
......
......@@ -27,7 +27,7 @@ import RnIfaces ( slurpImpDecls, mkImportInfo,
)
import RnHiFiles ( readIface, removeContext,
loadExports, loadFixDecls, loadDeprecs )
import RnEnv ( availName,
import RnEnv ( availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupSrcName, newGlobalName
......@@ -63,7 +63,8 @@ import Outputable
import IO ( openFile, IOMode(..) )
import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IfaceDecls(..),
VersionInfo(..), ImportVersion,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
Deprecations(..), lookupDeprec, lookupIface
......@@ -136,15 +137,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
-- SLURP IN ALL THE NEEDED DECLARATIONS
implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
let
-- The export_fvs make the exported names look just as if they
-- occurred in the source program. For the reasoning, see the
-- comments with RnIfaces.getImportVersions.
-- We only need the 'parent name' of the avail;
-- that's enough to suck in the declaration.
export_fvs = mkNameSet (map availName export_avails)
real_source_fvs = source_fvs `plusFV` export_fvs
slurp_fvs = implicit_fvs `plusFV` real_source_fvs
slurp_fvs = implicit_fvs `plusFV` source_fvs
-- It's important to do the "plus" this way round, so that
-- when compiling the prelude, locally-defined (), Bool, etc
-- override the implicit ones.
......@@ -188,11 +181,19 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
mi_deprecs = my_deprecs,
mi_decls = panic "mi_decls"
}
-- The export_fvs make the exported names look just as if they
-- occurred in the source program.
-- We only need the 'parent name' of the avail;
-- that's enough to suck in the declaration.
export_fvs = availsToNameSet export_avails
used_vars = source_fvs `plusFV` export_fvs
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
reportUnusedNames mod_iface imports global_avail_env
real_source_fvs rn_imp_decls `thenRn_`
used_vars rn_imp_decls `thenRn_`
returnRn (Just (mod_iface, final_decls))
where
......@@ -425,9 +426,7 @@ loadOldIface parsed_iface
vers_rules = rule_vers,
vers_decls = decls_vers }
decls = IfaceDecls { dcl_tycl = new_decls,
dcl_rules = new_rules,
dcl_insts = new_insts }
decls = mkIfaceDecls new_decls new_rules new_insts
mod_iface = ModIface { mi_module = mod, mi_version = version,
mi_exports = avails, mi_usages = usages,
......
......@@ -162,9 +162,9 @@ instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
----------------
ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs
ruleDeclFVs (IfaceRule _ vars _ _ rhs _)
ruleDeclFVs (IfaceRule _ vars _ args rhs _)
= delFVs (map ufBinderName vars) $
ufExprFVs rhs
ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args)
----------------
conDeclFVs (ConDecl _ _ tyvars context details _)
......
......@@ -85,53 +85,14 @@ getInterfaceExports mod_name from
%* *
%*********************************************************
getImportVersions figures out what the ``usage information'' for this
mkImportInof figures out what the ``usage information'' for this
moudule is; that is, what it must record in its interface file as the
things it uses. It records:
\begin{itemize}
\item (a) anything reachable from its body code
\item (b) any module exported with a @module Foo@
\item (c) anything reachable from an exported item
\end{itemize}
Why (b)? Because if @Foo@ changes then this module's export list
will change, so we must recompile this module at least as far as
making a new interface file --- but in practice that means complete
recompilation.
Why (c)? Consider this:
\begin{verbatim}
module A( f, g ) where | module B( f ) where
import B( f ) | f = h 3
g = ... | h = ...
\end{verbatim}
Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in
@A@'s usages? Our idea is that we aren't going to touch A.hi if it is
*identical* to what it was before. If anything about @B.f@ changes
than anyone who imports @A@ should be recompiled in case they use
@B.f@ (they'll get an early exit if they don't). So, if anything
about @B.f@ changes we'd better make sure that something in A.hi
changes, and the convenient way to do that is to record the version
number @B.f@ in A.hi in the usage list. If B.f changes that'll force a
complete recompiation of A, which is overkill but it's the only way to
write a new, slightly different, A.hi.
But the example is tricker. Even if @B.f@ doesn't change at all,
@B.h@ may do so, and this change may not be reflected in @f@'s version
number. But with -O, a module that imports A must be recompiled if
@B.h@ changes! So A must record a dependency on @B.h@. So we treat
the occurrence of @B.f@ in the export list *just as if* it were in the
code of A, and thereby haul in all the stuff reachable from it.
[NB: If B was compiled with -O, but A isn't, we should really *still*
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O. I think this is the case.]
Even if B is used at all we get a usage line for B
import B <n> :: ... ;
in A.hi, to record the fact that A does import B. This is used to decide
things it uses.
We produce a line for every module B below the module, A, currently being
compiled:
import B <n> ;
to record the fact that A does import B indireclty. This is used to decide
to look to look for B.hi rather than B.hi-boot when compiling a module that
imports A. This line says that A imports B, but uses nothing in it.
So we'll get an early bale-out when compiling A if B's version changes.
......@@ -317,8 +278,12 @@ closeDecls decls needed
case rule_decls of
[] -> returnRn decls -- No new rules, so we are done
other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' ->
closeDecls (map RuleD rule_decls' ++ decls)
(plusFVs (map ruleDeclFVs rule_decls'))
let
rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
in
traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs))) `thenRn_`
closeDecls (map RuleD rule_decls' ++ decls) rule_fvs
-------------------------------------------------------
......@@ -644,7 +609,13 @@ importDecl name
returnRn AlreadySlurped
else
-- STEP 2: Check if it's already in the type environment
-- STEP 2: Check if we've slurped it in while compiling this module
getIfacesRn `thenRn` \ ifaces ->
if name `elemNameSet` iSlurp ifaces then
returnRn AlreadySlurped
else
-- STEP 3: Check if it's already in the type environment
getTypeEnvRn `thenRn` \ lookup ->
case lookup name of {
Just ty_thing | name `elemNameEnv` wiredInThingEnv
......@@ -658,12 +629,6 @@ importDecl name
Nothing ->
-- STEP 3: Check if we've slurped it in while compiling this module
getIfacesRn `thenRn` \ ifaces ->
if name `elemNameSet` iSlurp ifaces then
returnRn AlreadySlurped
else
-- STEP 4: OK, we have to slurp it in from an interface file
-- First load the interface file
traceRn nd_doc `thenRn_`
......@@ -711,11 +676,11 @@ recompileRequired :: FilePath -- Only needed for debug msgs
-> ModIface -- Old interface
-> RnMG RecompileRequired
recompileRequired iface_path source_unchanged iface
= traceRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_`
= traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_`
-- CHECK WHETHER THE SOURCE HAS CHANGED
if not source_unchanged then
traceRn (nest 4 (text "Source file changed or recompilation check turned off")) `thenRn_`
traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off")) `thenRn_`
returnRn outOfDate
else
......@@ -819,8 +784,8 @@ checkEntityUsage new_vers (name,old_vers)
| new_vers == old_vers -> returnRn upToDate
| otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
up_to_date msg = traceRn msg `thenRn_` returnRn upToDate
out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate
\end{code}
......
......@@ -96,6 +96,11 @@ traceRn msg
= doptRn Opt_D_dump_rn_trace `thenRn` \b ->
if b then putDocRn msg else returnRn ()
traceHiDiffsRn :: SDoc -> RnM d ()
traceHiDiffsRn msg
= doptRn Opt_D_dump_hi_diffs `thenRn` \b ->
if b then putDocRn msg else returnRn ()
putDocRn :: SDoc -> RnM d ()
putDocRn msg = ioToRnM (printErrs msg) `thenRn_`
returnRn ()
......
......@@ -24,8 +24,7 @@ module BinderInfo (
#include "HsVersions.h"
import IdInfo ( OccInfo(..), InsideLam, OneBranch, insideLam, notInsideLam, oneBranch )
import GlaExts ( Int(..), (+#) )
import IdInfo ( OccInfo(..), InsideLam, insideLam, notInsideLam )
import Outputable
\end{code}
......
......@@ -17,16 +17,16 @@ module SaAbsInt (
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
import CoreUnfold ( Unfolding, maybeUnfoldingTemplate )
import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe )
import CoreUnfold ( maybeUnfoldingTemplate )
import Id ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, wwUnpackNew,
import Demand ( Demand(..), wwPrim, wwStrict, wwUnpackData, wwLazy, wwUnpackNew,
mkStrictnessInfo, isLazy
)
import SaLib
import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon )
import BasicTypes ( Arity, NewOrData(..) )
import TyCon ( isProductTyCon, isRecursiveTyCon, isNewTyCon )
import BasicTypes ( NewOrData(..) )
import Type ( splitTyConApp_maybe,
isUnLiftedType, Type )
import TyCon ( tyConUnique )
......
......@@ -165,7 +165,7 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv
-- This data type is used to help tie the knot
-- when type checking type and class declarations
data TyThingDetails = SynTyDetails Type
| DataTyDetails ClassContext [DataCon] [Class]
| DataTyDetails ClassContext [DataCon]
| ClassDetails ClassContext [Id] [ClassOpItem] DataCon
\end{code}
......
......@@ -131,6 +131,7 @@ tcModule :: PersistentCompilerState
tcModule pcs hst get_fixity this_mod decls unf_env
= -- Type-check the type and class decls
traceTc (text "Tc1") `thenTc_`
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcSetEnv env $
let
......@@ -139,12 +140,14 @@ tcModule pcs hst get_fixity this_mod decls unf_env
in
-- Typecheck the instance decls, includes deriving
traceTc (text "Tc2") `thenTc_`
tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
hst unf_env get_fixity this_mod
tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
tcSetInstEnv inst_env $
-- Default declarations
traceTc (text "Tc3") `thenTc_`
tcDefaults decls `thenTc` \ defaulting_tys ->
tcSetDefaultTys defaulting_tys $
......@@ -157,7 +160,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env
-- We must do this before mkImplicitDataBinds (which comes next), since
-- the latter looks up unpackCStringId, for example, which is usually
-- imported
traceTc (text "Tc3") `thenTc_`
tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
traceTc (text "Tc5") `thenTc_` (
tcExtendGlobalValEnv sig_ids $
tcGetEnv `thenTc` \ unf_env ->
......@@ -180,15 +185,18 @@ tcModule pcs hst get_fixity this_mod decls unf_env
tcExtendGlobalValEnv cls_ids $
-- Foreign import declarations next
traceTc (text "Tc6") `thenTc_`
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
traceTc (text "Tc7") `thenTc_`
tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
tcSetEnv env $
-- Foreign export declarations next
traceTc (text "Tc8") `thenTc_`
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-- Second pass over class and instance declarations,
......@@ -253,6 +261,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env
tc_fords = foi_decls ++ foe_decls',
tc_rules = local_rules'
})
)
get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
......
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