From: partain Date: Wed, 10 Apr 1996 18:13:06 +0000 (+0000) Subject: [project @ 1996-04-10 18:10:47 by partain] X-Git-Tag: Approximately_1000_patches_recorded~926 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9 [project @ 1996-04-10 18:10:47 by partain] Add SLPJ/WDP 1.3 changes through 960410 --- diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 8498896..0562eb9 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 8018ad2..2046335 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 6eebe45..1a65a67 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 eeaf9da..54875d7 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 f1a0d30..016bd99 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 dc2b61a..929d40d 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 e737450..174f505 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 e45e7bc..b744e0e 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" ' if diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 6d9dc55..2900230 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 9726092..e6b80f2 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 5b74a4d..3b4face 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 7aed7ae..3b202f4 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 8f7ce33..e0a0382 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 3507b79..918a24c 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 7018511..9244022 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 055304e..a42a667 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 e54bb0b..f66949f 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) */ %} {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); } _+{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 d81de59..0000000 --- a/ghc/compiler/parser/import_dirlist.c +++ /dev/null @@ -1,223 +0,0 @@ -/********************************************************************** -* * -* * -* Import Directory List Handling * -* * -* * -**********************************************************************/ - -#include - -#include "hspincl.h" -#include "constants.h" -#include "utils.h" - -#ifdef HAVE_UNISTD_H -#include -#endif - -#ifdef HAVE_SYS_TYPES_H -#include -#else -#ifdef HAVE_TYPES_H -#include -#endif -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#ifdef HAVE_SYS_FILE_H -#include -#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 8463644..325c553 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 de26eb0..f8ebc57 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 #-} - - (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 c396992..816304c 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 6f6b12b..caa46c2 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 0000000..f083712 --- /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 ed86172..c040d6d 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 9745409..9a9dab8 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 1559910..f391cbc 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 b52c603..0605971 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 48ac2b6..9b9cbf1 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 0b9913c..a7dd9e3 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 8369296..b51e488 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 e8595fd..89a90b0 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 68fdb49..2aaec61 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}