Commit c49d51f8 authored by partain's avatar partain

[project @ 1996-04-10 18:10:47 by partain]

Add SLPJ/WDP 1.3 changes through 960410
parent f0e42a46
......@@ -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
......
......@@ -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 ???
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
-----------------
......
......@@ -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}
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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:
......
......@@ -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)
----------------------------------------------------------
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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) {
......
......@@ -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 */
/*