diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index 84988960acb034617e85fcc21c6a36c5213a0256..0562eb9f153ff8702376673bdf6c1a86114c4872 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -114,6 +114,8 @@ types/Type.lhs \
\
specialise/SpecEnv.lhs
+#define RENAMERSRCS_HS \
+rename/ParseIface.hs
#define RENAMERSRCS_LHS \
rename/RnHsSyn.lhs \
@@ -344,7 +346,7 @@ profiling/CostCentre.lhs \
simplCore/BinderInfo.lhs \
simplCore/MagicUFs.lhs
-ALLSRCS_HS = READERSRCS_HS
+ALLSRCS_HS = READERSRCS_HS RENAMERSRCS_HS
ALLSRCS_LHS = /* all pieces of the compiler */ \
VBASICSRCS_LHS \
NOT_SO_BASICSRCS_LHS \
@@ -503,6 +505,10 @@ typecheck/TcLoop.hi : typecheck/TcLoop.lhi
types/TyLoop.hi : types/TyLoop.lhi
$(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
+rename/ParseIface.hs : rename/ParseIface.y
+ $(RM) rename/ParseIface.hs
+ happy -g rename/ParseIface.y
+
compile(absCSyn/AbsCUtils,lhs,)
compile(absCSyn/CStrings,lhs,)
compile(absCSyn/CLabel,lhs,)
@@ -615,6 +621,7 @@ compile(reader/PrefixToHs,lhs,)
compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#include"hspincl.h"'))
compile(reader/RdrHsSyn,lhs,)
+compile(rename/ParseIface,hs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,)
compile(rename/Rename,lhs,)
@@ -759,7 +766,6 @@ HSP_SRCS_C = parser/constr.c \
parser/hslexer.c \
parser/hsparser.tab.c \
parser/id.c \
- parser/import_dirlist.c \
parser/infix.c \
parser/list.c \
parser/literal.c \
@@ -779,7 +785,6 @@ HSP_OBJS_O = parser/constr.o \
parser/hslexer.o \
parser/hsparser.tab.o \
parser/id.o \
- parser/import_dirlist.o \
parser/infix.o \
parser/list.o \
parser/literal.o \
@@ -800,7 +805,6 @@ REAL_HSP_SRCS_C = parser/main.c \
parser/util.c \
parser/syntax.c \
parser/type2context.c \
- parser/import_dirlist.c \
parser/infix.c \
parser/printtree.c
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 8018ad2c992ce525cd3075d518c133de7f83142f..2046335c91e6d6711de1a1b1fbe7c88ae9b63208 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -1800,17 +1800,23 @@ instance NamedThing (GenId ty) where
getName this_id@(Id u _ details _ _)
= get details
where
- get (LocalId n _) = n
- get (SysLocalId n _) = n
- get (SpecPragmaId n _ _)= n
- get (ImportedId n) = n
- get (PreludeId n) = n
- get (TopLevId n) = n
- get (InstId n _) = n
+ get (LocalId n _) = n
+ get (SysLocalId n _) = n
+ get (SpecPragmaId n _ _) = n
+ get (ImportedId n) = n
+ get (PreludeId n) = n
+ get (TopLevId n) = n
+ get (InstId n _) = n
get (DataConId n _ _ _ _ _ _ _) = n
- get (TupleConId n _) = n
- get (RecordSelId l) = getName l
--- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
+ get (TupleConId n _) = n
+ get (RecordSelId l) = getName l
+ get (SuperDictSelId c sc) = panic "Id.getName.SuperDictSelId"
+ get (MethodSelId c op) = panic "Id.getName.MethodSelId"
+ get (DefaultMethodId c op _) = panic "Id.getName.DefaultMethodId"
+ get (DictFunId c ty _ _) = panic "Id.getName.DictFunId"
+ get (ConstMethodId c ty op _ _) = panic "Id.getName.ConstMethodId"
+ get (SpecId i tys _) = panic "Id.getName.SpecId"
+ get (WorkerId i) = panic "Id.getName.WorkerId"
{- LATER:
get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 6eebe45348f4859f85e97daf0f624924a8fdb3e3..1a65a676b26cd54359f734559d4ad55c469e8450 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -422,7 +422,7 @@ instance OptIdInfo (MatchEnv [Type] CoreExpr) where
= ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
- = panic "IdInfo:ppSpecs"
+ = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index eeaf9dac40992df531d724f6d9955761bd54ceca..54875d7fabc7a87c96f05c04f0b1912e4ae5bb8a 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -49,9 +49,7 @@ import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
mkErrorStdEntryLabel, mkRednCountsLabel
)
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent,
- opt_AsmTarget
- )
+import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
isCafCC, overheadCostCentre
@@ -436,7 +434,6 @@ closureCodeBody binder_info closure_info cc all_args body
let
do_arity_chks = opt_EmitArityChecks
is_concurrent = opt_ForConcurrent
- native_code = opt_AsmTarget
stg_arity = length all_args
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index f1a0d30e9583bdf2451b8d6fa0ce00f72a89894e..016bd99ec3cef2d73703e583f916b29185c6703d 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -90,7 +90,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
where
-----------------
grp_name = case opt_SccGroup of
- Just xx -> xx
+ Just xx -> _PK_ xx
Nothing -> mod_name -- default: module name
-----------------
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index dc2b61ae2001fd5212b89a924daa260bc98ecbd3..929d40d27e3668329298552d65bc6d66125b82f4 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -218,7 +218,7 @@ lintCoreExpr (Lam (ValBinder var) expr)
lintCoreExpr (Lam (TyBinder tyvar) expr)
= lintCoreExpr expr `thenMaybeL` \ty ->
returnL (Just(mkForAllTy tyvar ty))
- -- TODO: Should add in-scope type variable at this point
+ -- ToDo: Should add in-scope type variable at this point
lintCoreExpr e@(Case scrut alts)
= lintCoreExpr scrut `thenMaybeL` \ty ->
@@ -270,19 +270,20 @@ lintCoreArg _ e ty (VarArg v)
_ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
- = -- TODO: Check that ty is well-kinded and has no unbound tyvars
+ = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
`seqL`
case (getForAllTy_maybe ty) of
Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+ | pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (getTyVarKind tyvar), ppr PprDebug (getTypeKind arg_ty)]) False -> panic "impossible"
_ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
lintCoreArg _ e ty (UsageArg u)
- = -- TODO: Check that usage has no unbound usage variables
+ = -- ToDo: Check that usage has no unbound usage variables
case (getForAllUsageTy ty) of
Just (uvar,bounds,body) ->
- -- TODO Check argument satisfies bounds
+ -- ToDo: Check argument satisfies bounds
returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
_ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
\end{code}
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index e737450a3af6b9c3b616e422c1b53647b11042df..174f5053a8ee3188111b6884e64c4db210c91d34 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -54,7 +54,7 @@ import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
import UniqSupply ( initUs, returnUs, thenUs,
- mapUs, mapAndUnzipUs,
+ mapUs, mapAndUnzipUs, getUnique,
UniqSM(..), UniqSupply
)
import Usage ( UVar(..) )
@@ -172,32 +172,10 @@ For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type. @mkCoApp@ requires
a name supply to do its work.
-@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
+@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
arguments-must-be-atoms constraint.
\begin{code}
-{- LATER:
---mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
-
-mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
-mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
-mkCoApp e1 e2
- = let
- e2_ty = coreExprType e2
- in
- panic "getUnique" `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
- in
- returnUs (
- mkCoLetUnboxedToCase (NonRec new_var e2)
- (App e1 (VarArg new_var))
- )
--}
-\end{code}
-
-\begin{code}
-{-
data CoreArgOrExpr
= AnArg CoreArg
| AnExpr CoreExpr
@@ -206,30 +184,33 @@ mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoApps fun args = mkCoThing (Con con) args
-mkCoCon con args = mkCoThing (Con con) args
-mkCoPrim op args = mkCoThing (Prim op) args
+mkCoApps fun args = co_thing (mkGenApp fun) args
+mkCoCon con args = co_thing (Con con) args
+mkCoPrim op args = co_thing (Prim op) args
+
+co_thing :: ([CoreArg] -> CoreExpr)
+ -> [CoreArgOrExpr]
+ -> UniqSM CoreExpr
-mkCoThing thing arg_exprs
+co_thing thing arg_exprs
= mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
where
- expr_to_arg :: CoreExpr
- -> UniqSM (CoreArg, Maybe CoreBinding)
+ expr_to_arg :: CoreArgOrExpr
+ -> UniqSM (CoreArg, Maybe CoreBinding)
- expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
- expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
- expr_to_arg other_expr
+ expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
+ expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
+ expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
+ expr_to_arg (AnExpr other_expr)
= let
e_ty = coreExprType other_expr
in
- panic "getUnique" `thenUs` \ uniq ->
+ getUnique `thenUs` \ uniq ->
let
new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
- new_atom = VarArg new_var
in
- returnUs (new_atom, Just (NonRec new_var other_expr))
--}
+ returnUs (VarArg new_var, Just (NonRec new_var other_expr))
\end{code}
\begin{code}
@@ -242,18 +223,6 @@ argToExpr (LitArg lit) = Lit lit
\begin{code}
{- LATER:
---mkCoApps ::
--- GenCoreExpr val_bdr val_occ tyvar uvar ->
--- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
--- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
-
-mkCoApps fun [] = returnUs fun
-mkCoApps fun (arg:args)
- = mkCoApp fun arg `thenUs` \ new_fun ->
- mkCoApps new_fun args
-\end{code}
-
-\begin{code}
exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
@@ -713,18 +682,19 @@ do_CoreBinding venv tenv (Rec binds)
do_CoreArg :: ValEnv
-> TypeEnv
-> CoreArg
- -> UniqSM CoreExpr
+ -> UniqSM CoreArgOrExpr
-do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
-do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
-do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
-do_CoreArg venv tenv (VarArg v)
+do_CoreArg venv tenv a@(VarArg v)
= returnUs (
case (lookupIdEnv venv v) of
- Nothing -> --false:ASSERT(toplevelishId v)
- Var v
- Just expr -> expr
+ Nothing -> AnArg a
+ Just expr -> AnExpr expr
)
+
+do_CoreArg venv tenv (TyArg ty)
+ = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
+
+do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
\end{code}
\begin{code}
@@ -744,15 +714,10 @@ do_CoreExpr venv tenv orig_expr@(Var var)
do_CoreExpr venv tenv e@(Lit _) = returnUs e
do_CoreExpr venv tenv (Con con as)
- = panic "CoreUtils.do_CoreExpr:Con"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
mkCoCon con new_as
--}
do_CoreExpr venv tenv (Prim op as)
- = panic "CoreUtils.do_CoreExpr:Prim"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
do_PrimOp op `thenUs` \ new_op ->
mkCoPrim new_op new_as
@@ -765,7 +730,6 @@ do_CoreExpr venv tenv (Prim op as)
returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
do_PrimOp other_op = returnUs other_op
--}
do_CoreExpr venv tenv (Lam binder expr)
= dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
@@ -774,12 +738,9 @@ do_CoreExpr venv tenv (Lam binder expr)
returnUs (Lam new_binder new_expr)
do_CoreExpr venv tenv (App expr arg)
- = panic "CoreUtils.do_CoreExpr:App"
-{-
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
do_CoreArg venv tenv arg `thenUs` \ new_arg ->
- mkCoApp new_expr new_arg
--}
+ mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
do_CoreExpr venv tenv (Case expr alts)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index e45e7bc6db1dc25e70d9ff377f0c7878158cf89b..b744e0e213745e1eb0cc63f4319e1f9ea297df0a 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -33,14 +33,13 @@ import ListSetOps ( minusList, intersectLists )
import PprType ( GenType )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
-import Type ( mkTyVarTys, splitSigmaTy,
+import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
tyVarsOfType, tyVarsOfTypes
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
isDictTy = panic "DsBinds.isDictTy"
-quantifyTy = panic "DsBinds.quantifyTy"
\end{code}
%************************************************************************
@@ -154,7 +153,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
-- local_global_prs.
private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
binders = collectTypedBinders val_binds
- mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
+ mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
tyvar_tys = mkTyVarTys tyvars
\end{code}
@@ -244,7 +243,7 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
binders = collectTypedBinders val_binds
- mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
+ mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
\end{code}
@mkSatTyApp id tys@ constructs an expression whose value is (id tys).
@@ -343,8 +342,8 @@ dsInstBinds tyvars ((inst, expr) : bs)
where
inst_ty = idType inst
abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
- abs_tys = mkTyVarTys abs_tyvars
- (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
+ abs_tys = mkTyVarTys abs_tyvars
+ poly_inst_ty = mkForAllTys abs_tyvars inst_ty
------------------------
-- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 6d9dc558ede58f130f0a71989abc63de204da748..2900230d523bdee7fe34fd3f913add8b189f16dd 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -79,7 +79,7 @@ initDs init_us env mod_name action
where
module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
- Just xx -> xx
+ Just xx -> _PK_ xx
Nothing -> mod_name -- default: module name
thenDs :: DsM a -> (a -> DsM b) -> DsM b
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 9726092b576c446aeb754307677206e461915f42..e6b80f2d41074a3d6b0fcc76d27bf4f84a033b96 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -46,15 +46,13 @@ import Id ( idType, dataConArgTys, mkTupleCon,
DataCon(..), DictVar(..), Id(..), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon )
-import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
- applyTyCon, getAppDataTyCon
+import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
+ isUnboxedType, applyTyCon, getAppDataTyCon
)
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic )
-quantifyTy = panic "DsUtils.quantifyTy"
splitDictType = panic "DsUtils.splitDictType"
-mkCoTyApps = panic "DsUtils.mkCoTyApps"
\end{code}
%************************************************************************
@@ -417,10 +415,10 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
tuple_var_ty :: Type
tuple_var_ty
- = case (quantifyTy tyvars (mkRhoTy theta
- (applyTyCon (mkTupleTyCon no_of_binders)
- (map idType locals)))) of
- (_{-tossed templates-}, ty) -> ty
+ = mkForAllTys tyvars $
+ mkRhoTy theta $
+ applyTyCon (mkTupleTyCon no_of_binders)
+ (map idType locals)
where
theta = map (splitDictType . idType) dicts
@@ -434,17 +432,14 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
returnDs (
global,
mkLam tyvars dicts (
- mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
- binders selected)
+ mkTupleSelector
+ (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
+ (map VarArg dicts))
+ binders
+ selected)
)
-
-mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
-mkApp_XX expr [] = expr
-mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
\end{code}
-
-
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
\begin{code}
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 5b74a4d4127f0b9efa096b4615379e68b1760185..3b4facef0adadb80c45cf33677cf7723804667e3 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -66,7 +66,6 @@ data HsExpr tyvar uvar id pat
| SectionR (HsExpr tyvar uvar id pat) -- operator
(HsExpr tyvar uvar id pat) -- operand
-
| HsCase (HsExpr tyvar uvar id pat)
[Match tyvar uvar id pat] -- must have at least one Match
SrcLoc
@@ -110,9 +109,9 @@ data HsExpr tyvar uvar id pat
| RecordUpd (HsExpr tyvar uvar id pat)
(HsRecordBinds tyvar uvar id pat)
- | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
- [id] -- Dicts needed for construction
- (HsRecordBinds tyvar uvar id pat)
+ | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
+ [id] -- Dicts needed for construction
+ (HsRecordBinds tyvar uvar id pat)
| ExprWithTySig -- signature binding
(HsExpr tyvar uvar id pat)
@@ -211,7 +210,6 @@ pprExpr sty expr@(HsApp e1 e2)
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-
pprExpr sty (OpApp e1 op e2)
= case op of
HsVar v -> pp_infixly v
@@ -232,7 +230,6 @@ pprExpr sty (NegApp e)
pprExpr sty (HsPar e)
= ppParens (pprExpr sty e)
-
pprExpr sty (SectionL expr op)
= case op of
HsVar v -> pp_infixly v
@@ -259,23 +256,15 @@ pprExpr sty (SectionR op expr)
= ppSep [ ppBeside ppLparen (pprOp sty v),
ppBeside pp_expr ppRparen ]
-pprExpr sty (CCall fun args _ is_asm result_ty)
- = ppHang (if is_asm
- then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
- else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
- 4 (ppSep (map (pprParendExpr sty) args))
-
-pprExpr sty (HsSCC label expr)
- = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
- pprParendExpr sty expr ]
-
pprExpr sty (HsCase expr matches _)
= ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
ppNest 2 (pprMatches sty (True, ppNil) matches) ]
-pprExpr sty (ListComp expr quals)
- = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
- 4 (ppSep [interpp'SP sty quals, ppRbrack])
+pprExpr sty (HsIf e1 e2 e3 _)
+ = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
+ ppNest 4 (pprExpr sty e2),
+ ppPStr SLIT("else"),
+ ppNest 4 (pprExpr sty e3)]
-- special case: let ... in let ...
pprExpr sty (HsLet binds expr@(HsLet _ _))
@@ -288,12 +277,12 @@ pprExpr sty (HsLet binds expr)
pprExpr sty (HsDo stmts _)
= ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+pprExpr sty (HsDoOut stmts _ _ _)
+ = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
-pprExpr sty (HsIf e1 e2 e3 _)
- = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
- ppNest 4 (pprExpr sty e2),
- ppPStr SLIT("else"),
- ppNest 4 (pprExpr sty e3)]
+pprExpr sty (ListComp expr quals)
+ = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
+ 4 (ppSep [interpp'SP sty quals, ppRbrack])
pprExpr sty (ExplicitList exprs)
= ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
@@ -303,15 +292,18 @@ pprExpr sty (ExplicitListOut ty exprs)
pprExpr sty (ExplicitTuple exprs)
= ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
-pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
- 4 (ppBeside (ppr sty sig) ppRparen)
pprExpr sty (RecordCon con rbinds)
= pp_rbinds sty (ppr sty con) rbinds
pprExpr sty (RecordUpd aexp rbinds)
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
+pprExpr sty (RecordUpdOut aexp _ rbinds)
+ = pp_rbinds sty (pprParendExpr sty aexp) rbinds
+
+pprExpr sty (ExprWithTySig expr sig)
+ = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
+ 4 (ppBeside (ppr sty sig) ppRparen)
pprExpr sty (ArithSeqIn info)
= ppBracket (ppr sty info)
@@ -322,6 +314,16 @@ pprExpr sty (ArithSeqOut expr info)
_ ->
ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack]
+pprExpr sty (CCall fun args _ is_asm result_ty)
+ = ppHang (if is_asm
+ then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
+ else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
+ 4 (ppSep (map (pprParendExpr sty) args))
+
+pprExpr sty (HsSCC label expr)
+ = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
+ pprParendExpr sty expr ]
+
pprExpr sty (TyLam tyvars expr)
= ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
4 (pprExpr sty expr)
@@ -352,12 +354,15 @@ pprExpr sty (ClassDictLam dicts methods expr)
4 (pprExpr sty expr)
pprExpr sty (Dictionary dicts methods)
- = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
- ppBracket (interpp'SP sty dicts),
- ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+ ppBracket (interpp'SP sty dicts),
+ ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
pprExpr sty (SingleDict dname)
- = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+ = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+
+pprExpr sty (HsCon con tys exprs)
+ = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs]
\end{code}
Parenthesize unless very simple:
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index 7aed7aee482f852e40735e5ad30bad172a4ec91a..3b202f4fea0f54f7374119a98f67d40c5ad67cac 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -112,12 +112,15 @@ pprMatch sty is_case first_match
(row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
ppr_match sty is_case (PatMatch pat match)
- = (pat:pats, grhss_stuff)
- where
+ = (pat:pats, grhss_stuff)
+ where
(pats, grhss_stuff) = ppr_match sty is_case match
ppr_match sty is_case (GRHSMatch grhss_n_binds)
- = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+ = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+
+ ppr_match sty is_case (SimpleMatch expr)
+ = ([], ppr sty expr)
----------------------------------------------------------
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 8f7ce3372ed759d369675f984a63319fbc61fb00..e0a0382b28b652808c2180b7fb03ba511f731fd9 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -14,7 +14,7 @@ import Argv
CHK_Ubiq() -- debugging consistency check
import Maybes ( assocMaybe, firstJust, maybeToBool, Maybe(..) )
-import Util ( panic, panic#, assertPanic )
+import Util ( startsWith, panic, panic#, assertPanic )
\end{code}
A command-line {\em switch} is (generally) either on or off; e.g., the
@@ -140,30 +140,19 @@ data SimplifierSwitch
\begin{code}
lookup :: FAST_STRING -> Bool
-lookup_int :: FAST_STRING -> Maybe Int
-lookup_str :: FAST_STRING -> Maybe FAST_STRING
+lookup_int :: String -> Maybe Int
+lookup_str :: String -> Maybe String
lookup sw = maybeToBool (assoc_opts sw)
-lookup_str sw = let
- unpk_sw = _UNPK_ sw
- in
- case (firstJust (map (starts_with unpk_sw) unpacked_opts)) of
- Nothing -> Nothing
- Just xx -> Just (_PK_ xx)
+lookup_str sw = firstJust (map (startsWith sw) unpacked_opts)
lookup_int sw = case (lookup_str sw) of
Nothing -> Nothing
- Just xx -> Just (read (_UNPK_ xx))
+ Just xx -> Just (read xx)
assoc_opts = assocMaybe [ (a, True) | a <- argv ]
unpacked_opts = map _UNPK_ argv
-
-starts_with :: String -> String -> Maybe String
-
-starts_with [] str = Just str
-starts_with (c:cs) (s:ss)
- = if c /= s then Nothing else starts_with cs ss
\end{code}
\begin{code}
@@ -229,16 +218,40 @@ opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed")
opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape")
opt_UseGetMentionedVars = lookup SLIT("-fuse-get-mentioned-vars")
opt_Verbose = lookup SLIT("-v")
-opt_AsmTarget = lookup_str SLIT("-fasm-")
-opt_SccGroup = lookup_str SLIT("-G")
-opt_ProduceC = lookup_str SLIT("-C")
-opt_ProduceS = lookup_str SLIT("-S")
-opt_ProduceHi = lookup_str SLIT("-hi")
-opt_EnsureSplittableC = lookup_str SLIT("-fglobalise-toplev-names")
-opt_UnfoldingUseThreshold = lookup_int SLIT("-funfolding-use-threshold")
-opt_UnfoldingCreationThreshold = lookup_int SLIT("-funfolding-creation-threshold")
-opt_UnfoldingOverrideThreshold = lookup_int SLIT("-funfolding-override-threshold")
-opt_ReturnInRegsThreshold = lookup_int SLIT("-freturn-in-regs-threshold")
+opt_AsmTarget = lookup_str "-fasm="
+opt_SccGroup = lookup_str "-G="
+opt_ProduceC = lookup_str "-C="
+opt_ProduceS = lookup_str "-S="
+opt_ProduceHi = lookup_str "-hifile="
+opt_ProduceHu = lookup_str "-hufile="
+opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
+opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
+opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
+opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold"
+opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold"
+
+opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude")
+opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas")
+
+opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x }
+opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x }
+
+opt_HiDirList = get_dir_list "-i="
+opt_SysHiDirList = get_dir_list "-j="
+
+get_dir_list tag
+ = case (lookup_str tag) of
+ Nothing -> [{-no dirs to search???-}]
+ Just xs -> colon_split xs "" [] -- character and dir accumulators, both reversed...
+ where
+ colon_split [] cacc dacc = reverse (reverse cacc : dacc)
+ colon_split (':' : xs) cacc dacc = colon_split xs "" (reverse cacc : dacc)
+ colon_split ( x : xs) cacc dacc = colon_split xs (x : cacc) dacc
+
+-- -hisuf, -hisuf-prelude
+-- -fno-implicit-prelude
+-- -fignore-interface-pragmas
+-- importdirs and sysimport dirs
\end{code}
\begin{code}
@@ -348,9 +361,9 @@ classifyOpts = sep argv [] [] -- accumulators...
| starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
| starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
where
- maybe_suut = starts_with "-fsimpl-uf-use-threshold" o
- maybe_suct = starts_with "-fsimpl-uf-creation-threshold" o
- maybe_msi = starts_with "-fmax-simplifier-iterations" o
+ maybe_suut = startsWith "-fsimpl-uf-use-threshold" o
+ maybe_suct = startsWith "-fsimpl-uf-creation-threshold" o
+ maybe_msi = startsWith "-fmax-simplifier-iterations" o
starts_with_suut = maybeToBool maybe_suut
starts_with_suct = maybeToBool maybe_suct
starts_with_msi = maybeToBool maybe_msi
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 3507b79f8c4a685ee6e6d0dbc281f9ef597f3687..918a24c16a07c52ddf7f00a9320d97e72f125168 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -335,7 +335,7 @@ doIt (core_cmds, stg_cmds) input_pgm
doOutput switch io_action
= case switch of
Nothing -> returnMn ()
- Just fn -> let fname = _UNPK_ fn in
+ Just fname ->
fopen fname "a+" `thenPrimIO` \ file ->
if (file == ``NULL'') then
error ("doOutput: failed to open:"++fname)
diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs
index 70185118b39bd07f80ebd4938de770e026fbcc8b..92440229467f624202c71a4a49df79f1b955a36e 100644
--- a/ghc/compiler/parser/UgenUtil.lhs
+++ b/ghc/compiler/parser/UgenUtil.lhs
@@ -58,9 +58,7 @@ rdU_long x = returnUgn x
type U_stringId = FAST_STRING
rdU_stringId :: _Addr -> UgnM U_stringId
{-# INLINE rdU_stringId #-}
-rdU_stringId s
- = -- ToDo (sometime): ioToUgnM (_ccall_ hash_index s) `thenUgn` \ (I# i) ->
- returnUgn (_packCString s)
+rdU_stringId s = returnUgn (_packCString s)
type U_numId = Int -- ToDo: Int
rdU_numId :: _Addr -> UgnM U_numId
diff --git a/ghc/compiler/parser/hsclink.c b/ghc/compiler/parser/hsclink.c
index 055304e6119b0035aab6ae6fbad0820b0055cca0..a42a667ea36a83189a9d98213910ef88b3dc76d8 100644
--- a/ghc/compiler/parser/hsclink.c
+++ b/ghc/compiler/parser/hsclink.c
@@ -45,11 +45,6 @@ hspmain()
process_args(hsp_argc, hsp_argv); /* HACK */
hash_init();
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
-#endif
-
yyinit();
if (yyparse() != 0) {
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index e54bb0b54482d5189afc8424654b34c6fd551f44..f66949f0a24ad5800a21572060dc017e90edaf99 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -149,21 +149,12 @@ extern BOOLEAN etags; /* that which is saved */
extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
-static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
-
-extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
-extern int minAcceptablePragmaVersion; /* see documentation in main.c */
-extern int maxAcceptablePragmaVersion;
-extern int thisIfacePragmaVersion;
-
static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";"
* inserted before token +ve -- "}" inserted before
* token */
short icontexts = 0; /* Which context we're in */
-
-
/*
Table of indentations: right bit indicates whether to use
indentation rules (1 = use rules; 0 = ignore)
@@ -468,7 +459,7 @@ NL [\n\r]
/* These SHOULDNAE work in "Code" (sigh) */
%}
<Code,GlaExt,UserPragma>{Id}"#" {
- if (! (nonstandardFlag || in_interface)) {
+ if (! nonstandardFlag) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
hsperror(errbuf);
@@ -477,7 +468,7 @@ NL [\n\r]
RETURN(_isconstr(yytext) ? CONID : VARID);
}
<Code,GlaExt,UserPragma>_+{Id} {
- if (! (nonstandardFlag || in_interface)) {
+ if (! nonstandardFlag) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
hsperror(errbuf);
@@ -557,7 +548,7 @@ NL [\n\r]
addtext(yytext, yyleng - 2);
text = fetchtext(&length);
- if (! (nonstandardFlag || in_interface)) {
+ if (! nonstandardFlag) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
hsperror(errbuf);
@@ -634,7 +625,7 @@ NL [\n\r]
addtext(yytext, yyleng-2);
text = fetchtext(&length);
- if (! (nonstandardFlag || in_interface)) {
+ if (! nonstandardFlag) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
hsperror(errbuf);
@@ -1097,7 +1088,6 @@ yylex()
hscolno = hscolno_save;
hspcolno = hspcolno_save;
etags = etags_save;
- in_interface = FALSE;
icontexts = icontexts_save - 1;
icontexts_save = 0;
#ifdef HSP_DEBUG
@@ -1148,7 +1138,6 @@ setyyin(char *file)
hscolno_save = hscolno;
hspcolno_save = hspcolno;
hscolno = hspcolno = 0;
- in_interface = TRUE;
etags_save = etags; /* do not do "etags" stuff in interfaces */
etags = 0; /* We remember whether we are doing it in
the module, so we can restore it later [WDP 94/09] */
diff --git a/ghc/compiler/parser/import_dirlist.c b/ghc/compiler/parser/import_dirlist.c
deleted file mode 100644
index d81de59c237072791257bb62030ebc8868782f6c..0000000000000000000000000000000000000000
--- a/ghc/compiler/parser/import_dirlist.c
+++ /dev/null
@@ -1,223 +0,0 @@
-/**********************************************************************
-* *
-* *
-* Import Directory List Handling *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#else
-#ifdef HAVE_TYPES_H
-#include <types.h>
-#endif
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_SYS_FILE_H
-#include <sys/file.h>
-#endif
-
-#ifndef HAVE_ACCESS
-#define R_OK "r"
-#define F_OK "r"
-short
-access(const char *fileName, const char *mode)
-{
- FILE *fp = fopen(fileName, mode);
- if (fp != NULL) {
- (void) fclose(fp);
- return 0;
- }
- return 1;
-}
-#endif /* HAVE_ACCESS */
-
-
-list imports_dirlist, sys_imports_dirlist; /* The imports lists */
-extern char HiSuffix[];
-extern char PreludeHiSuffix[];
-/* OLD 95/08: extern BOOLEAN ExplicitHiSuffixGiven; */
-
-#define MAX_MATCH 16
-
-/*
- This finds a module along the imports directory list.
-*/
-
-void
-find_module_on_imports_dirlist(char *module_name, BOOLEAN is_sys_import, char *returned_filename)
-{
- char try[FILENAME_SIZE];
-
- list imports_dirs;
-
-#ifdef HAVE_STAT
- struct stat sbuf[MAX_MATCH];
-#endif
-
- int no_of_matches = 0;
- BOOLEAN tried_source_dir = FALSE;
-
- char *try_end;
- char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
- char *suffix_to_report = suffix_to_use; /* save this for reporting, because we
- might change suffix_to_use later */
- int modname_len = strlen(module_name);
-
- /*
- Check every directory in (sys_)imports_dirlist for the imports file.
- The first directory in the list is the source directory.
- */
- for (imports_dirs = (is_sys_import) ? sys_imports_dirlist : imports_dirlist;
- tlist(imports_dirs) == lcons;
- imports_dirs = ltl(imports_dirs))
- {
- char *dir = (char *) lhd(imports_dirs);
- strcpy(try, dir);
-
- try_end = try + strlen(try);
-
-#ifdef macintosh /* ToDo: use DIR_SEP_CHAR */
- if (*(try_end - 1) != ':')
- strcpy (try_end++, ":");
-#else
- if (*(try_end - 1) != '/')
- strcpy (try_end++, "/");
-#endif /* ! macintosh */
-
- strcpy(try_end, module_name);
-
- strcpy(try_end+modname_len, suffix_to_use);
-
- /* See whether the file exists and is readable. */
- if (access (try,R_OK) == 0)
- {
- if ( no_of_matches == 0 )
- strcpy(returned_filename, try);
-
- /* Return as soon as a match is found in the source directory. */
- if (!tried_source_dir)
- return;
-
-#ifdef HAVE_STAT
- if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
- {
- int i;
- for (i = 0; i < no_of_matches; i++)
- {
- if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
- sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
- goto next; /* Skip dups */
- }
- }
-#endif /* HAVE_STAT */
- no_of_matches++;
- }
- else if (access (try,F_OK) == 0)
- fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
-
- next:
- tried_source_dir = TRUE;
- }
-
- if ( no_of_matches == 0 && ! is_sys_import ) { /* Nothing so far */
-
- /* If we are explicitly meddling about with .hi suffixes,
- then some system-supplied modules may need to be looked
- for with PreludeHiSuffix; unsavoury but true...
- */
- suffix_to_use = PreludeHiSuffix;
-
- for (imports_dirs = sys_imports_dirlist;
- tlist(imports_dirs) == lcons;
- imports_dirs = ltl(imports_dirs))
- {
- char *dir = (char *) lhd(imports_dirs);
- strcpy(try, dir);
-
- try_end = try + strlen(try);
-
-#ifdef macintosh /* ToDo: use DIR_SEP_STRING */
- if (*(try_end - 1) != ':')
- strcpy (try_end++, ":");
-#else
- if (*(try_end - 1) != '/')
- strcpy (try_end++, "/");
-#endif /* ! macintosh */
-
- strcpy(try_end, module_name);
-
- strcpy(try_end+modname_len, suffix_to_use);
-
- /* See whether the file exists and is readable. */
- if (access (try,R_OK) == 0)
- {
- if ( no_of_matches == 0 )
- strcpy(returned_filename, try);
-
-#ifdef HAVE_STAT
- if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
- {
- int i;
- for (i = 0; i < no_of_matches; i++)
- {
- if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
- sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
- goto next_again; /* Skip dups */
- }
- }
-#endif /* HAVE_STAT */
- no_of_matches++;
- }
- else if (access (try,F_OK) == 0)
- fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
- next_again:
- /*NOTHING*/;
- }
- }
-
- /* Error checking */
-
- switch ( no_of_matches ) {
- default:
- fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n",
- no_of_matches, suffix_to_report, module_name);
- break;
- case 0:
- {
- char disaster_msg[MODNAME_SIZE+1000];
- sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s",
- suffix_to_report, module_name,
- (strncmp(module_name, "PreludeGlaIO", 12) == 0)
- ? "\n(The PreludeGlaIO interface no longer exists);"
- :(
- (strncmp(module_name, "PreludePrimIO", 13) == 0)
- ? "\n(The PreludePrimIO interface no longer exists -- just use PreludeGlaST);"
- :(
- (strncmp(module_name, "Prelude", 7) == 0)
- ? "\n(Perhaps you forgot a `-fglasgow-exts' flag?);"
- : ""
- )));
- hsperror(disaster_msg);
- break;
- }
- case 1:
- /* Everything is fine */
- break;
- }
-}
diff --git a/ghc/compiler/parser/main.c b/ghc/compiler/parser/main.c
index 8463644a77c6eebc39c872ae09d5537c9fb0347a..325c553940bd8733cade5c1dcf41ebbd7deb9176 100644
--- a/ghc/compiler/parser/main.c
+++ b/ghc/compiler/parser/main.c
@@ -27,11 +27,6 @@ main(int argc, char **argv)
process_args(argc,argv);
hash_init();
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
-#endif
-
yyinit();
if(yyparse() == 0 && !etags)
diff --git a/ghc/compiler/parser/util.c b/ghc/compiler/parser/util.c
index de26eb0217997ad1ebbb64411a66784da5e3a049..f8ebc57c09ab2975810806efb2d49fd79bb8d34f 100644
--- a/ghc/compiler/parser/util.c
+++ b/ghc/compiler/parser/util.c
@@ -23,38 +23,6 @@ BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */
BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */
-BOOLEAN implicitPrelude = TRUE; /* Set if we implicitly import the Prelude. */
-BOOLEAN ignorePragmas = FALSE; /* Set if we want to ignore pragmas */
-
-/* From time to time, the format of interface files may change.
-
- So that we don't get gratuitous syntax errors or silently slurp in
- junk info, two things: (a) the compiler injects a "this is a
- version N interface":
-
- {-# GHC_PRAGMA INTERFACE VERSION <n> #-}
-
- (b) this parser has a "minimum acceptable version", below which it
- refuses to parse the pragmas (it just considers them as comments).
- It also has a "maximum acceptable version", above which...
-
- The minimum is so a new parser won't try to grok overly-old
- interfaces; the maximum (usually the current version number when
- the parser was released) is so an old parser will not try to grok
- since-upgraded interfaces.
-
- If an interface has no INTERFACE VERSION line, it is taken to be
- version 0.
-*/
-int minAcceptablePragmaVersion = 7; /* 1.3-xx ONLY */
-int maxAcceptablePragmaVersion = 7; /* 1.3-xx+ */
-int thisIfacePragmaVersion = 0;
-
-char *input_file_dir; /* The directory where the input file is. */
-
-char HiSuffix[64] = ".hi"; /* can be changed with -h flag */
-char PreludeHiSuffix[64] = ".hi"; /* can be changed with -g flag */
-
static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
/* Forward decls */
@@ -80,9 +48,6 @@ process_args(argc,argv)
{
BOOLEAN keep_munging_option = FALSE;
- imports_dirlist = mklnil();
- sys_imports_dirlist = mklnil();
-
argc--, argv++;
while (argc > 0 && argv[0][0] == '-') {
@@ -92,28 +57,6 @@ process_args(argc,argv)
while (keep_munging_option && *++*argv != '\0') {
switch(**argv) {
- /* -I dir */
- case 'I':
- imports_dirlist = lapp(imports_dirlist,*argv+1);
- keep_munging_option = FALSE;
- break;
-
- /* -J dir (for system imports) */
- case 'J':
- sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
- keep_munging_option = FALSE;
- break;
-
- case 'g':
- strcpy(PreludeHiSuffix, *argv+1);
- keep_munging_option = FALSE;
- break;
-
- case 'h':
- strcpy(HiSuffix, *argv+1);
- keep_munging_option = FALSE;
- break;
-
case 'v':
who_am_i(); /* identify myself */
verbose = TRUE;
@@ -132,14 +75,6 @@ process_args(argc,argv)
ignoreSCC = FALSE;
break;
- case 'p':
- ignorePragmas = TRUE;
- break;
-
- case 'P':
- implicitPrelude = FALSE;
- break;
-
case 'D':
#ifdef HSP_DEBUG
{ extern int yydebug;
@@ -172,41 +107,11 @@ process_args(argc,argv)
exit(1);
}
-
- /* By default, imports come from the directory of the source file */
- if ( argc >= 1 )
- {
- char *endchar;
-
- input_file_dir = xmalloc (strlen(argv[0]) + 1);
- strcpy(input_file_dir, argv[0]);
-#ifdef macintosh
- endchar = rindex(input_file_dir, (int) ':');
-#else
- endchar = rindex(input_file_dir, (int) '/');
-#endif /* ! macintosh */
-
- if ( endchar == NULL )
- {
- free(input_file_dir);
- input_file_dir = ".";
- }
- else
- *endchar = '\0';
- }
-
- /* No input file -- imports come from the current directory first */
- else
- input_file_dir = ".";
-
- imports_dirlist = mklcons( input_file_dir, imports_dirlist );
-
- if (verbose)
- {
+ if (verbose) {
fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
if(acceptPrim)
fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
- }
+ }
}
void
diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h
index c396992e6fea2add98e596ff6d667b315367eeaa..816304c91385e91646993578d57950b266f4e1a1 100644
--- a/ghc/compiler/parser/utils.h
+++ b/ghc/compiler/parser/utils.h
@@ -17,21 +17,7 @@ extern BOOLEAN etags;
extern BOOLEAN ignoreSCC;
-extern BOOLEAN implicitPrelude;
-extern BOOLEAN ignorePragmas;
-
-extern int minAcceptablePragmaVersion;
-extern int maxAcceptablePragmaVersion;
-extern int thisIfacePragmaVersion;
-
extern unsigned hash_table_size;
-extern char *input_file_dir;
-
-extern list imports_dirlist;
-extern list sys_imports_dirlist;
-
-extern char HiSuffix[];
-extern char PreludeHiSuffix[];
void process_args PROTO((int, char **));
@@ -129,7 +115,6 @@ void checkprec PROTO((tree, qid, BOOLEAN));
BOOLEAN isconstr PROTO((char *));
void setstartlineno PROTO((void));
-void find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
/* mattson additions */
char *xstrdup PROTO((char *)); /* Duplicate a string */
diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs
index 6f6b12b7c8b8f29fa4670c38a0bca204f701c870..caa46c28d5a757c4df287246a4afc01f06d5c209 100644
--- a/ghc/compiler/profiling/SCCauto.lhs
+++ b/ghc/compiler/profiling/SCCauto.lhs
@@ -47,7 +47,7 @@ addAutoCostCentres mod_name binds
grp_name
= case opt_SccGroup of
- Just xx -> xx
+ Just xx -> _PK_ xx
Nothing -> mod_name -- default: module name
-----------------------------
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
new file mode 100644
index 0000000000000000000000000000000000000000..f083712cce2b19ae6968290f83f4a26c12e46b26
--- /dev/null
+++ b/ghc/compiler/rename/ParseIface.y
@@ -0,0 +1,290 @@
+{
+#include "HsVersions.h"
+
+module ParseIface (
+ parseIface,
+
+ ParsedIface(..), RdrIfaceDecl(..),
+
+ ExportsMap(..), LocalDefsMap(..), LocalPragmasMap(..),
+ LocalVersionsMap(..), PragmaStuff(..)
+
+ ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn ( ClassDecl, InstDecl, TyDecl, PolyType, InPat, Fake )
+import RdrHsSyn ( RdrNameTyDecl(..), RdrNameClassDecl(..),
+ RdrNamePolyType(..), RdrNameInstDecl(..)
+ )
+import FiniteMap ( emptyFM, listToFM, fmToList, lookupFM, keysFM, FiniteMap )
+import Name ( ExportFlag(..) )
+import Util ( startsWith )
+-----------------------------------------------------------------
+
+parseIface = parseIToks . lexIface
+
+type LocalVersionsMap = FiniteMap FAST_STRING Version
+type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
+type LocalDefsMap = FiniteMap FAST_STRING RdrIfaceDecl
+type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
+
+type PragmaStuff = String
+
+data ParsedIface
+ = ParsedIface
+ Module -- Module name
+ Version -- Module version number
+ (Maybe Version) -- Source version number
+ LocalVersionsMap -- Local version numbers
+ ExportsMap -- Exported names
+ [Module] -- Special instance modules
+ LocalDefsMap -- Local names defined
+ [RdrIfaceDecl] -- Local instance declarations
+ LocalPragmasMap -- Pragmas for local names
+
+{-
+instance Text ParsedIface where
+ showsPrec _ (ParsedIface m v mv lcm exm ims ldm lids ldp)
+ = showString "interface "
+ . showString (_UNPK_ m)
+ . showChar ' '
+ . showInt v
+ . showString "\n__versions__\n"
+ . showList (fmToList lcm)
+ . showString "\n__exports__\n"
+ . showList (fmToList exm)
+ . showString "\n__instance_modules__\n"
+ . showList (map _UNPK_ ims)
+ . showString "\n__declarations__\n"
+ . showList (map _UNPK_ (keysFM ldm))
+ . showString "\n__instances__\n"
+ . showList lids
+ . showString "\n__pragmas__\n"
+ . showList (map _UNPK_ (keysFM ldp))
+-}
+
+-----------------------------------------------------------------
+
+data RdrIfaceDecl
+ = TypeSig RdrName Bool SrcLoc RdrNameTyDecl
+ | NewTypeSig RdrName RdrName Bool SrcLoc RdrNameTyDecl
+ | DataSig RdrName [RdrName] Bool SrcLoc RdrNameTyDecl
+ | ClassSig RdrName [RdrName] Bool SrcLoc RdrNameClassDecl
+ | ValSig RdrName Bool SrcLoc RdrNamePolyType
+ | InstSig RdrName RdrName Bool SrcLoc RdrNameInstDecl
+ -- True => Source Iface decl
+-----------
+type Version = Int
+
+-----------------------------------------------------------------
+}
+
+%name parseIToks
+%tokentype { IfaceToken }
+
+%token
+ interface { ITinterface }
+ versions_part { ITversions }
+ exports_part { ITexports }
+ instance_modules_part { ITinstance_modules }
+ instances_part { ITinstances }
+ declarations_part { ITdeclarations }
+ pragmas_part { ITpragmas }
+ data { ITdata }
+ type { ITtype }
+ newtype { ITnewtype }
+ class { ITclass }
+ where { ITwhere }
+ instance { ITinstance }
+ bar { ITbar }
+ colons { ITcolons }
+ comma { ITcomma }
+ dblrarrow { ITdblrarrow }
+ dot { ITdot }
+ dotdot { ITdotdot }
+ equal { ITequal }
+ lbrace { ITlbrace }
+ lbrack { ITlbrack }
+ lparen { ITlparen }
+ rarrow { ITrarrow }
+ rbrace { ITrbrace }
+ rbrack { ITrbrack }
+ rparen { ITrparen }
+ semicolon { ITsemicolon }
+ num { ITnum $$ }
+ name { ITname $$ }
+%%
+
+Iface :: { ParsedIface }
+Iface : interface name num
+ VersionsPart ExportsPart InstanceModulesPart
+ DeclsPart InstancesPart PragmasPart
+ { ParsedIface $2 (fromInteger $3) Nothing{-src version-}
+ $4 -- local versions
+ $5 -- exports map
+ $6 -- instance modules
+ $7 -- decls map
+ $8 -- local instances
+ $9 -- pragmas map
+ }
+
+VersionsPart :: { LocalVersionsMap }
+VersionsPart : versions_part NameVersionPairs
+ { listToFM $2 }
+
+NameVersionPairs :: { [(FAST_STRING, Int)] }
+NameVersionPairs : NameVersionPairs name lparen num rparen
+ { ($2, fromInteger $4) : $1 }
+ | { [] }
+
+ExportsPart :: { ExportsMap }
+ExportsPart : exports_part ExportItems
+ { listToFM $2 }
+
+ExportItems :: { [(FAST_STRING, (RdrName, ExportFlag))] }
+ExportItems : ExportItems name dot name MaybeDotDot
+ { ($4, (Qual $2 $4, $5)) : $1 }
+ | { [] }
+
+MaybeDotDot :: { ExportFlag }
+MaybeDotDot : dotdot { ExportAll }
+ | { ExportAbs }
+
+InstanceModulesPart :: { [Module] }
+InstanceModulesPart : instance_modules_part ModList
+ { $2 }
+
+ModList :: { [Module] }
+ModList : ModList name { $2 : $1 }
+ | { [] }
+
+DeclsPart :: { LocalDefsMap }
+DeclsPart : declarations_part
+ { emptyFM }
+
+InstancesPart :: { [RdrIfaceDecl] }
+InstancesPart : instances_part
+ { [] }
+
+PragmasPart :: { LocalPragmasMap }
+PragmasPart : pragmas_part
+ { emptyFM }
+{
+-----------------------------------------------------------------
+happyError :: Int -> [IfaceToken] -> a
+happyError i _ = error ("Parse error in line " ++ show i ++ "\n")
+
+-----------------------------------------------------------------
+data IfaceToken
+ = ITinterface -- keywords
+ | ITversions
+ | ITexports
+ | ITinstance_modules
+ | ITinstances
+ | ITdeclarations
+ | ITpragmas
+ | ITdata
+ | ITtype
+ | ITnewtype
+ | ITclass
+ | ITwhere
+ | ITinstance
+ | ITbar -- magic symbols
+ | ITcolons
+ | ITcomma
+ | ITdblrarrow
+ | ITdot
+ | ITdotdot
+ | ITequal
+ | ITlbrace
+ | ITlbrack
+ | ITlparen
+ | ITrarrow
+ | ITrbrace
+ | ITrbrack
+ | ITrparen
+ | ITsemicolon
+ | ITnum Integer -- numbers and names
+ | ITname FAST_STRING
+
+-----------------------------------------------------------------
+lexIface :: String -> [IfaceToken]
+
+lexIface str
+ = case str of
+ [] -> []
+
+ -- whitespace and comments
+ ' ' : cs -> lexIface cs
+ '\t' : cs -> lexIface cs
+ '\n' : cs -> lexIface cs
+ '-' : '-' : cs -> lex_comment cs
+ '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
+
+ '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
+ '(' : cs -> ITlparen : lexIface cs
+ ')' : cs -> ITrparen : lexIface cs
+ '[' : cs -> ITlbrack : lexIface cs
+ ']' : cs -> ITrbrack : lexIface cs
+ '{' : cs -> ITlbrace : lexIface cs
+ '}' : cs -> ITrbrace : lexIface cs
+ '-' : '>' : cs -> ITrarrow : lexIface cs
+ '.' : cs -> ITdot : lexIface cs
+ '|' : cs -> ITbar : lexIface cs
+ ':' : ':' : cs -> ITcolons : lexIface cs
+ '=' : '>' : cs -> ITdblrarrow : lexIface cs
+ '=' : cs -> ITequal : lexIface cs
+ ',' : cs -> ITcomma : lexIface cs
+ ';' : cs -> ITsemicolon : lexIface cs
+
+ '_' : cs -> lex_word str
+ c : cs | isDigit c -> lex_num str
+ | isAlpha c -> lex_word str
+
+ other -> error ("lexing:"++other)
+ where
+ lex_comment str
+ = case (span ((/=) '\n') str) of { (junk, rest) ->
+ lexIface rest }
+
+ lex_nested_comment lvl [] = error "EOF in nested comment in interface"
+ lex_nested_comment lvl str
+ = case str of
+ '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
+ '-' : '}' : xs -> if lvl == 1
+ then lexIface xs
+ else lex_nested_comment (lvl-1) xs
+ _ : xs -> lex_nested_comment lvl xs
+
+ lex_num str
+ = case (span isDigit str) of { (num, rest) ->
+ ITnum (read num) : lexIface rest }
+
+ lex_word str
+ = case (span is_word_sym str) of { (word, rest) ->
+ case (lookupFM keywordsFM word) of {
+ Nothing -> ITname (_PK_ word) : lexIface rest ;
+ Just xx -> xx : lexIface rest
+ }}
+ where
+ is_word_sym '_' = True
+ is_word_sym c = isAlphanum c
+
+ keywordsFM :: FiniteMap String IfaceToken
+ keywordsFM = listToFM [
+ ("interface", ITinterface)
+
+ ,("__versions__", ITversions)
+ ,("__exports__", ITexports)
+ ,("__instance_modules__", ITinstance_modules)
+ ,("__instances__", ITinstances)
+ ,("__declarations__", ITdeclarations)
+ ,("__pragmas__", ITpragmas)
+
+ ,("data", ITdata)
+ ,("class", ITclass)
+ ,("where", ITwhere)
+ ,("instance", ITinstance)
+ ]
+}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index ed86172ab44fcf6370e04ce21864c6f951d1fa58..c040d6d4a3cb5b206c33a3bca983526bdb0e0279 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -16,14 +16,16 @@ import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass )
+import ParseIface ( ParsedIface )
import RnMonad
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
-import RnIfaces ( findHiFiles, rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface )
+import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
import MainMonad
import Bag ( isEmptyBag, unionBags, bagToList, listToBag )
+import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM )
import Name ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) )
@@ -31,8 +33,6 @@ import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
import Util ( panic, assertPanic )
-
-opt_HiDirList = panic "opt_HiDirList"
\end{code}
\begin{code}
@@ -62,8 +62,9 @@ ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
renameModule b_names b_keys us
input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
- = findHiFiles opt_HiDirList `thenPrimIO` \ hi_files ->
- newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var ->
+
+ = findHiFiles opt_HiDirList opt_SysHiDirList `thenMn` \ hi_files ->
+ newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var ->
fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
let
@@ -127,7 +128,7 @@ renameModule b_names b_keys us
-- ToDo: Do we need top-level names from this module in orig_env ???
in
ASSERT (isEmptyBag orig_dups)
- rnInterfaces iface_var orig_env us3 rn_module imports_used
+ rnIfaces iface_var orig_env us3 rn_module imports_used
`thenPrimIO` \ (rn_module_with_imports,
(implicit_val_fm, implicit_tc_fm),
iface_errs, iface_warns) ->
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 9745409a15d196874737a88213bb3cf8f41fe83a..9a9dab872621e7182a3735cc8607cdcfaf76703e 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -8,42 +8,45 @@
module RnIfaces (
findHiFiles,
- cacheInterface,
- readInterface,
- rnInterfaces,
+ cachedIface,
+ readIface,
+ rnIfaces,
finalIfaceInfo,
IfaceCache(..),
- VersionInfo(..),
- ParsedIface(..)
+ VersionInfo(..)
) where
-import PreludeGlaST ( returnPrimIO, thenPrimIO,
- readVar, writeVar, MutableVar(..) )
-
import Ubiq
+import LibDirectory
+import PreludeGlaST ( returnPrimIO, thenPrimIO, seqPrimIO,
+ readVar, writeVar, MutableVar(..)
+ )
+
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnUtils ( RnEnv(..) )
+import ParseIface ( parseIface, ParsedIface )
import Bag ( emptyBag )
+import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM )
import Pretty
import Maybes ( MaybeErr(..) )
-import Util ( panic )
-
+import Util ( startsWith, panic )
\end{code}
-
\begin{code}
-type IfaceCache = MutableVar _RealWorld (FiniteMap Module ParsedIface,
- FiniteMap Module String)
+type ModuleToIfaceContents = FiniteMap Module ParsedIface
+type ModuleToIfaceFilePath = FiniteMap Module FilePath
-data ParsedIface = ParsedIface
+type IfaceCache
+ = MutableVar _RealWorld (ModuleToIfaceContents,
+ ModuleToIfaceFilePath)
\end{code}
*********************************************************
@@ -52,9 +55,57 @@ data ParsedIface = ParsedIface
* *
*********************************************************
+Return a mapping from module-name to
+absolute-filename-for-that-interface.
\begin{code}
-findHiFiles :: [String] -> PrimIO (FiniteMap Module String)
-findHiFiles dirs = returnPrimIO emptyFM
+findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
+
+findHiFiles dirs sysdirs
+ = do_dirs emptyFM (dirs ++ sysdirs)
+ where
+ do_dirs env [] = return env
+ do_dirs env (dir:dirs)
+ = do_dir env dir >>= \ new_env ->
+ do_dirs new_env dirs
+ -------
+ do_dir env dir
+ = --trace ("Having a go on..."++dir) $
+ getDirectoryContents dir >>= \ entries ->
+ do_entries env entries
+ -------
+ do_entries env [] = return env
+ do_entries env (e:es)
+ = do_entry env e >>= \ new_env ->
+ do_entries new_env es
+ -------
+ do_entry env e
+ = case (acceptable_hi (reverse e)) of
+ Nothing -> --trace ("Deemed uncool:"++e) $
+ return env
+ Just mod -> let
+ pmod = _PK_ mod
+ in
+ case (lookupFM env pmod) of
+ Nothing -> --trace ("Adding "++mod++" -> "++e) $
+ return (addToFM env pmod e)
+ Just xx -> trace ("Already mapped: "++mod++" -> "++xx) $
+ return env
+ -------
+ acceptable_hi rev_e -- looking at pathname *backwards*
+ = case (startsWith (reverse opt_HiSuffix) rev_e) of
+ Nothing -> Nothing
+ Just xs -> plausible_modname xs{-reversed-}
+
+ -------
+ plausible_modname rev_e
+ = let
+ cand = reverse (takeWhile is_modname_char rev_e)
+ in
+ if null cand || not (isUpper (head cand))
+ then Nothing
+ else Just cand
+ where
+ is_modname_char c = isAlphanum c || c == '_'
\end{code}
*********************************************************
@@ -63,49 +114,59 @@ findHiFiles dirs = returnPrimIO emptyFM
* *
*********************************************************
+Return cached info about a Module's interface; otherwise,
+read the interface (using our @ModuleToIfaceFilePath@ map
+to decide where to look).
+
\begin{code}
-cacheInterface :: IfaceCache -> Module
- -> PrimIO (MaybeErr ParsedIface Error)
+cachedIface :: IfaceCache
+ -> Module
+ -> IO (MaybeErr ParsedIface Error)
-cacheInterface iface_var mod
+cachedIface iface_var mod
= readVar iface_var `thenPrimIO` \ (iface_fm, file_fm) ->
- case lookupFM iface_fm mod of
- Just iface -> returnPrimIO (Succeeded iface)
+
+ case (lookupFM iface_fm mod) of
+ Just iface -> return (Succeeded iface)
Nothing ->
- case lookupFM file_fm mod of
- Nothing -> returnPrimIO (Failed (noIfaceErr mod))
+ case (lookupFM file_fm mod) of
+ Nothing -> return (Failed (noIfaceErr mod))
Just file ->
- readInterface file mod `thenPrimIO` \ read_iface ->
+ readIface file mod >>= \ read_iface ->
case read_iface of
- Failed err -> returnPrimIO (Failed err)
+ Failed err -> return (Failed err)
Succeeded iface ->
let
iface_fm' = addToFM iface_fm mod iface
in
- writeVar iface_var (iface_fm', file_fm) `thenPrimIO` \ _ ->
- returnPrimIO (Succeeded iface)
-
-
-readInterface :: String -> Module
- -> PrimIO (MaybeErr ParsedIface Error)
+ writeVar iface_var (iface_fm', file_fm) `seqPrimIO`
+ return (Succeeded iface)
+\end{code}
-readInterface file mod = panic "readInterface"
+\begin{code}
+readIface :: FilePath -> Module
+ -> IO (MaybeErr ParsedIface Error)
+
+readIface file mod
+ = readFile file `thenPrimIO` \ read_result ->
+ case read_result of
+ Left err -> return (Failed (cannaeReadErr file))
+ Right contents -> return (Succeeded (parseIface contents))
\end{code}
\begin{code}
-rnInterfaces ::
- IfaceCache -- iface cache
- -> RnEnv -- original name env
- -> UniqSupply
- -> RenamedHsModule -- module to extend with iface decls
- -> [RnName] -- imported names required
- -> PrimIO (RenamedHsModule, -- extended module
- ImplicitEnv, -- implicit names required
- Bag Error,
- Bag Warning)
-
-rnInterfaces iface_var occ_env us rn_module todo
+rnIfaces :: IfaceCache -- iface cache
+ -> RnEnv -- original name env
+ -> UniqSupply
+ -> RenamedHsModule -- module to extend with iface decls
+ -> [RnName] -- imported names required
+ -> PrimIO (RenamedHsModule, -- extended module
+ ImplicitEnv, -- implicit names required
+ Bag Error,
+ Bag Warning)
+
+rnIfaces iface_var occ_env us rn_module todo
= returnPrimIO (rn_module, (emptyFM, emptyFM), emptyBag, emptyBag)
\end{code}
@@ -127,5 +188,8 @@ finalIfaceInfo iface_var imps_reqd imp_mods
\begin{code}
noIfaceErr mod sty
- = ppCat [ppStr "Could not find interface for", ppPStr mod]
+ = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
+
+cannaeReadErr file sty
+ = ppCat [ppPStr SLIT("Failed in reading file:"), ppStr file]
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 15599106bccda27527cf77ad67b527be2b224822..f391cbc09e3b0039c6af792ac5f4f5e769ed8e1f 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -19,8 +19,9 @@ import HsSyn
import RdrHsSyn
import RnHsSyn
+import ParseIface ( ParsedIface )
import RnMonad
-import RnIfaces ( IfaceCache(..), cacheInterface, ParsedIface )
+import RnIfaces ( IfaceCache(..), cachedIface )
import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index b52c6035b6a613cf997b75ad1d3e3acfb73e4895..06059714abcaa4d262409c0d1064ce0c150d3799 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -36,7 +36,7 @@ import Id ( idType, mkSysLocal, toplevelishId,
)
import Pretty ( ppStr, ppBesides, ppChar, ppInt )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( isPrimType, mkTyVarTys )
+import Type ( isPrimType, mkTyVarTys, mkForAllTys )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
growTyVarEnvList, lookupTyVarEnv,
tyVarSetToList,
@@ -49,7 +49,6 @@ import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
import Usage ( UVar(..) )
import Util ( mapAccumL, zipWithEqual, panic, assertPanic )
-quantifyTy = panic "SetLevels.quantifyTy (ToDo)"
isLeakFreeType = panic "SetLevels.isLeakFreeType (ToDo)"
\end{code}
@@ -514,7 +513,7 @@ abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
in
returnLvl final_expr
where
- poly_ty = snd (quantifyTy offending_tyvars ty)
+ poly_ty = mkForAllTys offending_tyvars ty
-- These defns are just like those in the TyLam case of lvlExpr
(incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
@@ -648,9 +647,7 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
| otherwise = []
offending_tyvar_tys = mkTyVarTys offending_tyvars
- poly_tys = [ snd (quantifyTy offending_tyvars ty)
- | ty <- tys
- ]
+ poly_tys = map (mkForAllTys offending_tyvars) tys
offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
\end{code}
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 48ac2b65010aee428c7cbeae8f5091851377aba0..9b9cbf1f4fd2c4c2598ff9803a0de198abafa7bf 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -112,10 +112,10 @@ stg2stg stg_todos module_name ppr_style us binds
(do_unlocalising, unlocal_tag)
= case (opt_EnsureSplittableC) of
Nothing -> (False, panic "tag")
- Just tag -> (True, tag)
+ Just tag -> (True, _PK_ tag)
grp_name = case (opt_SccGroup) of
- Just xx -> xx
+ Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
-------------
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 0b9913ceef30c441295202ef7814ec31be52bfbb..a7dd9e3eba4bfe83b926c2081f2b80ab5d7ca27e 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -19,13 +19,13 @@ import Id ( idType, mkSysLocal, dataConArgTys )
import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
import PrelInfo ( aBSENT_ERROR_ID )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( isPrimType, mkTyVarTys, mkFunTys, maybeAppDataTyCon )
+import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
+ maybeAppDataTyCon
+ )
import UniqSupply ( returnUs, thenUs, thenMaybeUs,
getUniques, UniqSM(..)
)
import Util ( zipWithEqual, assertPanic, panic )
-
-quantifyTy = panic "WwLib.quantifyTy"
\end{code}
%************************************************************************
@@ -224,9 +224,8 @@ mkWwBodies body_ty tyvars args arg_infos
)
worker_ty_w_hole = \ body_ty ->
- snd (quantifyTy tyvars (
+ mkForAllTys tyvars $
mkFunTys (map idType work_args) body_ty
- ))
in
returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
where
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 83692966279ca321be88b95728e50fdd13d5e48d..b51e4880cb45412a085a62679366cc5a5b7057f2 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -255,6 +255,10 @@ zonkMatch (GRHSMatch grhss_w_binds)
= zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
returnNF_Tc (GRHSMatch new_grhss_w_binds)
+zonkMatch (SimpleMatch expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SimpleMatch new_expr)
+
-------------------------------------------------------------------------
zonkGRHSsAndBinds :: TcGRHSsAndBinds s
-> NF_TcM s TypecheckedGRHSsAndBinds
@@ -309,6 +313,9 @@ zonkExpr (OpApp e1 op e2)
zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op new_e2)
+zonkExpr (NegApp _) = panic "zonkExpr:NegApp"
+zonkExpr (HsPar _) = panic "zonkExpr:HsPar"
+
zonkExpr (SectionL expr op)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkExpr op `thenNF_Tc` \ new_op ->
@@ -319,25 +326,24 @@ zonkExpr (SectionR op expr)
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (SectionR new_op new_expr)
-zonkExpr (CCall fun args may_gc is_casm result_ty)
- = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
- zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
- returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-
-zonkExpr (HsSCC label expr)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsSCC label new_expr)
-
zonkExpr (HsCase expr ms src_loc)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
returnNF_Tc (HsCase new_expr new_ms src_loc)
+zonkExpr (HsIf e1 e2 e3 src_loc)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
+
zonkExpr (HsLet binds expr)
= zonkBinds binds `thenNF_Tc` \ new_binds ->
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
+zonkExpr (HsDo _ _) = panic "zonkExpr:HsDo"
+
zonkExpr (HsDoOut stmts m_id mz_id src_loc)
= zonkStmts stmts `thenNF_Tc` \ new_stmts ->
zonkId m_id `thenNF_Tc` \ m_new ->
@@ -349,7 +355,7 @@ zonkExpr (ListComp expr quals)
zonkQuals quals `thenNF_Tc` \ new_quals ->
returnNF_Tc (ListComp new_expr new_quals)
---ExplicitList: not in typechecked exprs
+zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
zonkExpr (ExplicitListOut ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
@@ -364,18 +370,26 @@ zonkExpr (RecordCon con rbinds)
= panic "zonkExpr:RecordCon"
zonkExpr (RecordUpd exp rbinds)
= panic "zonkExpr:RecordUpd"
+zonkExpr (RecordUpdOut exp ids rbinds)
+ = panic "zonkExpr:RecordUpdOut"
-zonkExpr (HsIf e1 e2 e3 src_loc)
- = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr e2 `thenNF_Tc` \ new_e2 ->
- zonkExpr e3 `thenNF_Tc` \ new_e3 ->
- returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
+zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
+zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
zonkExpr (ArithSeqOut expr info)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkArithSeq info `thenNF_Tc` \ new_info ->
returnNF_Tc (ArithSeqOut new_expr new_info)
+zonkExpr (CCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
+ zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
+ returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+
+zonkExpr (HsSCC label expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsSCC label new_expr)
+
zonkExpr (TyLam tyvars expr)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
zonkExpr expr `thenNF_Tc` \ new_expr ->
@@ -411,6 +425,11 @@ zonkExpr (SingleDict name)
= zonkId name `thenNF_Tc` \ new_name ->
returnNF_Tc (SingleDict new_name)
+zonkExpr (HsCon con tys vargs)
+ = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
+ mapNF_Tc zonkExpr vargs `thenNF_Tc` \ new_vargs ->
+ returnNF_Tc (HsCon con new_tys new_vargs)
+
-------------------------------------------------------------------------
zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index e8595fd7e96acb54789b7be1e678119a1c26a55e..89a90b033e2f063652ccc70655aaee31f04bebf6 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -23,8 +23,9 @@ import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
RnName{-instance Outputable-}
)
-import TcHsSyn ( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) )
-
+import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, zonkId,
+ TcHsBinds(..), TcIdOcc(..)
+ )
import Inst ( newDicts, InstOrigin(..), Inst )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
import TcType ( tcInstTyVars, tcInstType, tcInstId )
@@ -245,7 +246,7 @@ mkConstructor con_id
-- Build the data constructor
let
con_rhs = mkHsTyLam tyvars $
- DictLam dicts $
+ mkHsDictLam dicts $
mk_pat_match args $
mk_case strict_args $
HsCon con_id arg_tys (map HsVar args)
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 68fdb493fb0e7b9e1878c7fe135b693ad2c0f073..2aaec61a283785a9e929f1f32f36892af7a37005 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -40,6 +40,7 @@ module Util (
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy,
nOfThem, lengthExceeds, isSingleton,
+ startsWith, endsWith,
#if defined(COMPILING_GHC)
isIn, isn'tIn,
#endif
@@ -196,6 +197,17 @@ isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton _ = False
+
+startsWith, endsWith :: String -> String -> Maybe String
+
+startsWith [] str = Just str
+startsWith (c:cs) (s:ss)
+ = if c /= s then Nothing else startsWith cs ss
+
+endsWith cs ss
+ = case (startsWith (reverse cs) (reverse ss)) of
+ Nothing -> Nothing
+ Just rs -> Just (reverse rs)
\end{code}
Debugging/specialising versions of \tr{elem} and \tr{notElem}