*/
SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */
-utils:basicTypes:types:hsSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
+utils:basicTypes:types:hsSyn:prelude:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
#ifdef MainIncludeDir
MAIN_INCLUDE_DIR=MainIncludeDir
# define loop_hi(f) CAT2(f,.hi)
#endif
-DELOOP_HIs = \
-utils/Ubiq.hi \
-absCSyn/AbsCLoop.hi \
-basicTypes/IdLoop.hi \
-codeGen/CgLoop1.hi \
-codeGen/CgLoop2.hi \
-deSugar/DsLoop.hi \
-hsSyn/HsLoop.hi \
-nativeGen/NcgLoop.hi \
-prelude/PrelLoop.hi \
-rename/RnLoop.hi \
-simplCore/SmplLoop.hi \
-typecheck/TcMLoop.hi \
-typecheck/TcLoop.hi \
-types/TyLoop.hi
+DELOOP_HIs = \
+loop_hi(utils/Ubiq) \
+loop_hi(absCSyn/AbsCLoop) \
+loop_hi(basicTypes/IdLoop) \
+loop_hi(codeGen/CgLoop1) \
+loop_hi(codeGen/CgLoop2) \
+loop_hi(deSugar/DsLoop) \
+loop_hi(hsSyn/HsLoop) \
+loop_hi(nativeGen/NcgLoop) \
+loop_hi(prelude/PrelLoop) \
+loop_hi(rename/RnLoop) \
+loop_hi(simplCore/SmplLoop) \
+loop_hi(typecheck/TcMLoop) \
+loop_hi(typecheck/TcLoop) \
+loop_hi(types/TyLoop)
/*
\
BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a)
+parser/hschooks.o : parser/hschooks.c
+ $(RM) $@
+ $(HC) -c -o $@ $(HCFLAGS) parser/hschooks.c
+
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
InstallBinaryTarget(hsc,$(INSTLIBDIR_GHC))
compile(hsSyn/HsBinds,lhs,)
compile(hsSyn/HsCore,lhs,)
compile(hsSyn/HsDecls,lhs,)
-compile(hsSyn/HsExpr,lhs,)
+compile(hsSyn/HsExpr,lhs,if_ghc(-K2m))
compile(hsSyn/HsImpExp,lhs,)
compile(hsSyn/HsLit,lhs,)
compile(hsSyn/HsMatches,lhs,)
compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR) if_ghc(-K2m))
compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/Stix,lhs,)
compile(nativeGen/StixInfo,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,)
-compile(rename/RnSource,lhs,)
+compile(rename/RnSource,lhs,-H12m)
compile(rename/RnBinds,lhs,)
compile(rename/RnExpr,lhs,)
compile(rename/RnIfaces,lhs,)
NormalLibraryTarget(hsp,$(HSP_OBJS_O))
/* We need the hsp program for hstags to work! */
-BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a)
+/* BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a) */
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
+#if GhcBuilderVersion < 200
+/* this will go away soon enough... (once 1.3 is settled in) */
+MKDEPENDHS = mkdependHS-1.2
+#endif
+
#if GhcWithHscBuiltViaC == NO
MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#else /* booting from .hc */
isTopLevId,
isTupleCon,
isWorkerId,
+ isWrapperId,
toplevelishId,
unfoldingUnfriendlyId,
getIdUnfolding,
getIdUpdateInfo,
getPragmaInfo,
+ replaceIdInfo,
-- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False
-{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
--}
\end{code}
\begin{code}
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
+unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
{-LATER:
unfoldingUnfriendlyId id
getIdInfo (Id _ _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ _ info _) = info
-{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id
-replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
+replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
+{-LATER:
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
indicatesWorker :: [Demand] -> Bool
indicatesWorker dems
- = fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
+ = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
where
fake_mk_ww _ [] = False
fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} )
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- instance for specializing only
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
-> Name -- from which we get provenance, etc....
-> Name -- result!
-mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
+mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
+ = Local u str True{-emph uniq-} locn
+
mkCompoundName u m str ns (Global _ _ _ prov exp _)
= Global u m (Right (Right str : ns)) prov exp []
mkTupNameStr 0 = SLIT("()")
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
-mkTupNameStr 3 = SLIT("(,,)") -- ditto
-mkTupNameStr 4 = SLIT("(,,,)") -- ditto
+mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
+mkTupNameStr 3 = _PK_ "(,,)" -- ditto
+mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
mkTupNameStr n
= _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
\begin{code}
instance Outputable SrcLoc where
ppr PprForUser (SrcLoc src_file src_line)
- = ppBesides [ ppChar '"', ppPStr src_file, ppPStr SLIT("\", line "), ppPStr src_line ]
+ = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
ppr sty (SrcLoc src_file src_line)
= ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
liftTyConKey,
listTyConKey,
ltDataConKey,
- mainIdKey,
- mainPrimIOIdKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
integerZeroIdKey = mkPreludeMiscIdUnique 15
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
lexIdKey = mkPreludeMiscIdUnique 17
-mainIdKey = mkPreludeMiscIdUnique 18
-mainPrimIOIdKey = mkPreludeMiscIdUnique 19
noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgClosure]{Code generation for closures}
import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre
)
import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep,
)
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
+import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
+import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
import Unpretty ( uppShow )
-import Util ( isIn, panic, pprPanic, assertPanic )
+import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
body_code = profCtrC SLIT("ENT_THK") [] `thenC`
- enterCostCentreCode closure_info cc IsThunk `thenC`
- thunkWrapper closure_info (cgExpr body)
+ thunkWrapper closure_info (
+ -- We only enter cc after setting up update so that cc
+ -- of enclosing scope will be recorded in update frame
+ -- CAF/DICT functions will be subsumed by this enclosing cc
+ enterCostCentreCode closure_info cc IsThunk `thenC`
+ cgExpr body)
stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
-#ifdef DEBUG
+--#ifdef DEBUG
deriving Eq
-#endif
+--#endif
enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
ASSERT(not (noCostCentreAttached cc))
if costsAreSubsumed cc then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsFunction)
+ --ASSERT(isToplevClosure closure_info)
+ --ASSERT(is_thunk == IsFunction)
+ (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then
let
emit_gran_macros = opt_GranMacros
in
- -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
- -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
(if emit_gran_macros
then if node_points
then fetchAndReschedule [] node_points
stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
- -- Must be after stackCheck: if stchk fails new stack
- -- space has to be allocated from the heap
+ -- heapCheck must be after stackCheck: if stchk fails
+ -- new stack space is allocated from the heap which
+ -- would violate any previous heapCheck
- heapCheck [] node_points (
- -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ heapCheck [] node_points ( -- heapCheck *encloses* the rest
+ -- The "[]" says there are no live argument registers
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info `thenC`
- -- Push update frame if necessary
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
- thunk_code
+ setupUpdate closure_info ( -- setupUpdate *encloses* the rest
+
+ -- Finally, do the business
+ thunk_code
)))
funWrapper :: ClosureInfo -- Closure whose code body this is
then yield arg_regs node_points
else absC AbsCNop) `thenC`
- stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
+ stackCheck closure_info arg_regs node_points (
+ -- stackCheck *encloses* the rest
- -- Heap overflow check
heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
+ -- heapCheck *encloses* the rest
-- Finally, do the business
fun_body
#include "HsVersions.h"
module CgMonad (
- Code(..), -- type
- FCode(..), -- type
+ SYN_IE(Code), -- type
+ SYN_IE(FCode), -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC,
- SemiTaggingStuff(..),
+ SYN_IE(SemiTaggingStuff),
addBindC, addBindsC, modifyBindC, lookupBindC,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage(..), BStackUsage(..), HeapUsage(..),
+ SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
StubFlag,
isStubbed,
import Maybes ( assocMaybe, maybeToBool )
import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
+import PprType ( getTyDescription, GenType{-instance Outputable-} )
import Pretty--ToDo:rm
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
mkFunTys, maybeAppSpecDataTyConExpandingDicts
)
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
-
-getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code}
The ``wrapper'' data type for closure information:
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- (tycon, _, _) = trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty
+ (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
+ getAppDataTyConExpandingDicts scrut_ty
size_up_alts _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
])
ppr_expr pe (Case expr alts)
+ | only_one_alt alts
+ -- johan thinks that single case patterns should be on same line as case,
+ -- and no indent; all sane persons agree with him.
+ = let
+ ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
+ ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
+ = ppCat [ppr_alt_con con (pCon pe con),
+ ppInterleave ppSP (map (pMinBndr pe) params),
+ ppStr "->"]
+
+ ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
+ ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
+ in
+ ppSep
+ [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
+ ppBeside (ppr_rhs alts) (ppStr "}")]
+
+ | otherwise -- default "case" printing
= ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
where
pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
+
+only_one_alt (AlgAlts [] (BindDefault _ _)) = True
+only_one_alt (AlgAlts (_:[]) NoDefault) = True
+only_one_alt (PrimAlts [] (BindDefault _ _)) = True
+only_one_alt (PrimAlts (_:[]) NoDefault) = True
+only_one_alt _ = False
+
+ppr_alt_con con pp_con
+ = if isSymLexeme con then ppParens pp_con else pp_con
\end{code}
\begin{code}
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
- ppCat [ppr_con con (pCon pe con),
+ ppCat [ppr_alt_con con (pCon pe con),
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
4 (ppr_expr pe expr)
- where
- ppr_con con pp_con
- = if isSymLexeme con then ppParens pp_con else pp_con
ppr_alts pe (PrimAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
- tyVarsOfType, tyVarsOfTypes
+ tyVarsOfType, tyVarsOfTypes, isDictTy
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
import PprType ( GenTyVar ) --ToDo:rm
import Usage--ToDo:rm
import Unique--ToDo:rm
-
-isDictTy = panic "DsBinds.isDictTy"
\end{code}
%************************************************************************
module HsCore (
UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
+ UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType),
UnfoldingPrimOp(..), UfCostCentre(..)
) where
-- this module tells about "real Haskell"
EXP_MODULE(HsSyn) ,
-#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING
EXP_MODULE(HsBinds) ,
EXP_MODULE(HsDecls) ,
EXP_MODULE(HsExpr) ,
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
EXP_MODULE(HsTypes)
-#else
- ArithSeqInfo(..),
- BangType(..),
- Bind(..),
- ClassDecl(..),
- ConDecl(..),
- DefaultDecl(..),
- FixityDecl(..),
- GRHS(..),
- GRHSsAndBinds(..),
- HsBinds(..),
- HsExpr(..),
- HsLit(..),
- IE(..),
- ImportDecl(..),
- InPat(..),
- InstDecl(..),
- Match(..),
- MonoBinds(..),
- MonoType(..),
- OutPat(..),
- PolyType(..),
- Qualifier(..),
- Sig(..),
- SpecDataSig(..),
- SpecInstSig(..),
- Stmt(..),
- TyDecl(..),
- bindIsRecursive,
- cmpContext,
- cmpMonoType,
- cmpPolyType,
- collectBinders,
- collectMonoBinders,
- collectMonoBindersAndLocs,
- collectPatBinders,
- collectTopLevelBinders,
- extractCtxtTyNames,
- extractMonoTyNames,
- failureFreePat,
- irrefutablePat,
- irrefutablePats,
- isConPat,
- isLitPat,
- negLiteral,
- nullBind,
- nullBinds,
- nullMonoBinds,
- patsAreAllCons,
- patsAreAllLits,
- pp_condecls,
- pp_decl_head,
- pp_dotdot,
- pp_rbinds,
- pp_tydecl,
- pprContext,
- pprExpr,
- pprGRHS,
- pprGRHSsAndBinds,
- pprMatch,
- pprMatches,
- pprParendExpr,
- pprParendMonoType,
- pprParendPolyType,
- ppr_bang,
- print_it,
- SYN_IE(ClassAssertion),
- SYN_IE(Context),
- SYN_IE(HsRecordBinds)
-#endif
) where
IMP_Ubiq()
opt_GranMacros,
opt_Haskell_1_3,
opt_HiMap,
- opt_HideBuiltinNames,
- opt_HideMostBuiltinNames,
opt_IgnoreIfacePragmas,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
opt_GranMacros = lookUp SLIT("-fgransim")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3")
-opt_HideBuiltinNames = lookUp SLIT("-fhide-builtin-names")
-opt_HideMostBuiltinNames = lookUp SLIT("-fmin-builtin-names")
opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
renameModule rn_uniqs rdr_module >>=
\ (rn_mod, rn_env, import_names,
- export_fn, usage_stuff,
+ export_stuff, usage_stuff,
rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
startIface mod_name >>= \ if_handle ->
ifaceUsages if_handle usages_map >>
ifaceVersions if_handle version_info >>
- ifaceExportList if_handle export_fn rn_mod >>
+ ifaceExportList if_handle export_stuff rn_env >>
ifaceFixities if_handle rn_mod >>
ifaceInstanceModules if_handle instance_modules >>
import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
-import Id ( idType, dataConRawArgTys, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
import Maybes ( maybeToBool )
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- isLexSym, isLocallyDefined, isWiredInName,
+ isLexSym, isLexCon, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
OrigName(..){-instance Ord-},
Name{-instance NamedThing-}
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
--import PrelMods ( modulesWithBuiltins )
-import PrelInfo ( builtinNameInfo )
+import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
import Pretty ( prettyToUn )
import Unpretty -- ditto
-import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName{-instance NamedThing-} )
+import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
+import RnUtils ( SYN_IE(RnEnv), pprRnEnv{-ToDo:rm-} )
import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
-> IO ()
ifaceExportList
:: Maybe Handle
- -> (Name -> ExportFlag)
- -> RenamedHsModule
+ -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
+ -> RnEnv
-> IO ()
ifaceFixities
:: Maybe Handle
Export list: grab the Names of things that are marked Exported, sort
(so the interface file doesn't ``wobble'' from one compilation to the
-next...), and print. Note that the ``module'' now contains all the
-imported things that we are dealing with, thus including any entities
-that we are re-exporting from somewhere else.
+next...), and print. We work from the renamer's final ``RnEnv'',
+which has all the names we might possibly be interested in.
+(Note that the ``module X'' export items can cause a lot of grief.)
\begin{code}
ifaceExportList Nothing{-no iface handle-} _ _ = return ()
ifaceExportList (Just if_hdl)
- export_fn -- sadly, just the HsModule isn't enough,
- -- because it will have no record of exported
- -- wired-in names.
- (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
+ (export_fn, (dotdot_vals, dotdot_tcs))
+ rn_env@((qual, unqual, tc_qual, tc_unqual), _)
= let
- (vals_wired, tcs_wired)
- = case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) ->
- (eltsFM vals_fm, eltsFM tcs_fm) }
-
name_flag_pairs :: FiniteMap OrigName ExportFlag
name_flag_pairs
- = foldr (from_wired True{-val-ish-})
- (foldr (from_wired False{-tycon-ish-})
- (foldr from_ty
- (foldr from_cls
- (foldr from_sig
- (from_binds binds emptyFM{-init accum-})
- sigs)
- classdecls)
- typedecls)
- tcs_wired)
- vals_wired
+ = foldr (from_wired True{-val-ish-})
+ (foldr (from_wired False{-tycon-ish-})
+ (foldr (from_dotdot True{-val-ish-})
+ (foldr (from_dotdot False{-tycon-ish-})
+ (foldr from_val
+ (foldr from_val
+ (foldr from_tc
+ (foldr from_tc emptyFM{-init accum-}
+ (eltsFM tc_unqual))
+ (eltsFM tc_qual))
+ (eltsFM unqual))
+ (eltsFM qual))
+ dotdot_tcs)
+ dotdot_vals)
+ (eltsFM builtinTcNamesMap))
+ (eltsFM builtinValNamesMap)
sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
in
+ --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
hPutStr if_hdl "\n__exports__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
where
- from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TySynonym n _ _ _) acc = maybe_add acc n
+ from_val rn acc
+ | fun_looking rn && exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_val" n
- from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
- from_sig (Sig n _ _ _) acc = maybe_add acc n
+ from_tc rn acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_tc" n
- from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
+ from_dotdot is_valish (n,ef) acc
+ | is_valish && isLexCon str = acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ on = origName "from_dotdot" n
+ (OrigName _ str) = on
- --------------
from_wired is_val_ish rn acc
- | on_in_acc = acc -- if already in acc (presumably from real decl),
- -- don't take the dubious export flag from the
- -- wired-in chappy
- | is_val_ish && isRnConstr rn
+ | is_val_ish && not (fun_looking rn)
= acc -- these things don't cause export-ery
| exportFlagOn ef = addToFM acc on ef
| otherwise = acc
n = getName rn
ef = export_fn n
on = origName "from_wired" n
- (OrigName _ str) = on
- on_in_acc = maybeToBool (lookupFM acc on)
-
- --------------
- maybe_add :: FiniteMap OrigName ExportFlag -> RnName -> FiniteMap OrigName ExportFlag
-
- maybe_add acc rn
- | on_in_acc = trace "maybe_add?" acc -- surprising!
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = nameExportFlag n
- n = getName rn
- on = origName "maybe_add" n
- on_in_acc = maybeToBool (lookupFM acc on)
-
- --------------
- maybe_add_list acc [] = acc
- maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
--------------
lexical_lt (n1,_) (n2,_) = n1 < n2
MOV L (OpImm (ImmCLbl lbl))
-- this is hardwired
(OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ JMP (OpImm (ImmLit (uppPStr (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
LABEL lbl]
in
returnInstrs call
IMP_Ubiq(){-uitious-}
IMPORT_1_3(Char(isPrint,isDigit))
IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
-#if __GLASGOW_HASKELL__ >= 200
-# define A_HASH GHCbase.A#
-#else
-# define A_HASH A#
-#endif
import MachRegs -- may differ per-platform
import MachMisc
import OrdList ( OrdList )
import Stix ( CodeSegment(..), StixTree )
import Unpretty -- all of it
+
+#if __GLASGOW_HASKELL__ >= 200
+a_HASH x = GHCbase.A# x
+pACK_STR x = packCString x
+#else
+a_HASH x = A# x
+pACK_STR x = _packCString x
+#endif
\end{code}
%************************************************************************
pprImm (LO i)
= uppBesides [ pp_lo, pprImm i, uppRparen ]
where
- pp_lo = uppPStr (_packCString (A_HASH "%lo("#))
+ pp_lo = uppPStr (pACK_STR (a_HASH "%lo("#))
pprImm (HI i)
= uppBesides [ pp_hi, pprImm i, uppRparen ]
where
- pp_hi = uppPStr (_packCString (A_HASH "%hi("#))
+ pp_hi = uppPStr (pACK_STR (a_HASH "%hi("#))
#endif
\end{code}
= uppPStr
IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
- ,IF_ARCH_i386(SLIT(".text\n\t.align 2,0x90") {-needs per-OS variation!-}
+ ,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
where
pp_lab = pprCLabel_asm clab
-#if __GLASGOW_HASKELL__ >= 200
-# define PACK_STR packCString
-#else
-# define PACK_STR _packCString
-#endif
- pp_ldgp = uppPStr (PACK_STR (A_HASH ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (PACK_STR (A_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+ pp_ldgp = uppPStr (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = uppPStr (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
pprInstr (FUNEND clab)
= uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
pprReg reg1
]
-pp_ld_lbracket = uppPStr (PACK_STR (A_HASH "\tld\t["#))
-pp_rbracket_comma = uppPStr (PACK_STR (A_HASH "],"#))
-pp_comma_lbracket = uppPStr (PACK_STR (A_HASH ",["#))
-pp_comma_a = uppPStr (PACK_STR (A_HASH ",a"#))
+pp_ld_lbracket = uppPStr (pACK_STR (a_HASH "\tld\t["#))
+pp_rbracket_comma = uppPStr (pACK_STR (a_HASH "],"#))
+pp_comma_lbracket = uppPStr (pACK_STR (a_HASH ",["#))
+pp_comma_a = uppPStr (pACK_STR (a_HASH ",a"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
returnUgn, thenUgn,
-- stuff defined in utils module
-#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING
EXP_MODULE(UgenUtil) ,
-- re-exported ugen-generated stuff
EXP_MODULE(U_qid) ,
EXP_MODULE(U_tree) ,
EXP_MODULE(U_ttype)
-#else
- SYN_IE(ParseTree),
- SYN_IE(U_VOID_STAR),
- U_binding (..),
- U_constr (..),
- U_either (..),
- U_entidt (..),
- SYN_IE(U_hstring),
- U_list (..),
- U_literal (..),
- SYN_IE(U_long),
- U_maybe (..),
- SYN_IE(U_numId),
- U_pbinding (..),
- U_qid (..),
- SYN_IE(U_stringId),
- U_tree (..),
- U_ttype (..),
- SYN_IE(UgnM),
- getSrcFileUgn,
- getSrcLocUgn,
- getSrcModUgn,
- initUgn,
- ioToUgnM,
- mkSrcLocUgn,
- rdU_VOID_STAR,
- rdU_binding,
- rdU_constr,
- rdU_either,
- rdU_entidt,
- rdU_hstring,
- rdU_list,
- rdU_literal,
- rdU_long,
- rdU_maybe,
- rdU_numId,
- rdU_pbinding,
- rdU_qid,
- rdU_stringId,
- rdU_tree,
- rdU_ttype,
- setSrcFileUgn,
- setSrcModUgn
-#endif
) where
import PreludeGlaST
#define I_ long int
void
-ErrorHdrHook (where)
- FILE *where;
+ErrorHdrHook (FILE *where)
{
fprintf(where, "\n"); /* no "Fail: " */
}
void
-OutOfHeapHook (request_size, heap_size)
- W_ request_size; /* in bytes */
- W_ heap_size; /* in bytes */
+OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */
{
fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
request_size,
}
void
-StackOverflowHook (stack_size)
- I_ stack_size; /* in bytes */
+StackOverflowHook (I_ stack_size) /* in bytes */
{
fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
}
-#if 0
-/* nothing to add here, really */
void
-MallocFailHook (request_size, msg)
- I_ request_size; /* in bytes */
- char *msg;
-{
- fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
-}
-#endif /* 0 */
-
-void
-PatErrorHdrHook (where)
- FILE *where;
+PatErrorHdrHook (FILE *where)
{
fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
}
void
-PreTraceHook (where)
- FILE *where;
+PreTraceHook (FILE *where)
{
fprintf(where, "\n"); /* not "Trace On" */
}
void
-PostTraceHook (where)
- FILE *where;
+PostTraceHook (FILE *where)
{
fprintf(where, "\n"); /* not "Trace Off" */
}
module PrelInfo (
-- finite maps for built-in things (for the renamer and typechecker):
- builtinNameInfo, SYN_IE(BuiltinNames),
+ builtinNameInfo, builtinNameMaps,
+ builtinValNamesMap, builtinTcNamesMap,
+ builtinKeysMap,
+ SYN_IE(BuiltinNames),
SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos),
maybeCharLikeTyCon, maybeIntLikeTyCon
import TysWiredIn
-- others:
-import CmdLineOpts ( opt_HideBuiltinNames,
- opt_HideMostBuiltinNames,
- opt_ForConcurrent
- )
import FiniteMap ( FiniteMap, emptyFM, listToFM )
import Id ( mkTupleCon, GenId, SYN_IE(Id) )
import Maybes ( catMaybes )
type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids
-builtinNameInfo
- = if opt_HideBuiltinNames then
- (
- (emptyFM, emptyFM),
- emptyFM,
- emptyUFM
- )
- else if opt_HideMostBuiltinNames then
- (
- (listToFM min_assoc_val_wired, listToFM min_assoc_tc_wired),
- emptyFM,
- emptyUFM
- )
- else
- (
- (listToFM assoc_val_wired, listToFM assoc_tc_wired),
- listToFM assoc_keys,
- listToUFM assoc_id_infos
- )
+builtinNameMaps = case builtinNameInfo of { (x,_,_) -> x }
+builtinKeysMap = case builtinNameInfo of { (_,x,_) -> x }
+builtinValNamesMap = fst builtinNameMaps
+builtinTcNamesMap = snd builtinNameMaps
+builtinNameInfo
+ = ( (listToFM assoc_val_wired, listToFM assoc_tc_wired)
+ , listToFM assoc_keys
+ , listToUFM assoc_id_infos
+ )
where
- min_assoc_val_wired -- min needed when compiling bits of Prelude
- = concat [
- -- data constrs
- concat (map pcDataConWiredInInfo g_con_tycons),
- concat (map pcDataConWiredInInfo min_nonprim_tycon_list),
-
- -- values
- map pcIdWiredInInfo wired_in_ids,
- primop_ids
- ]
- min_assoc_tc_wired
- = concat [
- -- tycons
- map pcTyConWiredInInfo prim_tycons,
- map pcTyConWiredInInfo g_tycons,
- map pcTyConWiredInInfo min_nonprim_tycon_list
- ]
-
assoc_val_wired
= concat [
-- data constrs
= mkFunTyCon : g_con_tycons
g_con_tycons
- = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ]
-
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
- = [ boolTyCon
- , charTyCon
- , intTyCon
- , floatTyCon
- , doubleTyCon
- , integerTyCon
- , liftTyCon
- , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
- , returnIntAndGMPTyCon
- ]
-
+ = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
data_tycons
= [ addrTyCon
\begin{code}
id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)]
id_keys_infos
- = [ -- here so we can check the type of main/mainPrimIO
- (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing)
- , (OrigName SLIT("GHCmain") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing)
-
- -- here because we use them in derived instances
- , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
+ = [ -- here because we use them in derived instances
+ (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
, (OrigName pRELUDE SLIT("."), composeIdKey, Nothing)
, (OrigName gHC__ SLIT("lex"), lexIdKey, Nothing)
, (OrigName pRELUDE SLIT("not"), notIdKey, Nothing)
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
-import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
+import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
import PrefixToHs
import PprStyle ( PprStyle(..) )
import PrelMods ( pRELUDE )
import Pretty
-import SrcLoc ( SrcLoc )
+import SrcLoc ( mkBuiltinSrcLoc, SrcLoc )
import Util ( nOfThem, pprError, panic )
\end{code}
imports
fixities
tydecls
- tysigs
+ tysigs
classdecls
instdecls
instsigs
defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
+ (add_main_sig modname (cvSepdBinds srcfile cvValSig binds))
[{-no interface sigs yet-}]
src_loc
)
+ where
+ add_main_sig modname binds
+ = if modname == SLIT("Main") then
+ let
+ s = Sig (Unqual SLIT("main")) (io_ty SLIT("IO")) noGenPragmas mkBuiltinSrcLoc
+ in
+ add_sig binds s
+
+ else if modname == SLIT("GHCmain") then
+ let
+ s = Sig (Unqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) noGenPragmas mkBuiltinSrcLoc
+ in
+ add_sig binds s
+
+ else -- add nothing
+ binds
+ where
+ add_sig (SingleBind b) s = BindWith b [s]
+ add_sig (BindWith b ss) s = BindWith b (s:ss)
+ add_sig _ _ = panic "rdModule:add_sig"
+
+ io_ty t = HsForAllTy [] [] (MonoTyApp (Unqual t) [MonoTupleTy []])
\end{code}
%************************************************************************
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
where
in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (x:_) | isAlpha x = is_var_sym
+ in_the_club (x:y) | isAlpha x = is_var_sym
| is_sym_sym x = is_sym_sym
| x == '[' = is_list_sym
| x == '(' = is_tuple_sym
- | otherwise = panic ("lex_word:in_the_club="++[x])
+ | otherwise = panic ("lex_word:in_the_club="++(x:y))
module_dot (c:cs)
= if not (isUpper c) || c == '\'' then
Name, RdrName(..), ExportFlag(..)
)
import PprStyle -- ToDo:rm
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import Pretty -- ToDo:rm
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
RnEnv, -- final env (for renaming derivings)
[Module], -- imported modules; for profiling
- Name -> ExportFlag, -- export info
+ (Name -> ExportFlag, -- export info
+ ([(Name,ExportFlag)],
+ [(Name,ExportFlag)])),
+
(UsagesMap,
VersionsMap, -- version info; for usage
[Module]), -- instance modules; for iface
\begin{code}
renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
- = let
- (b_names, b_keys, _) = builtinNameInfo
+ = {-
+ let
pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
in
- {-
- pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) ->
ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
, ppCat (map pp_pair (keysFM builtin_tcs))
- , ppCat (map pp_pair (keysFM b_keys))
+ , ppCat (map pp_pair (keysFM builtinKeysMap))
]}) $
-}
+-- _scc_ "rnGlobalNames"
makeHiMap opt_HiMap >>= \ hi_files ->
-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
initIfaceCache modname hi_files >>= \ iface_cache ->
- fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
+ fixIO ( \ ~(_, _, _, _, rec_occ_fm, ~(rec_export_fn,_)) ->
let
rec_occ_fn :: Name -> [RdrName]
rec_occ_fn n = case lookupUFM rec_occ_fm n of
Nothing -> []
Just (rn,occs) -> occs
- global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
+ global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn)
in
getGlobalNames iface_cache global_name_info us1 input >>=
\ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
else
-- No top-level name errors so rename source ...
+-- _scc_ "rnSource"
case initRn True modname occ_env us2
(rnSource imp_mods unqual_imps imp_fixes input) of {
- ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
+ ((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
--pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
-
let
occ_fm :: UniqFM (RnName, [RdrName])
GT__ -> x : insert new xs
occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
- multiple_occs (rn, (o1:o2:_)) = True
+
+ multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate")
+ -- the user is rarely responsible if
+ -- "negate" is mentioned in multiple ways
multiple_occs _ = False
in
return (rn_module, imp_mods,
top_errs `unionBags` src_errs,
top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
- occ_fm, export_fn)
+ occ_fm, (export_fn, module_dotdots))
- }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_fn) ->
+ }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) ->
if not (isEmptyBag errs_so_far) then
return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
else
-- No errors renaming source so rename the interfaces ...
+-- _scc_ "preRnIfaces"
let
-- split up all names that occurred in the source; between
-- those that are defined therein and those merely mentioned.
= [{-no Prelude.hi, no point looking-}]
| otherwise
= [ name_fn (mkWiredInName u orig ExportAll)
- | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys,
- str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
+ | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
in
-- ASSERT (isEmptyBag orig_occ_dups)
(if (isEmptyBag orig_occ_dups) then \x->x
else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
ASSERT (isEmptyBag orig_def_dups)
+-- _scc_ "rnIfaces"
rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
- rn_module (must_haves ++ imports_used) >>=
+ rn_module (must_haves {-initMustHaves-} ++ imports_used) >>=
\ (rn_module_with_imports, final_env,
(implicit_val_fm, implicit_tc_fm),
usage_stuff,
return (rn_module_with_imports,
final_env,
imp_mods,
- export_fn,
+ export_stuff,
usage_stuff,
errs_so_far `unionBags` iface_errs,
warns_so_far `unionBags` iface_warns)
(us1, us') = splitUniqSupply us
(us2, us3) = splitUniqSupply us'
+
+initMustHaves :: [RnName]
+ -- things we *must* find declarations for, because the
+ -- compiler may eventually make reference to them (e.g.,
+ -- class Eq)
+initMustHaves
+ | opt_NoImplicitPrelude
+ = [{-no Prelude.hi, no point looking-}]
+ | otherwise
+ = [ name_fn (mkWiredInName u orig ExportAll)
+ | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
\end{code}
\begin{code}
rnTopBinds,
rnMethodBinds,
rnBinds,
- FreeVars(..),
- DefinedVars(..)
+ SYN_IE(FreeVars),
+ SYN_IE(DefinedVars)
) where
IMP_Ubiq()
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
import ErrUtils ( addErrLoc, addShortErrLocLine )
-import Name ( RdrName )
+import Name ( getLocalName, RdrName )
import Maybes ( catMaybes )
import PprStyle--ToDo:rm
import Pretty
-- Discard unbound ones we've already complained about, so we
-- complain about duplicate ones.
- (goodies, dups) = removeDups compare (filter not_unbound sigs')
+ (goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
in
mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
lookupValue v `thenRn` \ new_v ->
returnRn (Just (MagicUnfoldingSig new_v str src_loc))
- not_unbound :: RenamedSig -> Bool
+ not_unbound, not_main :: RenamedSig -> Bool
not_unbound (Sig n _ _ _) = not (isRnUnbound n)
not_unbound (SpecSig n _ _ _) = not (isRnUnbound n)
not_unbound (DeforestSig n _) = not (isRnUnbound n)
not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
+ not_main (Sig n _ _ _) = let str = getLocalName n in
+ not (str == SLIT("main") || str == SLIT("mainPrimIO"))
+ not_main _ = True
+
-------------------------------------
sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
-- Return "Just x" if "x" has no type signature in
isLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
import Pretty
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
initIfaceCache mod hi_files
= newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
- return (IfaceCache mod b_names iface_var)
- where
- b_names = case builtinNameInfo of (b_names,_,_) -> b_names
+ return (IfaceCache mod builtinNameMaps iface_var)
\end{code}
*********************************************************
Just _ -> True
Nothing -> -- maybe it's builtin
let orig = qualToOrigName nm in
- case (lookupFM b_tc_names orig) of
+ case (lookupFM builtinTcNamesMap orig) of
Just _ -> True
- Nothing -> maybeToBool (lookupFM b_keys orig)
-
- (b_tc_names, b_keys) -- pretty UGLY ...
- = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
-{-
- ppr_insts insts
- = ppAboves (map ppr_inst insts)
- where
- ppr_inst (InstSig c t _ inst_decl)
- = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
--}
+ Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
\end{code}
\begin{code}
= ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
badIfaceLookupErr msg name decl sty
- = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+ = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
ifaceIoErr io_msg rn sty
= ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
OrigName(..), Name, mkLocalName, mkImplicitName,
getOccName, pprNonSym
)
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE )
import PprStyle{-ToDo:rm-}
import Outputable{-ToDo:rm-}
mode = if source then
RnSource occ_var
else
- case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
- RnIface wiredin_fm key_fm imp_var }
+ RnIface builtinNameMaps builtinKeysMap imp_var
rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
in
import RnMonad
import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
-import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr
+import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
+ lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
)
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
- unionManyBags, mapBag, filterBag, listToBag, bagToList )
+ unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
nameExportFlag, nameImportFlag,
getLocalName, getSrcLoc, getImpLocs,
moduleNamePair, pprNonSym,
- isLexCon, ExportFlag(..), OrigName(..)
+ isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
)
import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
- (src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs
+ (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
(all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
-- remove dups of the same imported thing
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
+-- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
+-- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
+-- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
\end{code}
imp_errs `unionBags` errs,
imp_warns `unionBags` warns)
where
- the_imps = implicit_prel ++ src_imps
- all_imps = implicit_qprel ++ the_imps
+ all_imps = implicit_prel ++ src_imps
+-- all_imps = implicit_qprel ++ the_imps
- implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc
- : (if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc])
+ explicit_prelude_imp
+ = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
- explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
- mod == pRELUDE ])
-
- implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc
- : (if explicit_prelude_imp || opt_NoImplicitPrelude
- then [{- no "import Prelude" -}]
- else [ImportDecl pRELUDE False Nothing Nothing prel_loc])
+ implicit_prel | opt_NoImplicitPrelude = []
+ | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+ | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
- (uniq_imps, imp_dups) = removeDups cmp_mod the_imps
+ (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
where
has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec -- NB: a no-op ToDo:rm
- in
- (if mod == gHC_BUILTINS then
- return (Succeeded (panic "doImport:GHC fake import!"),
- \ iface -> ([], [], emptyBag))
- else
- --pprTrace "doImport:" (ppPStr mod) $
- cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
- return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
- ) >>= \ (maybe_iface, do_ies) ->
+ = --let
+ -- (b_vals, b_tcs, maybe_spec')
+ -- = (emptyBag, emptyBag, maybe_spec)
+ --in
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
+ return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
+ >>= \ (maybe_iface, do_ies) ->
case maybe_iface of
Failed err ->
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
let
- final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
- final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
+ fold_ies = foldBag unionBags pair_occ emptyBag
+
+ final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
+ final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
final_vals_list = bagToList final_vals
in
- (if mod == gHC_BUILTINS then
- return [ (Nothing, emptyBag) | _ <- final_vals_list ]
- else
- accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
- ) >>= \ fix_maybes_errs ->
+ accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
+ >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ :: RnName -> (RdrName, RnName)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
+ pair_occ :: RnName -> Bag (RdrName, RnName)
+ pair_occ rn
+ = let
+ str = getLocalName rn
+ qual_bag = unitBag (Qual as_mod str, rn)
+ in
+ if qual
+ then qual_bag
+ else qual_bag -- the qualified name is *also* visible
+ `snocBag` (Unqual str, rn)
+
pair_as :: RnName -> (Module, RnName)
pair_as rn = (as_mod, rn)
-----------------------------
+{-
getBuiltins :: ImportNameInfo
-> Module
-> Maybe (Bool, [RdrNameIE])
)
getBuiltins _ modname maybe_spec
---OLD: | modname `notElem` modulesWithBuiltins
+-- | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
-{-
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
mkAllIE (orig,ExportAbs)
- = ASSERT(isLexCon (nameOf orig))
+ = --ASSERT(isLexCon (nameOf orig))
+ -- the ASSERT is correct, but it is too easy to
+ -- trigger when writing .hi files by hand (e.g.
+ -- when hackily breaking a module loop)
IEThingAbs orig
mkAllIE (orig, ExportAll)
- | isLexCon (nameOf orig)
+ | isLexCon name_orig || isLexSpecialSym name_orig
= IEThingAll orig
| otherwise
= IEVar orig
+ where
+ name_orig = nameOf orig
------------
lookupIEs :: ExportsMap
where
avoided_fn Nothing -- the thing should be in the source
= (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Left rn)) -- a builtin value brought into scope
+ avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
= (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Right rn)) -- a builtin tc/class brought into scope
- = --pprTrace "avoided:Right:" (ppr PprShowAll rn) $
- (emptyBag, unitBag rn, emptyBag, emptyBag, emptyBag)
+ avoided_fn (Just (Right rn@(WiredInTyCon tc)))
+ -- a builtin tc brought into scope; we also must bring its
+ -- data constructors into scope
+ = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
+ (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
-------------------------
checkOrigIE :: IfaceCache
-> IO something
with_decl iface_cache n do_avoid do_err do_decl
- = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl ->
+ = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
case maybe_decl of
CachingAvoided info -> return (do_avoid info)
CachingFail err -> return (do_err err)
CachingHit decl -> return (do_decl decl)
+ where
+ n_name = nameOf n
-------------
getFixityDecl :: IfaceCache
import CmdLineOpts ( opt_CompilingGhcInternals )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
-import Id ( GenId{-instance NamedThing-} )
+import Id ( isDataCon, GenId{-instance NamedThing-} )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
-> RdrNameHsModule
-> RnM s (RenamedHsModule,
Name -> ExportFlag, -- export info
+ ([(Name, ExportFlag)], -- export module X stuff
+ [(Name, ExportFlag)]),
Bag (RnName, RdrName)) -- occurrence info
rnSource imp_mods unqual_imps imp_fixes
= pushSrcLocRn src_loc $
- rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
+ rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) ->
rnFixes fixes `thenRn` \ src_fixes ->
let
all_fixes = src_fixes ++ bagToList imp_fixes
new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds [] src_loc,
- exported_fn,
+ exported_fn, module_dotdots,
occ_info
)
where
rnExports :: [Module]
-> Bag (Module,RnName)
-> Maybe [RdrNameIE]
- -> RnM s (Name -> ExportFlag)
+ -> RnM s (Name -> ExportFlag, -- main export-flag fun
+ ([(Name,ExportFlag)], -- info about "module X" exports
+ [(Name,ExportFlag)])
+ )
rnExports mods unqual_imps Nothing
- = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+ = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
+ , ([], [])
+ )
rnExports mods unqual_imps (Just exps)
= getModuleRn `thenRn` \ this_mod ->
(uniq_mods, dup_mods) = removeDups cmpPString exp_mods
(expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
- -- Get names for module This_Mod export
+ -- Get names for "module This_Mod" export
(this_tcs, this_vals)
= if null expmods_this
then ([], [])
(unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
get_mod_names mod
- = (tcs, vals, empty_mod)
+ = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
+ (tcs, vals, empty_mod)
where
tcs = [(getName rn, nameImportFlag (getName rn))
| (mod',rn) <- unqual_tcs, mod == mod']
vals = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_vals, mod == mod']
+ | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
empty_mod = if null tcs && null vals
then Just mod
else Nothing
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
+
-- Build finite map of exported names to export flag
tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
- returnRn exp_fn
+ returnRn (exp_fn, (mod_vals, mod_tcs))
+
+------------------------------------
+-- rename an "IE" in the export list
+rnIE :: [Module] -- this module and all the (directly?) imported modules
+ -> RdrNameIE
+ -> RnM s (
+ Maybe Module, -- Just m => a "module X" export item
+ (Bag (Name, ExportFlag), -- Exported tycons/classes
+ Bag (Name, ExportFlag))) -- Exported values
rnIE mods (IEVar name)
= lookupValue name `thenRn` \ rn ->
warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
(synAllExportErr False{-warning-} rn src_loc)
- checkIEAll rn = pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
+ checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
rn_fixity_pieces mk_fixity name i fix
= getRnEnv `thenRn` \ env ->
case lookupGlobalRnEnv env name of
- Just res | isLocallyDefined res || opt_CompilingGhcInternals
+ Just res | isLocallyDefined res -- || opt_CompilingGhcInternals
-- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
-- fixity decl to go through. It has a builtin name, which
-- doesn't respond to isLocallyDefined... sigh.
module RnUtils (
SYN_IE(RnEnv), SYN_IE(QualNames),
SYN_IE(UnqualNames), SYN_IE(ScopeStack),
- emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
+ emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
getLocalsFromRnEnv,
lubExportFlag,
qualNameErr,
- dupNamesErr
+ dupNamesErr,
+ pprRnEnv -- debugging only
) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(List(partition))
import Bag ( Bag, emptyBag, snocBag, unionBags )
-import CmdLineOpts ( opt_CompilingGhcInternals )
+import CmdLineOpts ( opt_GlasgowExts )
import ErrUtils ( addShortErrLocLine )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
- lookupFM, addListToFM, addToFM, eltsFM )
+import FiniteMap ( emptyFM, isEmptyFM, fmToList, listToFM, keysFM,
+ lookupFM, addListToFM, addToFM, eltsFM, FiniteMap )
import Maybes ( maybeToBool )
import Name ( RdrName(..), ExportFlag(..),
isQual, pprNonSym, getLocalName, isLocallyDefined )
import PprStyle ( PprStyle(..) )
+import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
+import PrelMods ( gHC_BUILTINS )
import Pretty
import RnHsSyn ( RnName )
import Util ( assertPanic )
type ScopeStack = FiniteMap FAST_STRING RnName
emptyRnEnv :: RnEnv
+initRnEnv :: RnEnv
extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
-> (RnEnv, Bag (RdrName, RnName, RnName))
extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
It optionally reports any shadowed names.
\begin{code}
-emptyRnEnv
- = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
+emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
+
+ -- an emptyRnEnv is empty; the initRnEnv may have
+ -- primitive names already in it (both unqual and qual),
+ -- and quals for all the other wired-in dudes.
+
+initRnEnv
+ = if (not opt_GlasgowExts) then
+ emptyRnEnv
+ else
+ ((listToFM qual, listToFM unqual, listToFM tc_qual, listToFM tc_unqual), emptyFM)
+ where
+ qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinValNamesMap ]
+ tc_qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinTcNamesMap ]
+
+ builtin_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) qual
+ builtin_tc_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) tc_qual
+
+ unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_qual
+ tc_unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_tc_qual
+
+-----------------
extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
= ASSERT(isEmptyFM stack)
ext_dups = if maybeToBool (lookupFM stack str)
then name:dups
else dups
+\end{code}
-
+\begin{code}
lookupRnEnv ((qual, unqual, _, _), stack) rdr
= case rdr of
- Unqual str -> lookup stack str (lookup unqual str Nothing)
- Qual mod str -> lookup qual (str,mod)
- (if not opt_CompilingGhcInternals -- see below
- then -- pprTrace "lookupRnEnv:" (ppAboves (ppCat [ppPStr mod, ppPStr str] : [ ppCat [ppPStr m, ppPStr s] | (s,m) <- keysFM qual ])) $
- Nothing
- else lookup unqual str Nothing)
+ Unqual str -> lookup stack str (lookupFM unqual str)
+ Qual mod str -> lookupFM qual (str,mod)
where
lookup fm thing do_on_fail
= case lookupFM fm thing of
lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
= case rdr of
Unqual str -> lookupFM unqual str
- Qual mod str -> case (lookupFM qual (str,mod)) of
- Just xx -> Just xx
- Nothing -> if not opt_CompilingGhcInternals then
- Nothing
- else -- "[]" may have turned into "Prelude.[]" and
- -- we are actually compiling "data [] a = ...";
- -- maybe the right thing is to get "Prelude.[]"
- -- into the "qual" table...
- lookupFM unqual str
+ Qual mod str -> lookupFM qual (str,mod)
lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
= case rdr of
Unqual str -> lookupFM tc_unqual str
- Qual mod str -> case (lookupFM tc_qual (str,mod)) of -- as above
- Just xx -> Just xx
- Nothing -> if not opt_CompilingGhcInternals then
- Nothing
- else
- lookupFM tc_unqual str
+ Qual mod str -> lookupFM tc_qual (str,mod)
getLocalsFromRnEnv ((_, vals, _, tcs), _)
= (filter isLocallyDefined (eltsFM vals),
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "here was another declaration of `",
pprNonSym sty name, ppStr "'" ]) sty
-\end{code}
+-----------------
+pprRnEnv :: PprStyle -> RnEnv -> Pretty
+
+pprRnEnv sty ((qual, unqual, tc_qual, tc_unqual), stack)
+ = ppAboves [ ppStr "Stack:"
+ , ppCat (map ppPStr (keysFM stack))
+ , ppStr "Val qual:"
+ , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM qual]
+ , ppStr "Val unqual:"
+ , ppCat (map ppPStr (keysFM unqual))
+ , ppStr "Tc qual:"
+ , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM tc_qual]
+ , ppStr "Tc unqual:"
+ , ppCat (map ppPStr (keysFM tc_unqual))
+ ]
+\end{code}
import Unique ( Unique{-instance Eq-} )
import Util ( assoc, zipEqual, pprTrace, panic )
-isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
+isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
\end{code}
GenForm form_summary template guidance
-> considerUnfolding env var args
- (panic "completeVar"{-txt_occ-}) form_summary template guidance
+ (False{-ToDo:!-}{-txt_occ-}) form_summary template guidance
MagicForm str magic_fun
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
\begin{code}
coreExprToStg env expr@(App _ _)
= let
- (fun, _, _, args) = collectArgs expr
+ (fun,args) = collect_args expr []
in
-- Deal with the arguments
coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
-- Now deal with the function
- case fun of
- Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+ case (fun, args) of
+ (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
+ -- there are no arguments.
+ returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+
+ (non_var_fun, []) -> -- No value args, so recurse into the function
+ coreExprToStg env non_var_fun
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
returnUs (StgLet (StgNonRec fun_id fun_rhs)
(StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
arg_binds `unionBags` fun_binds)
+ where
+ -- Collect arguments, discarding type/usage applications
+ collect_args (App e (TyArg _)) args = collect_args e args
+ collect_args (App e (UsageArg _)) args = collect_args e args
+ collect_args (App fun arg) args = collect_args fun (arg:args)
+ collect_args fun args = (fun, args)
\end{code}
%************************************************************************
pprTrace, panic, pprPanic, assertPanic
)
-returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
+returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
%************************************************************************
opt_D_dump_stranal, opt_D_simplifier_stats
)
import CoreSyn
-import Id ( idType, addIdStrictness,
+import Id ( idType, addIdStrictness, isWrapperId,
getIdDemandInfo, addIdDemandInfo,
GenId{-instance Outputable-}
)
import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
import Unique ( Unique{-instance Eq -} )
-import Util ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
-
-isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
+import Util ( zipWith4Equal, pprTrace, panic )
\end{code}
-
%************************************************************************
%* *
\subsection[Thoughts]{Random thoughts}
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingGuidance(..) )
+import CoreUnfold ( UnfoldingDetails(..){-ToDo:rm-}, UnfoldingGuidance(..) )
+IMPORT_DELOOPER(IdLoop) -- ToDo:rm when iWantToBeINLINEd goes
+
import CoreUtils ( coreExprType )
import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
- getIdInfo, GenId
+ getIdInfo, replaceIdInfo, GenId
)
import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
mkStrictnessInfo, StrictnessInfo(..)
import SaLib
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
import WwLib
-import Util ( panic{-ToDo:rm-} )
-replaceIdInfo = panic "WorkWrap.replaceIdInfo (ToDo)"
-iWantToBeINLINEd = panic "WorkWrap.iWantToBeINLINEd (ToDo)"
+iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
+iWantToBeINLINEd x = NoUnfoldingDetails --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
\end{code}
We take Core bindings whose binders have their strictness attached (by
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
-import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
+import Unique ( iOTyConKey )
import Util
import FiniteMap ( emptyFM, FiniteMap )
`thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
- checkTopLevelIds mod_name final_env `thenTc_`
-
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
-- top-level decl falls under the monomorphism
cls_decls_bag = listToBag cls_decls
inst_decls_bag = listToBag inst_decls
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Error checking code}
-%* *
-%************************************************************************
-
-
-checkTopLevelIds checks that Main.main or GHCmain.mainPrimIO has correct type.
-
-\begin{code}
-checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
-
-checkTopLevelIds mod final_env
- | mod /= SLIT("Main") && mod /= SLIT("GHCmain")
- = returnTc ()
-
- | mod == SLIT("Main")
- = tcSetEnv final_env (
- tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
- tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
-
- case maybe_main of
- Just main -> tcAddErrCtxt mainCtxt $
- unifyTauTy (applyTyCon io_tc [unitTy])
- (idType main)
-
- Nothing -> failTc (mainNoneIdErr "Main" "main")
- )
-
- | mod == SLIT("GHCmain")
- = tcSetEnv final_env (
- tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
-
- case maybe_prim of
- Just prim -> tcAddErrCtxt primCtxt $
- unifyTauTy (mkPrimIoTy unitTy)
- (idType prim)
-
- Nothing -> failTc (mainNoneIdErr "GHCmain" "mainPrimIO")
- )
-
-mainCtxt sty
- = ppStr "Main.main should have type IO ()"
-
-primCtxt sty
- = ppStr "GHCmain.mainPrimIO should have type PrimIO ()"
-
-mainNoneIdErr mod n sty
- = ppCat [ppPStr SLIT("module"), ppStr mod, ppPStr SLIT("does not contain a definition for"), ppStr n]
-\end{code}
\begin{code}
unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
-unifyTauTy ty1 ty2
+unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
= tcAddErrCtxtM (unifyCtxt ty1 ty2) $
uTys ty1 ty1 ty2 ty2
\end{code}
~~~~~~
\begin{code}
-unifyCtxt ty1 ty2
+unifyCtxt ty1 ty2 -- ty1 expected, ty2 inferred
= zonkTcType ty1 `thenNF_Tc` \ ty1' ->
zonkTcType ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (err ty1' ty2')
where
err ty1' ty2' sty = ppAboves [
- ppCat [ppStr "When matching:", ppr sty ty1'],
- ppCat [ppStr " against:", ppr sty ty2']
+ ppCat [ppStr "Expected:", ppr sty ty1'],
+ ppCat [ppStr "Inferred:", ppr sty ty2']
]
unifyMisMatch ty1 ty2 sty
getTypeString,
typeMaybeString,
specMaybeTysSuffix,
+ getTyDescription,
GenClass,
GenClassOp, pprGenClassOp,
) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
+IMPORT_DELOOPER(IdLoop)
+--IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
where
do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
do_tc (SynTy _ _ ty) = do_tc ty
- do_tc other = pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
+ do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
Right (_PK_ (ppShow 1000 (pprType PprForC other)))
do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc)
do_arg_ty (TyVarTy tv) = Right (_PK_ (ppShow 80 (ppr PprForC tv)))
do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
- do_arg_ty other = pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
+ do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
Right (_PK_ (ppShow 1000 (pprType PprForC other)))
-- PprForC expands type synonyms as it goes;
-}
\end{code}
+Grab a name for the type. This is used to determine the type
+description for profiling.
+\begin{code}
+getTyDescription :: Type -> String
+
+getTyDescription ty
+ = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res _ -> '-' : '>' : fun_result res
+ TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
+ SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
+ DictTy _ _ _ -> "dict"
+ _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
+ }
+ where
+ fun_result (FunTy _ res _) = '>' : fun_result res
+ fun_result other = getTyDescription other
+\end{code}
+
ToDo: possibly move:
\begin{code}
nmbrType :: Type -> NmbrM Type
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic, pprPanic{-ToDo:rm-} )
-import {-hide me-}
- PprType (pprTyCon)
-import {-hide me-}
- PprStyle--ToDo:rm
+--import {-hide me-}
+-- PprType (pprTyCon)
+--import {-hide me-}
+-- PprStyle--ToDo:rm
\end{code}
\begin{code}
tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
tyConFamilySize (TupleTyCon _ _ _) = 1
#ifdef DEBUG
-tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
#endif
tyConPrimRep :: TyCon -> PrimRep
) where
CHK_Ubiq() -- debugging consistency check
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-- friends
import Usage ( GenUsage, SYN_IE(Usage), usageOmega )
SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
mkDictTy,
- mkRhoTy, splitRhoTy, mkTheta,
+ mkRhoTy, splitRhoTy, mkTheta, isDictTy,
mkSigmaTy, splitSigmaTy,
maybeAppTyCon, getAppTyCon,
) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop)
+--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
Pretty
import {-mumble-}
PprStyle
-import {-mumble-}
- PprType --(pprType )
+--import {-mumble-}
+-- PprType --(pprType )
import {-mumble-}
UniqFM (ufmToList )
import {-mumble-}
applyTyCon :: TyCon -> [GenType t u] -> GenType t u
applyTyCon tycon tys
- = --ASSERT (not (isSynTyCon tycon))
- (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
+ = ASSERT (not (isSynTyCon tycon))
+ --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
foldl AppTy (TyConTy tycon usageOmega) tys
getTyCon_maybe :: GenType t u -> Maybe TyCon
= map cvt dict_tys
where
cvt (DictTy clas ty _) = (clas, ty)
- cvt other = pprPanic "mkTheta:" (pprType PprDebug other)
+ cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
+
+isDictTy (DictTy _ _ _) = True
+isDictTy (SynTy _ _ t) = isDictTy t
+isDictTy _ = False
\end{code}
typePrimRep (TyConTy tc _)
| isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
Just xx -> xx
- Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+ Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
| otherwise = case maybeNewTyCon tc of
Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
import Pretty
# endif
import Bag ( foldBag )
-import {-hide from mkdependHS-}
- Name ( RdrName, OrigName ) -- specialising only
# if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
instance Ord Reg
+instance Ord OrigName
instance Ord RdrName
instance Ord CLabel
instance Ord TyCon
instance Eq Reg
+instance Eq OrigName
instance Eq RdrName
instance Eq CLabel
instance Eq TyCon
+-- specializing in UniqFM, UniqSet
+instance Uniquable Unique
+instance Uniquable RnName
+instance Uniquable Name
+-- specializing in Name
+instance NamedThing RnName
\end{code}
Maybes MaybeErr
Name ExportFlag
Name Module
+Name Name
Name NamedThing (..)
Name OrigName (..)
Name RdrName (..)
PragmaInfo PragmaInfo
PrimOp PrimOp
PrimRep PrimRep
+RnHsSyn RnName
SrcLoc SrcLoc
TyCon Arity
TyCon TyCon
#if defined(COMPILING_GHC)
IMP_Ubiq(){-uitous-}
-import {-hide from mkdependHS-}
- Name ( Name ) -- specialising only
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- specialising only
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
import PprStyle ( PprStyle )
import Util ( Ord3(..) )
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- specialising only
-
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
#else
uppInteger n = cStr (show n)
uppSP = cCh ' '
-upp'SP{-'-} = cPStr SLIT(", ")
+upp'SP{-'-} = uppBeside uppComma uppSP
uppLbrack = cCh '['
uppRbrack = cCh ']'
uppLparen = cCh '('
#if defined(COMPILING_GHC)
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(List(zipWith4))
import Pretty
#endif
projects / ghc-hetmet.git / commitdiff