summaryrefslogtreecommitdiff
path: root/ghc/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/rename')
-rw-r--r--ghc/compiler/rename/ParseIface.y91
-rw-r--r--ghc/compiler/rename/Rename.lhs47
-rw-r--r--ghc/compiler/rename/RnBinds.lhs6
-rw-r--r--ghc/compiler/rename/RnExpr.lhs13
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs88
-rw-r--r--ghc/compiler/rename/RnNames.lhs4
-rw-r--r--ghc/compiler/rename/RnSource.lhs67
7 files changed, 176 insertions, 140 deletions
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index a151fe4caf..40cc45165a 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -7,14 +7,16 @@ import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
import HsTypes ( mkHsForAllTy, mkHsUsForAllTy )
import HsCore
-import Const ( Literal(..), mkMachInt_safe )
+import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
import BasicTypes ( Fixity(..), FixityDirection(..),
NewOrData(..), Version
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
+import CallConv ( cCallConv )
import HsPragmas ( noDataPragmas, noClassPragmas )
import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, UsageAnn(..) )
import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) )
+import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
@@ -23,14 +25,13 @@ import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
+import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual, mkRdrNameWkr )
import Name ( OccName, Provenance )
import OccName ( mkSysOccFS,
tcName, varName, ipName, dataName, clsName, tvName, uvName,
EncodedFS
)
import Module ( ModuleName, mkSysModuleFS )
-import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName )
import SrcLoc ( SrcLoc )
import Maybes
@@ -95,6 +96,9 @@ import Ratio ( (%) )
'__bot' { ITbottom }
'__integer' { ITinteger_lit }
'__float' { ITfloat_lit }
+ '__word' { ITword_lit }
+ '__int64' { ITint64_lit }
+ '__word64' { ITword64_lit }
'__rational' { ITrational_lit }
'__addr' { ITaddr_lit }
'__litlit' { ITlit_lit }
@@ -112,8 +116,8 @@ import Ratio ( (%) )
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
'__R' { ITrules }
+ '__M' { ITcprinfo }
'__D' { ITdeprecated }
- '__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
'::' { ITdcolon }
@@ -405,15 +409,15 @@ constrs1 : constr { [$1] }
| constr '|' constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
-constr : src_loc ex_stuff data_name batypes { mkConDecl $3 $2 (VanillaCon $4) $1 }
- | src_loc ex_stuff data_name '{' fields1 '}' { mkConDecl $3 $2 (RecCon $5) $1 }
+constr : src_loc ex_stuff data_name batypes { mk_con_decl $3 $2 (VanillaCon $4) $1 }
+ | src_loc ex_stuff data_name '{' fields1 '}' { mk_con_decl $3 $2 (RecCon $5) $1 }
-- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} }
newtype_constr : { [] }
- | src_loc '=' ex_stuff data_name atype { [mkConDecl $4 $3 (NewCon $5 Nothing) $1] }
+ | src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (NewCon $5 Nothing) $1] }
| src_loc '=' ex_stuff data_name '{' var_name '::' atype '}'
- { [mkConDecl $4 $3 (NewCon $8 (Just $6)) $1] }
+ { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] }
ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) }
ex_stuff : { ([],[]) }
@@ -662,7 +666,7 @@ id_info :: { [HsIdInfo RdrName] }
id_info_item :: { HsIdInfo RdrName }
: '__A' INTEGER { HsArity (exactArity (fromInteger $2)) }
| '__U' inline_prag core_expr { HsUnfold $2 $3 }
- | '__M' { HsCprInfo $1 }
+ | '__M' { HsCprInfo }
| '__S' { HsStrictness (HsStrictnessInfo $1) }
| '__C' { HsNoCafRefs }
| '__P' qvar_name { HsWorker $2 }
@@ -683,8 +687,7 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 }
| '__letrec' '{' rec_binds '}'
'in' core_expr { UfLet (UfRec $3) $6 }
- | con_or_primop '{' core_args '}' { UfCon $1 $3 }
- | '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] }
+ | '__litlit' STRING atype { UfLitLit $2 $3 }
| '__inline_me' core_expr { UfNote UfInlineMe $2 }
| '__inline_call' core_expr { UfNote UfInlineCall $2 }
@@ -706,7 +709,6 @@ core_args :: { [UfExpr RdrName] }
core_aexpr :: { UfExpr RdrName } -- Atomic expressions
core_aexpr : qvar_name { UfVar $1 }
-
| qdata_name { UfVar $1 }
-- This one means that e.g. "True" will parse as
-- (UfVar True_Id) rather than (UfCon True_Con []).
@@ -717,14 +719,30 @@ core_aexpr : qvar_name { UfVar $1 }
-- If you want to get a UfCon, then use the
-- curly-bracket notation (True {}).
- | core_lit { UfCon (UfLitCon $1) [] }
- | '(' core_expr ')' { $2 }
- | '(' comma_exprs2 ')' { UfTuple (mkTupConRdrName (length $2)) $2 }
- | '(#' comma_exprs0 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 }
-
-- This one is dealt with by qdata_name: see above comments
-- | '(' ')' { UfTuple (mkTupConRdrName 0) [] }
+ | core_lit { UfLit $1 }
+ | '(' core_expr ')' { $2 }
+
+ -- Tuple construtors are for the *worker* of the tuple
+ -- Going direct saves needless messing about
+ | '(' comma_exprs2 ')' { UfTuple (mkRdrNameWkr (mkTupConRdrName (length $2))) $2 }
+ | '(#' comma_exprs0 '#)' { UfTuple (mkRdrNameWkr (mkUbxTupConRdrName (length $2))) $2 }
+
+ | '{' '__ccall' ccall_string type '}'
+ { let
+ (is_dyn, is_casm, may_gc) = $2
+
+ target | is_dyn = DynamicTarget (error "CCall dyn target bogus unique")
+ | otherwise = StaticTarget $3
+
+ ccall = CCall target is_casm may_gc cCallConv
+ in
+ UfCCall ccall $4
+ }
+
+
comma_exprs0 :: { [UfExpr RdrName] } -- Zero or more
comma_exprs0 : {- empty -} { [ ] }
| core_expr { [ $1 ] }
@@ -734,15 +752,6 @@ comma_exprs2 :: { [UfExpr RdrName] } -- Two or more
comma_exprs2 : core_expr ',' core_expr { [$1,$3] }
| core_expr ',' comma_exprs2 { $1 : $3 }
-con_or_primop :: { UfCon RdrName }
-con_or_primop : qdata_name { UfDataCon $1 }
- | qvar_name { UfPrimOp $1 }
- | '__ccall' ccall_string { let
- (is_dyn, is_casm, may_gc) = $1
- in
- UfCCallOp $2 is_dyn is_casm may_gc
- }
-
rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
: { [] }
| core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 }
@@ -754,12 +763,12 @@ core_alts :: { [UfAlt RdrName] }
core_alt :: { UfAlt RdrName }
core_alt : core_pat '->' core_expr { (fst $1, snd $1, $3) }
-core_pat :: { (UfCon RdrName, [RdrName]) }
-core_pat : core_lit { (UfLitCon $1, []) }
- | '__litlit' STRING atype { (UfLitLitCon $2 $3, []) }
- | qdata_name core_pat_names { (UfDataCon $1, $2) }
- | '(' comma_var_names1 ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) }
- | '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) }
+core_pat :: { (UfConAlt RdrName, [RdrName]) }
+core_pat : core_lit { (UfLitAlt $1, []) }
+ | '__litlit' STRING atype { (UfLitLitAlt $2 $3, []) }
+ | qdata_name core_pat_names { (UfDataAlt $1, $2) }
+ | '(' comma_var_names1 ')' { (UfDataAlt (mkTupConRdrName (length $2)), $2) }
+ | '(#' comma_var_names1 '#)' { (UfDataAlt (mkUbxTupConRdrName (length $2)), $2) }
| '__DEFAULT' { (UfDefault, []) }
| '(' core_pat ')' { $2 }
@@ -780,22 +789,14 @@ comma_var_names1 : var_name { [$1] }
| var_name ',' comma_var_names1 { $1 : $3 }
core_lit :: { Literal }
-core_lit : integer { mkMachInt_safe $1 }
+core_lit : integer { mkMachInt $1 }
| CHAR { MachChar $1 }
| STRING { MachStr $1 }
- | '__string' STRING { NoRepStr $2 (panic "NoRepStr type") }
| rational { MachDouble $1 }
+ | '__word' integer { mkMachWord $2 }
+ | '__word64' integer { mkMachWord64 $2 }
+ | '__int64' integer { mkMachInt64 $2 }
| '__float' rational { MachFloat $2 }
-
- | '__integer' integer { NoRepInteger $2 (panic "NoRepInteger type")
- -- The type checker will add the types
- }
-
- | '__rational' integer integer { NoRepRational ($2 % $3)
- (panic "NoRepRational type")
- -- The type checker will add the type
- }
-
| '__addr' integer { MachAddr $2 }
integer :: { Integer }
@@ -868,5 +869,5 @@ data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface
| PRules [RdrNameRuleDecl]
| PDeprecs [RdrNameDeprecation]
-mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc
+mk_con_decl name (ex_tvs, ex_ctxt) details loc = mkConDecl name ex_tvs ex_ctxt details loc
}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 211b80162b..359f284133 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -29,10 +29,11 @@ import RnEnv ( availName, availsToNameSet,
)
import Module ( Module, ModuleName, mkSearchPath, mkThisModule )
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
- nameOccName, nameUnique, isUserImportedExplicitlyName,
+ nameOccName, nameUnique,
+ isUserImportedExplicitlyName, isUserImportedName,
maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
)
-import OccName ( occNameFlavour )
+import OccName ( occNameFlavour, isValOcc )
import Id ( idType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
@@ -98,6 +99,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
else
let
Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
+ ExportEnv export_avails _ _ = export_env
in
-- RENAME THE SOURCE
@@ -108,10 +110,15 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
-- SLURP IN ALL THE NEEDED DECLARATIONS
implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
let
- real_source_fvs = implicit_fvs `plusFV` source_fvs
+ real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_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.
+
+ -- 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
+ export_fvs = mkNameSet (map availName export_avails)
in
slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls ->
let
@@ -424,7 +431,7 @@ vars of the source program, and extracts from the decl the gate names.
getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(map getTyVarName tvs)
`addOneToNameSet` cls)
@@ -454,13 +461,13 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
(map getTyVarName tvs)
`addOneToNameSet` tycon
where
- get (ConDecl n tvs ctxt details _)
+ get (ConDecl n _ tvs ctxt details _)
| n `elemNameSet` source_fvs
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
(map getTyVarName tvs)
- get (ConDecl n tvs ctxt (RecCon fields) _)
+ get (ConDecl n _ tvs ctxt (RecCon fields) _)
-- Even if the constructor isn't mentioned, the fields
-- might be, as selectors. They can't mention existentially
-- bound tyvars (typechecker checks for that) so no need for
@@ -526,12 +533,28 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_name
-- Now, a use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
really_used_names = used_names `unionNameSets`
- mkNameSet [ availName avail
- | sub_name <- nameSetToList used_names,
- let avail = case lookupNameEnv avail_env sub_name of
- Just avail -> avail
- Nothing -> WARN( True, text "reportUnusedName: not in avail_env" <+> ppr sub_name )
- Avail sub_name
+ mkNameSet [ availName parent_avail
+ | sub_name <- nameSetToList used_names
+ , isValOcc (getOccName sub_name)
+
+ -- Usually, every used name will appear in avail_env, but there
+ -- is one time when it doesn't: tuples and other built in syntax. When you
+ -- write (a,b) that gives rise to a *use* of "(,)", so that the
+ -- instances will get pulled in, but the tycon "(,)" isn't actually
+ -- in scope. Hence the isValOcc filter.
+ --
+ -- Also, (-x) gives rise to an implicit use of 'negate'; similarly,
+ -- 3.5 gives rise to an implcit use of :%
+ -- hence the isUserImportedName filter on the warning
+
+ , let parent_avail
+ = case lookupNameEnv avail_env sub_name of
+ Just avail -> avail
+ Nothing -> WARN( isUserImportedName sub_name,
+ text "reportUnusedName: not in avail_env" <+> ppr sub_name )
+ Avail sub_name
+
+ , case parent_avail of { AvailTC _ _ -> True; other -> False }
]
defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index eef2204045..aefb9ec051 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -233,7 +233,8 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs
$ \ new_mbinders ->
let
- binder_set = mkNameSet new_mbinders
+ binder_set = mkNameSet new_mbinders
+ binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-- Weed out the fixity declarations that do not
-- apply to any of the binders in this group.
@@ -242,9 +243,6 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
forLocalBind (FixSig sig@(FixitySig name _ _ )) =
isJust (lookupFM binder_occ_fm (rdrNameOcc name))
forLocalBind _ = True
-
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-
in
-- Rename the signatures
renameSigs False binder_set
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index a4c7e7d3e5..65bf0f8367 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -177,20 +177,21 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
Just ty -> extractHsTyRdrNames ty
tyvars_in_pats = extractPatsTyVars pats
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
- doc = text "a pattern type-signature"
+ doc_sig = text "a pattern type-signature"
+ doc_pats = text "in a pattern match"
in
- bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+ bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
-- f x x = 1
- bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
+ bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
@@ -347,13 +348,13 @@ rnExpr section@(SectionR op expr)
checkSectionPrec "right" section op' expr' `thenRn_`
returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
= lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (CCall fun args' may_gc is_casm fake_result_ty,
+ returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
rnExpr (HsSCC lbl expr)
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 2715924203..6b1b90c627 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -22,7 +22,7 @@ module RnIfaces (
import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas )
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
- ForeignDecl(..), ForKind(..), isDynamic,
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
isClassOpSig, Deprecation(..)
)
@@ -678,51 +678,47 @@ moudule is; that is, what it must record in its interface file as the
things it uses. It records:
\begin{itemize}
-\item anything reachable from its body code
-\item any module exported with a @module Foo@.
+\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 the latter? Because if @Foo@ changes then this module's export list
+
+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.
-What about this?
+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}
-Should we record @B.f@ in @A@'s usages? In fact we don't. Certainly,
-if anything about @B.f@ changes than anyone who imports @A@ should be
-recompiled; they'll get an early exit if they don't use @B.f@.
-However, 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. So there
-are two things going on when compiling module @A@:
-
-\begin{enumerate}
-\item Are @A.o@ and @A.hi@ correct? Then we can bale out early.
-\item Should modules that import @A@ be recompiled?
-\end{enumerate}
-
-For (1) it is slightly harmful to record @B.f@ in @A@'s usages,
-because a change in @B.f@'s version will provoke full recompilation of
-@A@, producing an identical @A.o@, and @A.hi@ differing only in its
-usage-version of @B.f@ (and this usage-version info isn't used by any
-importer).
-
-For (2), because of the tricky @B.h@ question above, we ensure that
-@A.hi@ is touched (even if identical to its previous version) if A's
-recompilation was triggered by an imported @.hi@ file date change.
-Given that, there's no need to record @B.f@ in @A@'s usages.
-
-On the other hand, if @A@ exports @module B@, then we {\em do} count
-@module B@ among @A@'s usages, because we must recompile @A@ to ensure
-that @A.hi@ changes appropriately.
-
-HOWEVER, we *do* record the usage
- import B <n> :: ;
+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
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.
@@ -733,7 +729,7 @@ getImportVersions :: ModuleName -- Name of this module
-> ExportEnv -- Info about exports
-> RnMG (VersionInfo Name) -- Version info for these names
-getImportVersions this_mod (ExportEnv export_avails _ export_all_mods)
+getImportVersions this_mod (ExportEnv _ _ export_all_mods)
= getIfacesRn `thenRn` \ ifaces ->
let
mod_map = iImpModInfo ifaces
@@ -813,6 +809,8 @@ getSlurped
returnRn (iSlurp ifaces)
recordSlurp maybe_version avail
+-- Nothing for locally defined names
+-- Just version for imported names
= getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names,
iVSlurp = imp_names }) ->
let
@@ -856,7 +854,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
returnRn (Just (AvailTC tycon_name [tycon_name]))
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ src_loc))
+getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
-- Record the names for the class ops
@@ -890,17 +888,17 @@ getDeclBinders new_name (RuleD _) = returnRn Nothing
binds_haskell_name (FoImport _) _ = True
binds_haskell_name FoLabel _ = True
-binds_haskell_name FoExport ext_nm = isDynamic ext_nm
+binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm
----------------
-getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest)
= mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
getConFieldNames new_name rest `thenRn` \ ns ->
returnRn (cfs ++ ns)
where
fields = concat (map fst fielddecls)
-getConFieldNames new_name (ConDecl con _ _ condecl src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
(case condecl of
NewCon _ (Just f) ->
@@ -925,11 +923,11 @@ and the dict fun of an instance decl, because both of these have
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname snames src_loc))
- = new_name dname src_loc `thenRn` \ datacon_name ->
- new_name tname src_loc `thenRn` \ tycon_name ->
- sequenceRn [new_name n src_loc | n <- snames] `thenRn` \ scsel_names ->
- returnRn (tycon_name : datacon_name : scsel_names)
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc))
+ = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)]
+
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _))
+ = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
= returnRn []
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 832c925611..4ef7c0a5db 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -16,7 +16,7 @@ import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
IE(..), ieName,
- ForeignDecl(..), ForKind(..), isDynamic,
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), Sig(..), ImportDecl(..),
collectTopBinders
)
@@ -334,7 +334,7 @@ fixitiesFromLocalDecls gbl_env decls
getFixities acc (FixD fix)
= fix_decl acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _))
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities acc other_decl
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 0ef3d39e3b..1531d8c809 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -52,6 +52,8 @@ import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import UniqFM ( lookupUFM )
+import ErrUtils ( Message )
+import CStrings ( isCLabelString )
import Maybes ( maybeToBool, catMaybes )
import Util
\end{code}
@@ -163,7 +165,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
- tname dname snames src_loc))
+ tname dname dwname snames src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn cname `thenRn` \ cname' ->
@@ -177,6 +179,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
-- I can't work up the energy to do it more beautifully
mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
+ mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' ->
mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
-- Tyvars scope over bindings and context
@@ -216,7 +219,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
ASSERT(isNoClassPragmas pragmas)
returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
- NoClassPragmas tname' dname' snames' src_loc),
+ NoClassPragmas tname' dname' dwname' snames' src_loc),
sig_fvs `plusFV`
fix_fvs `plusFV`
cxt_fvs `plusFV`
@@ -362,6 +365,10 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
= pushSrcLocRn src_loc $
lookupOccRn name `thenRn` \ name' ->
let
+ ok_ext_nm Dynamic = True
+ ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
+ ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+
fvs1 = case imp_exp of
FoImport _ | not isDyn -> emptyFVs
FoLabel -> emptyFVs
@@ -371,12 +378,13 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
| otherwise -> mkNameSet [name']
_ -> emptyFVs
in
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
+ checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
+ rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
fvs1 `plusFV` fvs2)
where
fo_decl_msg = ptext SLIT("a foreign declaration")
- isDyn = isDynamic ext_nm
+ isDyn = isDynamicExtName ext_nm
\end{code}
%*********************************************************
@@ -447,17 +455,21 @@ rnDerivs (Just clss)
\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
-conDeclName (ConDecl n _ _ _ l) = (n,l)
+conDeclName (ConDecl n _ _ _ _ l) = (n,l)
rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
-rnConDecl (ConDecl name tvs cxt details locn)
+rnConDecl (ConDecl name wkr tvs cxt details locn)
= pushSrcLocRn locn $
checkConName name `thenRn_`
lookupBndrRn name `thenRn` \ new_name ->
+
+ mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
+ -- See comments with ClassDecl
+
bindTyVarsFVRn doc tvs $ \ new_tyvars ->
rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
- returnRn (ConDecl new_name new_tyvars new_context new_details locn,
+ returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
cxt_fvs `plusFV` det_fvs)
where
doc = text "the definition of data constructor" <+> quotes (ppr name)
@@ -738,8 +750,8 @@ rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
returnRn (HsUnfold inline expr', fvs)
rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
-rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs)
-rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs)
+rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
+rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
`thenRn` \ (rule_body', fvs) ->
returnRn (HsSpecialise rule_body', fvs)
@@ -762,10 +774,16 @@ rnCoreExpr (UfVar v)
= lookupOccRn v `thenRn` \ v' ->
returnRn (UfVar v', unitFV v')
-rnCoreExpr (UfCon con args)
- = rnUfCon con `thenRn` \ (con', fvs1) ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
- returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
+rnCoreExpr (UfLit l)
+ = returnRn (UfLit l, emptyFVs)
+
+rnCoreExpr (UfLitLit l ty)
+ = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
+ returnRn (UfLitLit l ty', fvs)
+
+rnCoreExpr (UfCCall cc ty)
+ = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
+ returnRn (UfCCall cc ty', fvs)
rnCoreExpr (UfTuple con args)
= lookupOccRn con `thenRn` \ con' ->
@@ -853,23 +871,16 @@ rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
rnUfCon UfDefault
= returnRn (UfDefault, emptyFVs)
-rnUfCon (UfDataCon con)
+rnUfCon (UfDataAlt con)
= lookupOccRn con `thenRn` \ con' ->
- returnRn (UfDataCon con', unitFV con')
+ returnRn (UfDataAlt con', unitFV con')
-rnUfCon (UfLitCon lit)
- = returnRn (UfLitCon lit, emptyFVs)
+rnUfCon (UfLitAlt lit)
+ = returnRn (UfLitAlt lit, emptyFVs)
-rnUfCon (UfLitLitCon lit ty)
+rnUfCon (UfLitLitAlt lit ty)
= rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
- returnRn (UfLitLitCon lit ty', fvs)
-
-rnUfCon (UfPrimOp op)
- = lookupOccRn op `thenRn` \ op' ->
- returnRn (UfPrimOp op', emptyFVs)
-
-rnUfCon (UfCCallOp str is_dyn casm gc)
- = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
+ returnRn (UfLitLitAlt lit ty', fvs)
\end{code}
%*********************************************************
@@ -972,4 +983,8 @@ badRuleVar name var
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
+
+badExtName :: ExtName -> Message
+badExtName ext_nm
+ = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
\end{code}
View Lorry Controller Status