omitIfaceSigForId, isDeadBinder,
exportWithOrigOccName,
externallyVisibleId,
- idFreeTyVars,
isIP,
isSpecPragmaId, isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
maybeModifyIdInfo,
externallyVisibleId
)
-import VarSet
-import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars,
+import Type ( Type, typePrimRep, addFreeTyVars,
usOnce, seqType, splitTyConApp_maybe )
import IdInfo
\begin{code}
mkId :: Name -> Type -> IdInfo -> Id
mkId name ty info = mkIdVar name (addFreeTyVars ty) info
-
-mkImportedId :: Name -> Type -> IdInfo -> Id
-mkImportedId name ty info = mkId name ty (info `setFlavourInfo` ImportedId)
\end{code}
\begin{code}
%************************************************************************
\begin{code}
-idFreeTyVars :: Id -> TyVarSet
-idFreeTyVars id = tyVarsOfType (idType id)
-
setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
isLocalId :: Id -> Bool
-- True of Ids that are locally defined, but are not constants
-- like data constructors, record selectors, and the like.
--- See comments with CoreSyn.isLocalVar
+-- See comments with CoreFVs.isLocalVar
isLocalId id = case idFlavour id of
VanillaId -> True
ExportedId -> True
module IdInfo (
IdInfo, -- Abstract
- vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
+ vanillaIdInfo, constantIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Zapping
zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
Setters
\begin{code}
-setFlavourInfo info fl = fl `seq` info { flavourInfo = wk }
+setFlavourInfo info fl = fl `seq` info { flavourInfo = fl }
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo info sp = PSEQ sp (info { specInfo = sp })
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setLBVarInfo info lb = info { lbvarInfo = lb }
setNoDiscardInfo info = case flavourInfo info of
- VanillaId -> info { flavourInfo = NoDiscardId }
+ VanillaId -> info { flavourInfo = ExportedId }
other -> info
zapSpecPragInfo info = case flavourInfo info of
SpecPragmaId -> info { flavourInfo = VanillaId }
vanillaIdInfo :: IdInfo
vanillaIdInfo = mkIdInfo VanillaId
+constantIdInfo :: IdInfo
+constantIdInfo = mkIdInfo ConstantId
+
mkIdInfo :: IdFlavour -> IdInfo
mkIdInfo flv = IdInfo {
flavourInfo = flv,
| ExportedId -- Locally defined, exported
| SpecPragmaId -- Locally defined, RHS holds specialised call
- | ImportedId -- Imported from elsewhere
+ | ConstantId -- Imported from elsewhere, or a dictionary function,
+ -- default method Id.
| DataConId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
ppFlavourInfo VanillaId = empty
ppFlavourInfo ExportedId = ptext SLIT("[Exported]")
ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
-ppFlavourInfo ImportedId = ptext SLIT("[Imported]")
+ppFlavourInfo ConstantId = ptext SLIT("[Constant]")
ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]")
ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]")
mkVanillaId, mkTemplateLocals,
mkTemplateLocal, idCprInfo
)
-import IdInfo ( IdInfo, vanillaIdInfo, mkIdInfo,
+import IdInfo ( IdInfo, constantIdInfo, mkIdInfo,
exactArity, setUnfoldingInfo, setCafInfo, setCprInfo,
setArityInfo, setSpecInfo, setTyGenInfo,
mkStrictnessInfo, setStrictnessInfo,
mkDefaultMethodId dm_name rec_c ty
= mkId dm_name ty info
where
- info = vanillaIdInfo `setTyGenInfo` TyGenNever
+ info = constantIdInfo `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
= mkId dfun_name dfun_ty info
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = vanillaIdInfo `setTyGenInfo` TyGenNever
+ info = constantIdInfo `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
- info = vanillaIdInfo
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = constantIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
getTagId
= pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
where
- info = vanillaIdInfo
+ info = constantIdInfo
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
-- Very useful...
-noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
+noCafIdInfo = constantIdInfo `setCafInfo` NoCafRefs
(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
openAlphaTy = mkTyVarTy openAlphaTyVar
\begin{code}
module CoreFVs (
+ isLocalVar, mustHaveLocalBinding,
+
exprFreeVars, exprsFreeVars,
exprSomeFreeVars, exprsSomeFreeVars,
- idRuleVars, idFreeVars,
+ idRuleVars, idFreeVars, idFreeTyVars,
ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
- mustHaveLocalBinding,
-
CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
) where
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation )
+import Id ( Id, idName, idType, isLocalId, hasNoBinding, idSpecialisation )
import VarSet
import Var ( Var, isId )
import Type ( tyVarsOfType )
%************************************************************************
%* *
+\subsection{isLocalVar}
+%* *
+%************************************************************************
+
+@isLocalVar@ returns True of all TyVars, and of Ids that are defined in
+this module and are not constants like data constructors and record selectors.
+These are the variables that we need to pay attention to when finding free
+variables, or doing dependency analysis.
+
+\begin{code}
+isLocalVar :: Var -> Bool
+isLocalVar v = isTyVar v || isLocalId v
+\end{code}
+
+\begin{code}
+mustHaveLocalBinding :: Var -> Bool
+-- True <=> the variable must have a binding in this module
+mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v))
+\end{code}
+
+
+%************************************************************************
+%* *
\section{Finding the free variables of an expression}
%* *
%************************************************************************
\begin{code}
-idRuleVars ::Id -> VarSet
-idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
-
idFreeVars :: Id -> VarSet
idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+idFreeTyVars :: Id -> TyVarSet
+-- Only local Ids conjured up locally, can have free type variables.
+-- (During type checking top-level Ids can have free tyvars)
+idFreeTyVars id = tyVarsOfType (idType id)
+-- | isLocalId id = tyVarsOfType (idType id)
+-- | otherwise = emptyVarSet
+
+idRuleVars ::Id -> VarSet
+idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
+
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
mkConApp,
varToCoreExpr,
- isTyVar, isId, isLocalVar, mustHaveLocalBinding,
+ isTyVar, isId,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, collectBindersIgnoringNotes,
%************************************************************************
%* *
-\subsection{isLocalVar}
-%* *
-%************************************************************************
-
-@isLocalVar@ returns True of all TyVars, and of Ids that are defined in
-this module and are not constants like data constructors and record selectors.
-These are the variables that we need to pay attention to when finding free
-variables, or doing dependency analysis.
-
-\begin{code}
-isLocalVar :: Var -> Bool
-isLocalVar v = isTyVar v || isLocalId v
-\end{code}
-
-\begin{code}
-mustHaveLocalBinding :: Var -> Bool
--- True <=> the variable must have a binding in this module
-mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v))
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Transformation rules}
%* *
%************************************************************************
import VarEnv
import VarSet
import Var ( Id, Var )
-import Id ( idType, idInfo, idName,
+import Id ( idType, idInfo, idName, isExportedId,
mkVanillaId, mkId, exportWithOrigOccName,
idStrictness, setIdStrictness,
idDemandInfo, setIdDemandInfo,
tidyTopId mod env@(tidy_env, var_env) env_idinfo id
= -- Top level variables
let
- (tidy_env', name') = tidyTopName mod tidy_env (idIsExported id) (idName id)
+ (tidy_env', name') = tidyTopName mod tidy_env (isExportedId id) (idName id)
ty' = tidyTopType (idType id)
idinfo' = tidyIdInfo env_idinfo (idInfo id)
id' = mkId name' ty' idinfo'
lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface
-- We often have two IfaceTables, and want to do a lookup
lookupIfaceByModName hit pit mod
- = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod
+ = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod
\end{code}
import IdInfo -- Lots
import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
- bindersOfBinds, mustHaveLocalBinding
+ bindersOfBinds
)
-import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
+import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars, mustHaveLocalBinding )
import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
import Name ( getName, nameModule, Name, NamedThing(..) )
import Name -- Env
import Module ( ModuleName, mkPrelModule, mkModuleName )
import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, mkKindOccFS )
-import RdrName ( RdrName, mkOrig, mkRdrOrig, mkUnqual )
+import RdrName ( RdrName, mkOrig, mkUnqual )
import UniqFM
import Unique ( Unique, Uniquable(..), hasKey,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
import UniqFM ( UniqFM, listToUFM )
import Name ( Name, mkLocalName, mkKnownKeyGlobal, nameRdrName )
import RdrName ( rdrNameOcc )
-import SrcLoc ( noSrcLoc )
+import SrcLoc ( builtinSrcLoc )
import Util ( nOfThem )
import Panic ( panic )
\end{code}
tcQual mod str uq = mkKnownKeyGlobal (tcQual_RDR mod str) uq
clsQual mod str uq = mkKnownKeyGlobal (clsQual_RDR mod str) uq
-kindQual str uq = mkLocalName (mkKindOccFS tcName str) uq
+kindQual str uq = mkLocalName uq (mkKindOccFS tcName str) builtinSrcLoc
-- Kinds are not z-encoded in interface file, hence mkKindOccFS
-- And they don't come from any particular module; indeed we always
-- want to print them unqualified. Hence the LocalName
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
+mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc
isUnboundName :: Name -> Bool
isUnboundName name = name `hasKey` unboundKey
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
-import RnNames ( getGlobalNames )
+import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
getInterfaceExports, closeDecls,
import IO ( openFile, IOMode(..) )
import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), WhatsImported(..),
- VersionInfo(..), ImportVersion,
+ VersionInfo(..), ImportVersion, IsExported,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
GlobalRdrEnv, pprGlobalRdrEnv,
AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe (PrintUnqualified, ModIface, [RenamedHsDecl]))
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
renameModule dflags hit hst old_pcs this_module rdr_module
; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module
(rename this_module rdr_module)
- ; let print_unqualified :: Name -> Bool -- Is this chap in scope unqualified?
- print_unqualified = case maybe_rn_stuff of
- Just (unqual, _, _) -> unqual
- Nothing -> alwaysQualify
+ ; let print_unqualified = case maybe_rn_stuff of
+ Just (unqual, _, _, _) -> unqual
+ Nothing -> alwaysQualify
-- Print errors from renaming
\begin{code}
rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
-rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
+rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
= pushSrcLocRn loc $
-- FIND THE GLOBAL NAME ENVIRONMENT
returnRn Nothing
else
- -- PROCESS EXPORT LIST (but not if we've had errors already)
+ -- PROCESS EXPORT LIST
exportsFromAvail mod_name exports all_avails gbl_env `thenRn` \ export_avails ->
traceRn (text "Local top-level environment" $$
if b then putDocRn msg else returnRn ()
putDocRn :: SDoc -> RnM d ()
-putDocRn msg = ioToRnM (printDump msg) `thenRn_`
+putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_`
returnRn ()
\end{code}
\begin{code}
module RnNames (
- getGlobalNames
+ getGlobalNames, exportsFromAvail
) where
#include "HsVersions.h"
GlobalRdrEnv, -- Maps just *local* things
ExportAvails) -- The exported stuff
-getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc)
+getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc)
= -- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
-- into the global name cache.
import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType )
import CoreFVs -- all of it
import Subst
-import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo,
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
SwitchResult(..), intSwitchSet,
- opt_UsageSPOn,
DynFlags, DynFlag(..), dopt, dopt_CoreToDo
)
import CoreLint ( showPass, endPass )
import CoreSyn
-import CoreFVs ( ruleSomeFreeVars )
-import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
+import CoreFVs ( ruleRhsFreeVars )
+import HscTypes ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) )
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
extendRuleBaseList, addRuleBaseFVs )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, isDataConWrapId, setIdNoDiscard, isLocalId )
+import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import IO ( hPutStr, stderr )
import Outputable
+import Maybes ( orElse )
import List ( partition )
\end{code}
-- COMPUTE THE RULE BASE TO USE
(rule_base, local_rule_stuff, orphan_rules)
- <- prepareRules dflags pkg_rule_base hst ru_us rules
+ <- prepareRules dflags pkg_rule_base hst ru_us binds rules
-- PREPARE THE BINDINGS
let binds1 = updateBinders local_rule_stuff is_exported binds
\begin{code}
prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
-> UniqSupply
+ -> [CoreBind]
-> [IdCoreRule] -- Local rules
- -> IO (RuleBase, -- Full rule base
- (IdSet,IdSet), -- Local rule Ids, and RHS fvs
- [IdCoreRule]) -- Orphan rules
+ -> IO (RuleBase, -- Full rule base
+ (IdSet,IdSet), -- Local rule Ids, and RHS fvs
+ [IdCoreRule]) -- Orphan rules
prepareRules dflags pkg_rule_base hst us binds rules
= do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(vcat (map pprIdCoreRule better_rules))
- ; let (local_id_rules, orphan_rules) = partition (isLocalId . fst) better_rules
- local_rule_rhs_fvs = unionVarSets (map ruleRhsFreeVars local_id_rules)
- local_rule_base = extendRuleBaseList emptyRuleBase local_id_rules
- local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
- imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
- rule_base = extendRuleBaseList imp_rule_base orphan_rules
- final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
+ ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
+ local_rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) local_rules)
+ local_rule_base = extendRuleBaseList emptyRuleBase local_rules
+ local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
+ rule_base = extendRuleBaseList imp_rule_base orphan_rules
+ final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
-- The last step black-lists the free vars of local rules too
; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules)
local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-updateBinders :: IdSet -- Locally defined ids with their Rules attached
- -> IdSet -- Ids free in the RHS of local rules
+updateBinders :: (IdSet, -- Locally defined ids with their Rules attached
+ IdSet) -- Ids free in the RHS of local rules
+ -> IsExported
-> [CoreBind] -> [CoreBind]
-- A horrible function
-- the rules (maybe we should?), so this substitution would make the rule
-- bogus.
-updateBinders rule_ids rule_rhs_fvs is_exported binds
+updateBinders (rule_ids, rule_rhs_fvs) is_exported binds
= map update_bndrs binds
where
update_bndrs (NonRec b r) = NonRec (update_bndr b) r
update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
update_bndr bndr
- | is_exported (getName bndr)
+ | is_exported (idName bndr)
|| bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr'
| otherwise = bndr'
where
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
import Id ( idType, idName,
idUnfolding, idStrictness,
- mkId, idInfo
+ mkVanillaId, idInfo
)
import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
let
poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
- poly_id = mkId poly_name poly_ty vanillaIdInfo
+ poly_id = mkVanillaId poly_name poly_ty
-- In the olden days, it was crucial to copy the occInfo of the original var,
-- because we were looking at occurrence-analysed but as yet unsimplified code!
zonkTcTyVars, zonkTcType, zonkTcTypes,
zonkTcThetaType
)
-import Bag
+import CoreFVs ( idFreeTyVars )
import Class ( Class, FunDep )
import FunDeps ( instantiateFdClassTys )
-import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
+import Id ( Id, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
import PprType ( pprPred )
import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
+import Bag
import Outputable
\end{code}
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
-import Id ( mkVanillaId, setInlinePragma, idFreeTyVars )
+import CoreFVs ( idFreeTyVars )
+import Id ( mkVanillaId, setInlinePragma )
import Var ( idType, idName )
import IdInfo ( InlinePragInfo(..) )
import Name ( Name, getOccName, getSrcLoc )
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
import DataCon ( dataConWrapId )
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
TcEnv, TcId, tcInstId
let
new_id = case maybe_id' of
Just (AnId id') -> id'
- other -> pprTrace "zonkIdOcc: " (ppr id) id
+ other -> pprTrace "zonkIdOcc:" (ppr id) id
in
returnNF_Tc new_id
\end{code}
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkId, mkImportedId, isDataConWrapId_maybe )
+import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
tcHsType ty `thenTc` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
- returnTc (mkImportedId name sigma_ty id_info)
+ returnTc (mkId name sigma_ty id_info)
\end{code}
\begin{code}
tcIdInfo unf_env in_scope_vars name ty info info_ins
- = foldlTc tcPrag vanillaIdInfo info_ins
+ = foldlTc tcPrag constantIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
import TcDefaults ( tcDefaults )
import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
tcEnvTyCons, tcEnvClasses, isLocalThing,
- RecTcEnv, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
+ tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
= do { showPass dflags "Typechecker";
; env <- initTcEnv hst (pcs_PTE pcs)
- ; (maybe_result, (warns,errs)) <- initTc dflags env tc_module
-
- ; let { maybe_tc_result :: Maybe TcResults ;
- maybe_tc_result = case maybe_result of
- Nothing -> Nothing
- Just (_,r) -> Just r }
+ ; (maybe_tc_result, (warns,errs)) <- initTc dflags env (tcModule pcs hst get_fixity this_mod decls)
; printErrorsAndWarnings unqual (errs,warns)
; printTcDump dflags maybe_tc_result
return Nothing
}
where
- tc_module :: TcM (RecTcEnv, TcResults)
- tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env)
-
fixity_env = mi_fixities mod_iface
get_fixity :: Name -> Maybe Fixity
-> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
- -> RecTcEnv -- The knot-tied environment
- -> TcM (TcEnv, TcResults)
+ -> TcM TcResults
- -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
- -- which is done lazily [ie failure just drops the pragma
- -- without having any global-failure effect].
- --
- -- unf_env is also used to get the pragama info
- -- for imported dfuns and default methods
-
-tcModule pcs hst get_fixity this_mod decls unf_env
+tcModule pcs hst get_fixity this_mod decls
= -- Type-check the type and class decls
- tcTyAndClassDecls unf_env decls `thenTc` \ env ->
- tcSetEnv env $
- let
- classes = tcEnvClasses env
- tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
- in
-
- -- Typecheck the instance decls, includes deriving
- 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
- tcDefaults decls `thenTc` \ defaulting_tys ->
- tcSetDefaultTys defaulting_tys $
-
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- -- We must do this before mkImplicitDataBinds (which comes next), since
- -- the latter looks up unpackCStringId, for example, which is usually
- -- imported
- tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- -- Create any necessary record selector Ids and their bindings
- -- "Necessary" includes data and newtype declarations
- -- We don't create bindings for dictionary constructors;
- -- they are always fully applied, and the bindings are just there
- -- to support partial applications
- mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) ->
- mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
-
- -- Extend the global value environment with
- -- (a) constructors
- -- (b) record selectors
- -- (c) class op selectors
- -- (d) default-method ids... where? I can't see where these are
- -- put into the envt, and I'm worried that the zonking phase
- -- will find they aren't there and complain.
- tcExtendGlobalValEnv data_ids $
- tcExtendGlobalValEnv cls_ids $
- tcGetEnv `thenTc` \ unf_env ->
+ fixTc (\ ~(unf_env, _, _, _, _) ->
+ -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
+ -- which is done lazily [ie failure just drops the pragma
+ -- without having any global-failure effect].
+ --
+ -- unf_env is also used to get the pragama info
+ -- for imported dfuns and default methods
+
+-- traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls unf_env decls `thenTc` \ env ->
+ tcSetEnv env $
+ let
+ classes = tcEnvClasses env
+ tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
+ in
+
+ -- Typecheck the instance decls, includes deriving
+-- traceTc (text "Tc2") `thenNF_Tc_`
+ 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 $
+
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ -- We must do this before mkImplicitDataBinds (which comes next), since
+ -- the latter looks up unpackCStringId, for example, which is usually
+ -- imported
+-- traceTc (text "Tc3") `thenNF_Tc_`
+ tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ -- Create any necessary record selector Ids and their bindings
+ -- "Necessary" includes data and newtype declarations
+ -- We don't create bindings for dictionary constructors;
+ -- they are always fully applied, and the bindings are just there
+ -- to support partial applications
+ mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) ->
+ mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
+
+ -- Extend the global value environment with
+ -- (a) constructors
+ -- (b) record selectors
+ -- (c) class op selectors
+ -- (d) default-method ids... where? I can't see where these are
+ -- put into the envt, and I'm worried that the zonking phase
+ -- will find they aren't there and complain.
+ tcExtendGlobalValEnv data_ids $
+ tcExtendGlobalValEnv cls_ids $
+ tcGetEnv `thenTc` \ unf_env ->
+ returnTc (unf_env, new_pcs_insts, local_inst_info, deriv_binds,
+ imp_data_binds `AndMonoBinds` imp_cls_binds)
+ ) `thenTc` \ (env, new_pcs_insts, local_inst_info, deriv_binds, data_cls_binds) ->
+ tcSetEnv env $
+
-- Foreign import declarations next
+-- traceTc (text "Tc4") `thenNF_Tc_`
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
+ -- Default declarations
+ tcDefaults decls `thenTc` \ defaulting_tys ->
+ tcSetDefaultTys defaulting_tys $
+
+ -- Value declarations next.
+ -- We also typecheck any extra binds that came out of the "deriving" process
+-- traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
tcSetEnv env $
- -- Foreign export declarations next
+ -- Foreign export declarations next
+-- traceTc (text "Tc6") `thenNF_Tc_`
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
+-- traceTc (text "Tc7") `thenNF_Tc_`
tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+-- traceTc (text "Tc8") `thenNF_Tc_`
tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
let
- all_binds = imp_data_binds `AndMonoBinds`
- imp_cls_binds `AndMonoBinds`
+ all_binds = data_cls_binds `AndMonoBinds`
val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
const_inst_binds `AndMonoBinds`
foe_binds
in
+-- traceTc (text "Tc9") `thenNF_Tc_`
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
pcs_rules = new_pcs_rules
}
in
- returnTc (unf_env,
- TcResults { tc_pcs = final_pcs,
+-- traceTc (text "Tc10") `thenNF_Tc_`
+ returnTc (TcResults { tc_pcs = final_pcs,
tc_env = local_type_env,
tc_binds = all_binds',
tc_insts = map iDFunId local_inst_info,
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
-import Id ( mkVanillaId, idName, idType, idFreeTyVars )
+import CoreFVs ( idFreeTyVars )
+import Id ( mkVanillaId, idName, idType )
import Var ( Id, Var, TyVar, mkTyVar, tyVarKind )
import VarEnv
import VarSet
-- Collect together all the bad guys
bad_guys = non_stds ++ concat std_bads
in
-
-- Disambiguate the ones that look feasible
mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
pprInstsInFull dicts])
-addRuleLhsErr dict
- = addInstErrTcM (instLoc dict)
- (tidy_env,
- vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
- nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
- where
- (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
-
addTopIPErr dict
= addInstErrTcM (instLoc dict)
(tidy_env,
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
inlDataCon, crossTyCon, crossDataCon
)
-import IdInfo ( vanillaIdInfo, setUnfoldingInfo )
+import IdInfo ( constantIdInfo, setUnfoldingInfo )
import CoreUnfold ( mkTopUnfolding )
import Unique ( mkBuiltinUnique )
tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
tyvar_tys = mkTyVarTys tyvars
- from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
- to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+ from_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+ to_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
projects / ghc-hetmet.git / commitdiff