Commit e47dd5d2 authored by simonpj's avatar simonpj
Browse files

[project @ 1998-04-07 07:51:07 by simonpj]

Simons changes while away at Tic/WG2.8
parent 36bc0530
......@@ -60,7 +60,12 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
\begin{code}
writeRealC :: Handle -> AbstractC -> IO ()
writeRealC handle absC = printForC handle (pprAbsC absC (costs absC))
--writeRealC handle absC =
-- _scc_ "writeRealC"
-- printDoc LeftMode handle (pprAbsC absC (costs absC))
writeRealC handle absC =
_scc_ "writeRealC"
printForC handle (pprAbsC absC (costs absC))
dumpRealC :: AbstractC -> SDoc
dumpRealC absC = pprAbsC absC (costs absC)
......@@ -77,19 +82,16 @@ emitMacro (Cost (i,b,l,s,f))
= hcat [ ptext SLIT("GRAN_EXEC"), char '(',
int i, comma, int b, comma, int l, comma,
int s, comma, int f, pp_paren_semi ]
\end{code}
\begin{code}
pp_paren_semi = text ");"
\end{code}
-- ---------------------------------------------------------------------------
-- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
-- code as an argument (that's needed when spitting out the GRAN_EXEC macro
-- which must be done before the return i.e. inside absC code) HWL
-- ---------------------------------------------------------------------------
New type: Now pprAbsC also takes the costs for evaluating the Abstract C
code as an argument (that's needed when spitting out the GRAN_EXEC macro
which must be done before the return i.e. inside absC code) HWL
\begin{code}
pprAbsC :: AbstractC -> CostRes -> SDoc
pprAbsC AbsCNop _ = empty
pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
......@@ -97,7 +99,6 @@ pprAbsC (CClosureUpdInfo info) c
= pprAbsC info c
pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
pprAbsC (CJump target) c
= ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
(hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
......@@ -199,9 +200,9 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
vcat [ pp_saves,
the_op,
pp_restores
]
the_op,
pp_restores
]
else
the_op
}
......@@ -498,7 +499,6 @@ if_profiling pretty
= if opt_SccProfilingOn
then pretty
else char '0' -- leave it out!
-- ---------------------------------------------------------------------------
-- Changes for GrAnSim:
-- draw costs for computation in head of if into both branches;
......@@ -561,8 +561,8 @@ Some rough notes on generating code for @CCallOp@:
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
{- Doesn't apply anymore with ForeignObj, structure create via primop.
makeForeignObj (ForeignObj is not CReturnable)
{- Doesn't apply anymore with ForeignObj, structure created via the primop.
makeForeignObj (i.e., ForeignObj is not CReturnable)
7) If returning Malloc Pointer, build a closure containing the
appropriate value.
-}
......@@ -708,7 +708,7 @@ For l-values, the critical questions are:
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
-> SDoc -- liveness mask
-> SDoc -- liveness mask
->
( SDoc, -- declaration of any local vars
[SDoc], -- list of result vars (same length as results)
......@@ -1138,6 +1138,7 @@ type CLabelSet = FiniteMap CLabel (){-any type will do-}
emptyCLabelSet = emptyFM
x `elementOfCLabelSet` labs
= case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
addToCLabelSet set x = addToFM set x ()
type TEenv = (UniqSet Unique, CLabelSet)
......
......@@ -258,15 +258,16 @@ mkRecordSelId field_label selector_ty
[data_id] = mkTemplateLocals [data_ty]
alts = map mk_maybe_alt data_cons
the_alts = catMaybes alts
sel_rhs = mkTyLam tyvars $
mkValLam [data_id] $
Case (Var data_id)
-- if any of the constructors don't have the label, ...
(if any (not . isJust) alts then
AlgAlts (catMaybes alts)
(BindDefault data_id error_expr)
AlgAlts the_alts(BindDefault data_id error_expr)
else
AlgAlts (catMaybes alts) NoDefault)
AlgAlts the_alts NoDefault)
mk_maybe_alt data_con
= case maybe_the_arg_id of
......
......@@ -43,6 +43,7 @@ module Unique (
andandIdKey,
appendIdKey,
arrayPrimTyConKey,
assertIdKey,
augmentIdKey,
boolTyConKey,
boundedClassKey,
......@@ -708,4 +709,5 @@ toEnumClassOpKey = mkPreludeMiscIdUnique 68
\begin{code}
inlineIdKey = mkPreludeMiscIdUnique 69
coerceIdKey = mkPreludeMiscIdUnique 70
assertIdKey = mkPreludeMiscIdUnique 71
\end{code}
......@@ -502,13 +502,14 @@ constraints.
simplify_eqns :: [EquationInfo] -> [EquationInfo]
simplify_eqns [] = []
simplify_eqns ((EqnInfo n ctx pats result):qs) =
(EqnInfo n ctx(map simplify_pat pats) result) :
simplify_eqns qs
(EqnInfo n ctx pats' result) : simplify_eqns qs
where
pats' = map simplify_pat pats
simplify_pat :: TypecheckedPat -> TypecheckedPat
simplify_pat (WildPat gt ) = WildPat gt
simplify_pat (VarPat id) = WildPat (idType id)
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
simplify_pat (LazyPat p) = simplify_pat p
......@@ -535,11 +536,11 @@ simplify_pat (RecPat id ty idps) = ConPat id ty pats
pats = map (\ (id,p,_)-> simplify_pat p) idps
simplify_pat pat@(LitPat lit lit_ty)
| isUnboxedType lit_ty = LitPat lit lit_ty
| isUnboxedType lit_ty = pat
| lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
| otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
| otherwise = pat --pprPanic "tidy1:LitPat:" (ppr pat)
where
mk_char (HsChar c) = HsCharPrim c
......@@ -554,13 +555,20 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat
| lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
-- Convert the literal pattern "" to the constructor pattern [].
| null_str_lit lit = ConPat nilDataCon lit_ty []
| null_str_lit lit = ConPat nilDataCon lit_ty []
| one_str_lit lit = ConPat consDataCon list_ty
[ ConPat charDataCon lit_ty [LitPat (mk_head_char lit) charPrimTy]
, ConPat nilDataCon lit_ty []]
| otherwise = NPat lit lit_ty hsexpr
list_ty = mkListTy lit_ty
mk_int (HsInt i) = HsIntPrim i
mk_int l@(HsLitLit s) = l
mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
mk_char (HsChar c) = HsCharPrim c
mk_char l@(HsLitLit s) = l
......@@ -579,6 +587,9 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat
null_str_lit (HsString s) = _NULL_ s
null_str_lit other_lit = False
one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
one_str_lit other_lit = False
simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2
WildPat ty
where ty = panic "Check.simplify_pat: Never used"
......
......@@ -499,7 +499,9 @@ tidy1 v pat@(LitPat lit lit_ty) match_result
= returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
match_result)
| otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
| otherwise
--= pprPanic "tidy1:LitPat:" (ppr pat)
= returnDs (pat, match_result)
where
mk_char (HsChar c) = HsCharPrim c
......
......@@ -21,6 +21,7 @@ import DsMonad
import DsUtils
import Literal ( mkMachInt, Literal(..) )
import PrimRep ( PrimRep(IntRep) )
import Maybes ( catMaybes )
import Type ( Type, isUnpointedType )
import Util ( panic, assertPanic )
......@@ -72,8 +73,8 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t
mk_core_lit ty (HsStringPrim s) = MachStr s
mk_core_lit ty (HsFloatPrim f) = MachFloat f
mk_core_lit ty (HsDoublePrim d) = MachDouble d
mk_core_lit ty (HsLitLit s) = ASSERT(isUnpointedType ty)
MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
mk_core_lit ty (HsLitLit s) = --ASSERT(isUnpointedType ty)
MachLitLit s IntRep -- (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
......
......@@ -310,6 +310,7 @@ opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
opt_MultiParamClasses = opt_GlasgowExts
opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
......
......@@ -24,6 +24,7 @@ import Stix ( StixTree )
import Unique ( mkBuiltinUnique )
import Util ( mapAccumB, panic )
import GlaExts ( trace )
import Outputable
\end{code}
This is the generic register allocator.
......@@ -77,16 +78,18 @@ simpleRegAlloc
simpleRegAlloc _ _ _ [] = Just []
simpleRegAlloc free live env (instr:instrs)
= if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
Just (instr3 : instrs3)
else
Nothing
| null deadSrcs &&
maybeToBool newAlloc &&
maybeToBool instrs2
= Just (instr3 : instrs3)
| otherwise
= Nothing
where
instr3 = patchRegs instr (lookup env2)
(srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
(srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d)
lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
......@@ -108,14 +111,14 @@ simpleRegAlloc free live env (instr:instrs)
allocateNewReg _ Nothing = Nothing
allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
if null choices then Nothing
else Just (free2, prs2)
allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
| null choices = Nothing
| otherwise = Just (free2, prs2)
where
choices = possibleMRegs pk free
reg = head choices
free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
reg = head choices
free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
\end{code}
Here is the ``clever'' bit. First go backward (i.e. left), looking for
......@@ -129,15 +132,20 @@ hairyRegAlloc
-> [Instr]
-> [Instr]
hairyRegAlloc regs reserve_regs instrs
= case mapAccumB (doRegAlloc reserve_regs)
(RH regs' 1 emptyFM) noFuture instrs
of (RH _ loc' _, _, instrs') ->
if loc' == 1 then instrs' else
case mapAccumB do_RegAlloc_Nil
(RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
of ((RH _ loc'' _),_,instrs'') ->
if loc'' == loc' then instrs'' else panic "runRegAllocate"
hairyRegAlloc regs reserve_regs instrs =
case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of
(RH _ mloc1 _, _, instrs')
| mloc1 == 1 -> instrs'
| otherwise ->
let
instrs_patched' = patchMem instrs'
instrs_patched = flattenOrdList instrs_patched'
in
case mapAccumB do_RegAlloc_Nil (RH regs'' mloc1 emptyFM) noFuture instrs_patched of
((RH _ mloc2 _),_,instrs'')
| mloc2 == mloc1 -> instrs''
| otherwise -> instrs''
--pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1)
where
regs' = regs `useMRegs` reserve_regs
regs'' = mkMRegsState reserve_regs
......@@ -169,11 +177,12 @@ patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
patchMem' :: Instr -> InstrList
patchMem' instr
= if null memSrcs && null memDsts then mkUnitList instr
else mkSeqList
(foldr mkParList mkEmptyList loadSrcs)
(mkSeqList instr'
(foldr mkParList mkEmptyList spillDsts))
| null memSrcs && null memDsts = mkUnitList instr
| otherwise =
mkSeqList
(foldr mkParList mkEmptyList loadSrcs)
(mkSeqList instr'
(foldr mkParList mkEmptyList spillDsts))
where
(RU srcs dsts) = regUsage instr
......@@ -221,18 +230,26 @@ getUsage (RF next_in_use future reg_conflicts) instr
live_through = in_use `minusRegSet` dsts
last_used = [ r | r <- regSetToList srcs,
not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
in_use' = srcs `unionRegSets` live_through
reg_conflicts' = case new_conflicts of
[] -> reg_conflicts
_ -> addListToFM reg_conflicts new_conflicts
new_conflicts = if isEmptyRegSet live_dynamics then []
else [ (r, merge_conflicts r)
| r <- extractMappedRegNos (regSetToList dsts) ]
merge_conflicts reg = case lookupFM reg_conflicts reg of
Nothing -> live_dynamics
Just conflicts -> conflicts `unionRegSets` live_dynamics
live_dynamics = mkRegSet
[ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
reg_conflicts' =
case new_conflicts of
[] -> reg_conflicts
_ -> addListToFM reg_conflicts new_conflicts
new_conflicts
| isEmptyRegSet live_dynamics = []
| otherwise =
[ (r, merge_conflicts r)
| r <- extractMappedRegNos (regSetToList dsts) ]
merge_conflicts reg =
case lookupFM reg_conflicts reg of
Nothing -> live_dynamics
Just conflicts -> conflicts `unionRegSets` live_dynamics
live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
doRegAlloc'
:: [RegNo]
......@@ -273,18 +290,23 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst
Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
dynToStatic other = other
allocateNewRegs
:: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
allocateNewRegs :: Reg
-> (MRegsState, Int, [(Reg, Reg)])
-> (MRegsState, Int, [(Reg, Reg)])
allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
where (fs', f, mem') = case acceptable fs of
[] -> (fs, MemoryReg mem pk, mem + 1)
(IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
acceptable regs = filter no_conflict (possibleMRegs pk regs)
no_conflict reg = case lookupFM conflicts reg of
Nothing -> True
Just conflicts -> not (d `elementOfRegSet` conflicts)
where
(fs', f, mem') =
case acceptable fs of
[] -> (fs, MemoryReg mem pk, mem + 1)
(IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
acceptable regs = filter no_conflict (possibleMRegs pk regs)
no_conflict reg =
case lookupFM conflicts reg of
Nothing -> True
Just conflicts -> not (d `elementOfRegSet` conflicts)
\end{code}
We keep a local copy of the Prelude function \tr{notElem},
......
......@@ -1083,6 +1083,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
-- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
where
imul_div fn x y = getRegister (StCall fn IntRep [x, y])
......
......@@ -389,6 +389,7 @@ mpData_mantissa = mpData mantissa
Support for the Gnu GMP multi-precision package.
\begin{code}
-- size (in words) of __MP_INT
mpIntSize = 3 :: Int
mpAlloc, mpSize, mpData :: StixTree -> StixTree
......@@ -406,6 +407,7 @@ mpSpace gmp res sizes
= foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
where
sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
-- what's the magical 17 for?
fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
\end{code}
......
......@@ -7,6 +7,7 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
#include "HsVersions.h"
import Char ( ord )
import MachMisc
import MachRegs
......@@ -28,9 +29,6 @@ import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, UniqSM )
import Outputable
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
#endif
\end{code}
The main honcho here is primCode, which handles the guts of COpStmts.
......@@ -407,6 +405,22 @@ primCode [lhs] MakeStablePtrOp args
\begin{code}
primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
primCode [lhs] SeqOp [a]
= let
{-
The evaluation of seq#'s argument is done by `seqseqseq',
here we just set up the call to it (identical to how
DerefStablePtr does things.)
-}
lhs' = amodeToStix lhs
a' = amodeToStix a
pk = getAmodeRep lhs -- an IntRep
call = StCall SLIT("SeqZhCode") pk [a']
assign = StAssign pk lhs' call
in
-- trace "SeqOp" $
returnUs (\xs -> assign : xs)
primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| otherwise
......
......@@ -964,6 +964,10 @@ dexp : MINUS kexp { $$ = mknegate($2); }
| kexp
;
/*
We need to factor out a leading let expression so we can set
inpat=TRUE when parsing (non let) expressions inside stmts and quals
*/
expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
| oexpLno
;
......@@ -1172,7 +1176,7 @@ alts : alt { $$ = $1; }
| alts SEMI alt { $$ = lconc($1,$3); }
;
alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; }
alt : pat { PREVPATT = $1; } altrest { expORpat(LEGIT_PATT,$1); $$ = lsing($3); PREVPATT = NULL; }
| /* empty */ { $$ = Lnil; }
;
......@@ -1578,6 +1582,16 @@ vccurly1:
* *
**********************************************************************/
/*
void
checkinpat()
{
if(!inpat)
hsperror("pattern syntax used in expression");
}
*/
/* The parser calls "hsperror" when it sees a
`report this and die' error. It sets the stage
and calls "yyerror".
......
......@@ -21,7 +21,7 @@ module PrelInfo (
ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR,
ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
error_RDR, assert_RDR,
error_RDR, assertErr_RDR,
showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
......@@ -302,6 +302,7 @@ knownKeyNames
-- Others
, (otherwiseId_RDR, otherwiseIdKey)
, (assert_RDR, assertIdKey)
]
\end{code}
......@@ -421,7 +422,8 @@ times_RDR = varQual (pREL_BASE, SLIT("*"))
mkInt_RDR = varQual (pREL_BASE, SLIT("I#"))
error_RDR = varQual (pREL_ERR, SLIT("error"))
assert_RDR = varQual (pREL_ERR, SLIT("assert__"))
assert_RDR = varQual (pREL_GHC, SLIT("assert"))
assertErr_RDR = varQual (pREL_ERR, SLIT("assertError"))
eqH_Char_RDR = prelude_primop CharEqOp
ltH_Char_RDR = prelude_primop CharLtOp
......
......@@ -276,87 +276,37 @@ ifaceFlavour name = case getNameProvenance name of
Looking up a name in the RnEnv.
\begin{code}
lookupRn :: RdrName
-> Maybe Name -- Result of environment lookup
-> RnMS s Name
lookupRn rdr_name (Just name)
= -- Found the name in the envt
returnRn name -- In interface mode the only things in
-- the environment are things in local (nested) scopes
lookupRn rdr_name nm@Nothing
= tryLookupRn rdr_name nm `thenRn` \ name_or_error ->
case name_or_error of
Left (nm,err) -> failWithRn nm err
Right nm -> returnRn nm
tryLookupRn :: RdrName
-> Maybe Name -- Result of environment lookup
-> RnMS s (Either (Name, ErrMsg) Name)
tryLookupRn rdr_name (Just name)
= -- Found the name in the envt
returnRn (Right name) -- In interface mode the only things in
-- the environment are things in local (nested) scopes
-- lookup in environment, but don't flag an error if
-- name is not found.
tryLookupRn rdr_name Nothing
= -- We didn't find the name in the environment
getModeRn `thenRn` \ mode ->
case mode of {
SourceMode -> returnRn (Left ( mkUnboundName rdr_name
, unknownNameErr rdr_name));
-- Source mode; lookup failure is an error
InterfaceMode _ _ ->
----------------------------------------------------
-- OK, so we're in interface mode
-- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
-- So, qualify the unqualified name with the
-- module of the interface file, and try again
case rdr_name of
Unqual occ ->
getModuleRn `thenRn` \ mod ->
newImportedGlobalName mod occ HiFile `thenRn` \ nm ->
returnRn (Right nm)
Qual mod occ hif ->
newImportedGlobalName mod occ hif `thenRn` \ nm ->
returnRn (Right nm)
}
lookupRn :: NameEnv -> RdrName -> RnMS s Name
lookupRn name_env rdr_name
= case lookupFM name_env rdr_name of
-- Found it!
Just name -> returnRn name
-- Not found
Nothing -> getModeRn `thenRn` \ mode ->
case mode of
-- Not found when processing source code; so fail
SourceMode -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
-- Not found when processing an imported declaration,
-- so we create a new name for the purpose
InterfaceMode _ ->
case rdr_name of
Qual mod_name occ hif -> newGlobalName mod_name occ hif
-- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
newGlobalName mod_name occ HiFile
lookupBndrRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
lookupRn rdr_name maybe_name `thenRn` \ name ->
if isLocalName name then
returnRn name
else
----------------------------------------------------
-- OK, so we're at the binding site of a top-level defn
-- Check to see whether its an imported decl
getModeRn `thenRn` \ mode ->
case mode of {
SourceMode -> returnRn name ;
InterfaceMode _ print_unqual_fn ->
----------------------------------------------------
-- OK, the binding site of an *imported* defn
-- so we can make the provenance more informative
getSrcLocRn `thenRn` \ src_loc ->
let
name' = case getNameProvenance name of
NonLocalDef _ hif _ -> setNameProvenance name
(NonLocalDef src_loc hif (print_unqual_fn name'))
other -> name
in
returnRn name'