Commit 9d4c0380 authored by partain's avatar partain

[project @ 1996-06-30 15:56:44 by partain]

partain 1.3 changes through 960629
parent da3d8948
......@@ -611,7 +611,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/ParseIface,hs,-Onot) /* sigh */
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
......
......@@ -5,4 +5,17 @@ MachMisc fixedHdrSizeInWords (..)
MachMisc varHdrSizeInWords (..)
CgRetConv ctrlReturnConvAlg (..)
CgRetConv CtrlReturnConvention(..)
ClosureInfo closureKind (..)
ClosureInfo closureLabelFromCI (..)
ClosureInfo closureNonHdrSize (..)
ClosureInfo closurePtrsSize (..)
ClosureInfo closureSMRep (..)
ClosureInfo closureSemiTag (..)
ClosureInfo closureSizeWithoutFixedHdr (..)
ClosureInfo closureTypeDescr (..)
ClosureInfo closureUpdReqd (..)
ClosureInfo infoTableLabelFromCI (..)
ClosureInfo maybeSelectorInfo (..)
ClosureInfo entryLabelFromCI (..)
ClosureInfo fastLabelFromCI (..)
\end{code}
......@@ -20,6 +20,9 @@ module PprAbsC (
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
IMPORT_1_3(IO(Handle))
IMPORT_1_3(Char(isDigit,isPrint))
IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
import AbsCSyn
......@@ -35,7 +38,7 @@ import CmdLineOpts ( opt_SccProfilingOn )
import CostCentre ( uppCostCentre, uppCostCentreDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import FiniteMap ( addToFM, emptyFM, lookupFM )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
import Literal ( showLiteral, Literal(..) )
import Maybes ( maybeToBool, catMaybes )
......@@ -799,7 +802,11 @@ process_casm results args string = process results args string
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
case readDec other of
let
read_int :: ReadS Int
read_int = reads
in
case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
then uppBeside (uppParens (args !! num))
......
......@@ -83,6 +83,7 @@ import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import Unique ( pprUnique )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
#ifdef REALLY_HASKELL_1_3
......@@ -766,7 +767,7 @@ pp_unfolding sty for_this_id inline_env uf_details
pp NoUnfoldingDetails = pp_NONE
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
= ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
pp (GenForm _ _ BadUnfolding) = pp_NONE
......
......@@ -70,7 +70,7 @@ data UnfoldingDetails
| OtherLitForm [Literal]
| OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
| GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
| MagicForm _PackedString MagicUnfoldingFun
| MagicForm Unique MagicUnfoldingFun
data UnfoldingGuidance
= UnfoldNever
......
......@@ -20,7 +20,7 @@ import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
import Type ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon )
import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
import Util ( panic )
......@@ -44,7 +44,7 @@ primOpId op
mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
Coercing str ty1 ty2 ->
mk_prim_Id op str [] [ty1] (mkFunTys [ty1] ty2) 1
mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mk_prim_Id op str
......@@ -72,7 +72,7 @@ primOpId op
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTys [ty] ty
monadic_fun_ty ty = ty `mkFunTy` ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
......
......@@ -132,7 +132,6 @@ module Unique (
parIdKey,
patErrorIdKey,
primIoTyConKey,
primIoDataConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
......@@ -590,7 +589,6 @@ stateDataConKey = mkPreludeDataConUnique 39
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
stDataConKey = mkPreludeDataConUnique 42
primIoDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
......
......@@ -7,7 +7,7 @@
#include "HsVersions.h"
module CgBindery (
CgBindings(..), CgIdInfo(..){-dubiously concrete-},
SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
StableLoc, VolatileLoc,
maybeAStkLoc, maybeBStkLoc,
......@@ -34,7 +34,7 @@ import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
import CLabel ( mkClosureLabel )
import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument )
import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
import HeapOffs ( SYN_IE(VirtualHeapOffset),
SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
)
......
......@@ -63,8 +63,8 @@ import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
)
import TyCon ( isEnumerationTyCon )
import Type ( typePrimRep,
getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
isEnumerationTyCon
getAppSpecDataTyConExpandingDicts,
maybeAppSpecDataTyConExpandingDicts
)
import Util ( sortLt, isIn, isn'tIn, zipEqual,
pprError, panic, assertPanic
......
......@@ -24,15 +24,14 @@ import CgBindery ( getCAddrMode, getArgAmodes,
getCAddrModeAndInfo, bindNewToNode,
bindNewToAStack, bindNewToBStack,
bindNewToReg, bindArgsToRegs,
stableAmodeIdInfo, heapIdInfo
stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
import CgCompInfo ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
, heapCheckOnly, fetchAndReschedule, yield -- HWL
)
import CgRetConv ( mkLiveRegsMask,
ctrlReturnConvAlg, dataReturnConvAlg,
import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
......
......@@ -26,7 +26,7 @@ import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
bindArgsToRegs, newTempAmodeAndIdInfo,
idInfoToAmode, stableAmodeIdInfo,
heapIdInfo
heapIdInfo, CgIdInfo
)
import CgClosure ( cgTopRhsClosure )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
......
......@@ -16,8 +16,7 @@ import CgMonad
import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
import CgCompInfo ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
import CgRetConv ( mkLiveRegsMask,
dataReturnConvAlg, ctrlReturnConvAlg,
import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
DataReturnConvention(..)
)
......@@ -33,7 +32,7 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon,
infoTableLabelFromCI, dataConLiveness
)
import CostCentre ( dontCareCostCentre )
import FiniteMap ( fmToList )
import FiniteMap ( fmToList, FiniteMap )
import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) )
import Id ( dataConTag, dataConRawArgTys,
dataConNumFields, fIRST_TAG,
......
......@@ -20,7 +20,7 @@ import CgMonad
import AbsCSyn
import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
import CgBindery ( getArgAmodes )
import CgBindery ( getArgAmodes, CgIdInfo )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
......
......@@ -20,7 +20,6 @@ import AbsCSyn
import CgMonad
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgRetConv ( mkLiveRegsMask )
import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
initHeapUsage
)
......
......@@ -20,7 +20,8 @@ import CgMonad
import AbsCSyn
import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
bindNewToAStack, bindNewToBStack
bindNewToAStack, bindNewToBStack,
CgIdInfo
)
import CgHeapery ( heapCheck )
import CgRetConv ( assignRegs )
......
\begin{code}
interface CgLoop2_1_3 1
__exports__
Outputable Outputable (..)
CgExpr cgExpr (..)
CgExpr getPrimOpArgAmodes (..)
\end{code}
......@@ -34,7 +34,8 @@ import CgStackery ( adjustRealSps, mkStkAmodes )
import CgUsages ( getSpARelOffset )
import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..)
getEntryConvention, EntryConvention(..),
LambdaFormInfo
)
import CmdLineOpts ( opt_DoSemiTagging )
import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) )
......
......@@ -27,6 +27,7 @@ import AbsCSyn
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import Bag ( foldBag )
import CgBindery ( CgIdInfo )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits )
......@@ -35,6 +36,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals,
opt_EnsureSplittableC, opt_SccGroup
)
import CStrings ( modnameToC )
import FiniteMap ( FiniteMap )
import Maybes ( maybeToBool )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Util ( panic, assertPanic )
......
......@@ -50,7 +50,7 @@ import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( cloneTyVar,
isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
)
import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
getFunTy_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
......@@ -91,7 +91,7 @@ coreExprType (Con con args) = applyTypeToArgs (idType con) args
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
= mkFunTys [idType binder] (coreExprType expr)
= idType binder `mkFunTy` coreExprType expr
coreExprType (Lam (TyBinder tyvar) expr)
= mkForAllTy tyvar (coreExprType expr)
......
......@@ -11,7 +11,7 @@ module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import CoreSyn
import DsMonad
......
......@@ -18,9 +18,9 @@ IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn -- lots of things
hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TypecheckedBind(..), TypecheckedMonoBinds(..),
TypecheckedPat(..)
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds),
SYN_IE(TypecheckedPat)
)
import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
......
......@@ -16,9 +16,9 @@ import HsSyn ( failureFreePat,
Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
GRHSsAndBinds
)
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedRecordBinds(..), TypecheckedPat(..),
TypecheckedStmt(..)
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedPat),
SYN_IE(TypecheckedStmt)
)
import CoreSyn
......@@ -28,7 +28,7 @@ import DsHsSyn ( outPatType )
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
MatchResult, DsCoreArg(..)
MatchResult, SYN_IE(DsCoreArg)
)
import Match ( matchWrapper )
......
......@@ -13,9 +13,9 @@ IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds )
import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
TypecheckedPat(..), TypecheckedHsBinds(..),
TypecheckedHsExpr(..) )
import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
SYN_IE(TypecheckedHsExpr) )
import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
import DsMonad
......@@ -78,23 +78,21 @@ dsGRHSs ty kind pats (grhs:grhss)
combineGRHSMatchResults match_result1 match_result2
dsGRHS ty kind pats (OtherwiseGRHS expr locn)
= putSrcLocDs locn (
= putSrcLocDs locn $
dsExpr expr `thenDs` \ core_expr ->
let
expr_fn = \ ignore -> core_expr
in
returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
)
dsGRHS ty kind pats (GRHS guard expr locn)
= putSrcLocDs locn (
= putSrcLocDs locn $
dsExpr guard `thenDs` \ core_guard ->
dsExpr expr `thenDs` \ core_expr ->
let
expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
in
returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
)
\end{code}
......@@ -12,8 +12,8 @@ IMP_Ubiq()
import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
import TcHsSyn ( TypecheckedPat(..), TypecheckedBind(..),
TypecheckedMonoBinds(..) )
import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedBind),
SYN_IE(TypecheckedMonoBinds) )
import Id ( idType )
import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
......
......@@ -12,7 +12,7 @@ IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn ( Qualifier(..), HsExpr, HsBinds )
import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) )
import DsHsSyn ( outPatType )
import CoreSyn
......@@ -22,7 +22,7 @@ import DsUtils
import CmdLineOpts ( opt_FoldrBuildOn )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( mkBuild, foldrId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy )
import TysPrim ( alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
import TyVar ( alphaTyVar )
......@@ -49,11 +49,14 @@ dsListComp expr quals
else -- foldr/build lives!
new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) ->
let
alpha_to_alpha = mkFunTys [alphaTy] alphaTy
alpha_to_alpha = alphaTy `mkFunTy` alphaTy
c_ty = mkFunTys [expr_ty, n_ty] n_ty
g_ty = mkForAllTy alphaTyVar (
(mkFunTys [expr_ty, alpha_to_alpha] alpha_to_alpha))
(expr_ty `mkFunTy` alpha_to_alpha)
`mkFunTy`
alpha_to_alpha
)
in
newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
......@@ -138,7 +141,7 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
u2_ty = outPatType pat
res_ty = coreExprType core_list2
h_ty = mkFunTys [u1_ty] res_ty
h_ty = u1_ty `mkFunTy` res_ty
in
newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
`thenDs` \ [h', u1, u2, u3] ->
......
\begin{code}
interface DsLoop_1_3 1
__exports__
Outputable Outputable (..)
Match match (..)
Match matchSimply (..)
DsBinds dsBinds (..)
DsExpr dsExpr (..)
\end{code}
......@@ -7,7 +7,7 @@
#include "HsVersions.h"
module DsMonad (
DsM(..),
SYN_IE(DsM),
initDs, returnDs, thenDs, andDs, mapDs, listDs,
mapAndUnzipDs, zipWithDs,
uniqSMtoDsM,
......@@ -17,7 +17,7 @@ module DsMonad (
getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs,
extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
DsIdEnv(..),
SYN_IE(DsIdEnv),
lookupId,
dsShadowError,
......@@ -38,7 +38,7 @@ import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat(..) )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instances-} )
import UniqSupply ( splitUniqSupply, getUnique, getUniques,
......
......@@ -13,7 +13,7 @@ module DsUtils (
combineGRHSMatchResults,
combineMatchResults,
dsExprToAtom, DsCoreArg(..),
dsExprToAtom, SYN_IE(DsCoreArg),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
......@@ -32,7 +32,7 @@ IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedPat(..) )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
import CoreSyn
......@@ -47,7 +47,7 @@ import Id ( idType, dataConArgTys, mkTupleCon,
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
import TysPrim ( voidTy )
......@@ -578,7 +578,7 @@ mkFailurePair :: Type -- Result type of the whole case expression
-- applied to unit tuple
mkFailurePair ty
| isUnboxedType ty
= newFailLocalDs (mkFunTys [voidTy] ty) `thenDs` \ fail_fun_var ->
= newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
......
......@@ -13,8 +13,8 @@ IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
......
......@@ -13,8 +13,8 @@ IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedPat(..)
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
SYN_IE(TypecheckedPat)
)
import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) )
......
......@@ -9,6 +9,7 @@
module Main ( main ) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
import HsSyn
......
......@@ -19,17 +19,19 @@ module MkIface (
) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
import Bag ( emptyBag, snocBag, bagToList )
import Bag ( bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( fmToList, eltsFM )
import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
import Id ( idType, dataConRawArgTys, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
import Maybes ( maybeToBool )
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
isLexSym, isLocallyDefined, isWiredInName,
......@@ -45,12 +47,12 @@ import PprType -- most of it (??)
import PrelInfo ( builtinNameInfo )
import Pretty ( prettyToUn )
import Unpretty -- ditto
import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
import TcModule ( TcIfaceInfo(..) )
import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName{-instance NamedThing-} )
import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
ppr_ty ty = prettyToUn (pprType PprInterface ty)
......@@ -189,24 +191,23 @@ ifaceExportList (Just if_hdl)
= let
(vals_wired, tcs_wired)
= case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) ->
([ getName rn | rn <- eltsFM vals_fm ]
,[ getName rn | rn <- eltsFM tcs_fm ]) }
(eltsFM vals_fm, eltsFM tcs_fm) }
name_flag_pairs :: Bag (OrigName, ExportFlag)
name_flag_pairs :: FiniteMap OrigName ExportFlag
name_flag_pairs
= foldr from_wired
(foldr from_wired
= foldr (from_wired True{-val-ish-})
(foldr (from_wired False{-tycon-ish-})
(foldr from_ty
(foldr from_cls
(foldr from_sig
(from_binds binds emptyBag{-init accum-})
(from_binds binds emptyFM{-init accum-})
sigs)
classdecls)
typedecls)
tcs_wired)
vals_wired
sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
in
hPutStr if_hdl "\n__exports__\n" >>
......@@ -223,21 +224,33 @@ ifaceExportList (Just if_hdl)
from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
--------------
from_wired n acc
| exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
from_wired is_val_ish rn acc
| on_in_acc = acc -- if already in acc (presumably from real decl),
-- don't take the dubious export flag from the