#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
#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 $
%
%********************************************************
%* *
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
-import CgHeapery ( altHeapCheck, yield )
+import CgHeapery ( altHeapCheck )
import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
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 )
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 $
%
%********************************************************
%* *
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 )
sTD_ITBL_SIZE, pROF_ITBL_SIZE,
gRAN_ITBL_SIZE, tICKY_ITBL_SIZE )
import Outputable
-import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) )
\end{code}
%************************************************************************
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
- mkClassDeclSysNames, isIfaceRuleDecl,
+ mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames
) where
-- others:
import FunDeps ( pprFundeps )
-import Class ( FunDep )
+import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc )
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}
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)
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)
-- 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
$$ indent ms
$$ text "}"
-staticblock = \ss ->
- text "static" <+> text "{"
- $$ indent ss
- $$ text "}"
-
modifiers mfs = hsep (map modifier mfs)
modifier mf = text $ map toLower (show mf)
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
|| sw `is_elem` ss
\end{code}
-Default settings for simplifier switches
-
-\begin{code}
-defaultSimplSwitches = [MaxSimplifierIterations 1]
-\end{code}
%************************************************************************
%* *
import Outputable
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import TmpFiles ( newTempName )
-import UniqSupply ( mkSplitUniqSupply )
import IO ( IOMode(..), hClose, openFile, Handle )
\end{code}
lookupIface, lookupIfaceByModName,
emptyModIface,
- IfaceDecls(..),
+ IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
VersionInfo(..), initialVersionInfo,
import BasicTypes ( Version, initialVersion, Fixity )
-import HsSyn ( DeprecTxt )
+import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import Maybes ( seqMaybe )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
-import Util ( thenCmp )
+import Util ( thenCmp, sortLt )
import UniqSupply ( UniqSupply )
\end{code}
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
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(..)
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)
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
)
import RnHiFiles ( readIface, removeContext,
loadExports, loadFixDecls, loadDeprecs )
-import RnEnv ( availName,
+import RnEnv ( availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupSrcName, newGlobalName
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
-- 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.
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
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,
----------------
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 _)
%* *
%*********************************************************
-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.
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
+
-------------------------------------------------------
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
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_`
-> 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
| 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}
= 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 ()
#include "HsVersions.h"
-import IdInfo ( OccInfo(..), InsideLam, OneBranch, insideLam, notInsideLam, oneBranch )
-import GlaExts ( Int(..), (+#) )
+import IdInfo ( OccInfo(..), InsideLam, insideLam, notInsideLam )
import Outputable
\end{code}
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 )
-- 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}
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
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 $
-- 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 ->
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,
tc_fords = foi_decls ++ foe_decls',
tc_rules = local_rules'
})
+ )
get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
#include "HsVersions.h"
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import HsSyn ( HsDecl(..), TyClDecl(..),
HsTyVarBndr,
ConDecl(..),
import ErrUtils ( Message )
import HsDecls ( getClassDeclSysNames )
import Generics ( mkTyConGenInfo )
-import CmdLineOpts ( DynFlags )
\end{code}
where
tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
data_cons nconstrs
- derived_classes
flavour is_rec gen_info
- gen_info = mkTyConGenInfo dflags tycon name1 name2
- DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
+ gen_info | not (dopt Opt_Generics dflags) = Nothing
+ | otherwise = mkTyConGenInfo tycon name1 name2
+
+ DataTyDetails ctxt data_cons = lookupNameEnv_NF rec_details tycon_name
tycon_kind = lookupNameEnv_NF kenv tycon_name
tyvars = mkTyClTyVars tycon_kind tyvar_names
kcHsContext, kcHsSigType
)
import TcEnv ( tcExtendTyVarEnv,
- tcLookupTyCon, tcLookupClass, tcLookupGlobalId,
+ tcLookupTyCon, tcLookupGlobalId,
TyThingDetails(..)
)
import TcMonad
uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
= checkKinds swapped tv1 non_var_ty2 `thenTc_`
occur_check non_var_ty2 `thenTc_`
- ASSERT( isNotUsgTy ps_ty2 )
checkTcM (not (isSigTyVar tv1))
(failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_`
__interface Generics 1 0 where
__export Generics mkTyConGenInfo ;
-1 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ;
+2 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ;
) where
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import RnHsSyn ( RenamedHsExpr )
import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
%************************************************************************
\begin{code}
-mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
-- mkTyConGenInfo is called twice
-- once from TysWiredIn for Tuples
-- once the typechecker TcTyDecls
-- The two names are the names constructed by the renamer
-- for the fromT and toT conversion functions.
-mkTyConGenInfo dflags tycon from_name to_name
- | not (dopt Opt_Generics dflags)
- = Nothing
-
+mkTyConGenInfo tycon from_name to_name
| null datacons -- Abstractly imported types don't have
= Nothing -- to/from operations, (and should not need them)
splitSigmaTy, splitDFunTy, tyVarsOfTypes
)
import PprType ( )
-import DataCon ( DataCon )
import TyCon ( TyCon )
import Outputable
import Unify ( matchTys, unifyTyListsX )
#include "HsVersions.h"
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
+import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
import DataCon ( dataConRepArgTys )
import FiniteMap
import Var ( TyVar )
import VarSet
-import Name ( Name, getName )
import Maybes ( expectJust )
import Outputable
\end{code}
#define OUTPUTABLE_key {--}
#endif
-import {-# SOURCE #-} Name ( Name )
import GlaExts
-import FastString
import Maybes
import Bag ( Bag, foldrBag )
import Outputable
| otherwise -- We now need the same two cases as in glueBal above.
= glueBal fm_l fm_r
where
- (mid_key_l,mid_elt_l) = findMax fm_l
- (mid_key_r,mid_elt_r) = findMin fm_r
size_l = sizeFM fm_l
size_r = sizeFM fm_r
\end{code}
import qualified Pretty
import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
import Panic
-import ST ( runST )
-import Foreign
import Char ( chr, ord, isDigit )
\end{code}
import GlaExts
import PrelAddr ( Addr(..) )
import Foreign
-import ST
import Char ( chr )
-- urk!
#include "HsVersions.h"
-import Panic (panic)
-import Char (chr, ord)
+import Panic ( panic )
+import Char ( chr )
\end{code}
\begin{code}
projects / ghc-hetmet.git / commitdiff