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))
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}
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
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 )
_ -> 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))
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
+import Unique ( pprUnique )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
#ifdef REALLY_HASKELL_1_3
pp NoUnfoldingDetails = pp_NONE
pp (MagicForm tag _)
- = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
+ = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
pp (GenForm _ _ BadUnfolding) = pp_NONE
| 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
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 )
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
\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}
parIdKey,
patErrorIdKey,
primIoTyConKey,
- primIoDataConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
stDataConKey = mkPreludeDataConUnique 42
-primIoDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
#include "HsVersions.h"
module CgBindery (
- CgBindings(..), CgIdInfo(..){-dubiously concrete-},
+ SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
StableLoc, VolatileLoc,
maybeAStkLoc, maybeBStkLoc,
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)
)
)
import TyCon ( isEnumerationTyCon )
import Type ( typePrimRep,
- getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
- isEnumerationTyCon
+ getAppSpecDataTyConExpandingDicts,
+ maybeAppSpecDataTyConExpandingDicts
)
import Util ( sortLt, isIn, isn'tIn, zipEqual,
pprError, panic, assertPanic
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,
import CgBindery ( getArgAmodes, bindNewToNode,
bindArgsToRegs, newTempAmodeAndIdInfo,
idInfoToAmode, stableAmodeIdInfo,
- heapIdInfo
+ heapIdInfo, CgIdInfo
)
import CgClosure ( cgTopRhsClosure )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
import CgCompInfo ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( mkLiveRegsMask,
- dataReturnConvAlg, ctrlReturnConvAlg,
+import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
DataReturnConvention(..)
)
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,
import AbsCSyn
import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
-import CgBindery ( getArgAmodes )
+import CgBindery ( getArgAmodes, CgIdInfo )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgMonad
import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgRetConv ( mkLiveRegsMask )
import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
initHeapUsage
)
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}
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) )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import Bag ( foldBag )
+import CgBindery ( CgIdInfo )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits )
opt_EnsureSplittableC, opt_SccGroup
)
import CStrings ( modnameToC )
+import FiniteMap ( FiniteMap )
import Maybes ( maybeToBool )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Util ( panic, assertPanic )
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
)
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)
IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
-import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import CoreSyn
import DsMonad
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 )
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
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
- MatchResult, DsCoreArg(..)
+ MatchResult, SYN_IE(DsCoreArg)
)
import Match ( matchWrapper )
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
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}
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 )
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
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 )
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] ->
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}
#include "HsVersions.h"
module DsMonad (
- DsM(..),
+ SYN_IE(DsM),
initDs, returnDs, thenDs, andDs, mapDs, listDs,
mapAndUnzipDs, zipWithDs,
uniqSMtoDsM,
getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs,
extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
- DsIdEnv(..),
+ SYN_IE(DsIdEnv),
lookupId,
dsShadowError,
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,
combineGRHSMatchResults,
combineMatchResults,
- dsExprToAtom, DsCoreArg(..),
+ dsExprToAtom, SYN_IE(DsCoreArg),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
-import TcHsSyn ( TypecheckedPat(..) )
+import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
import CoreSyn
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 )
-- 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),
-- 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
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) )
module Main ( main ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
import HsSyn
) 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,
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)
= 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" >>
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
+ -- wired-in chappy
+ | is_val_ish && isRnConstr rn
+ = acc -- these things don't cause export-ery
+ | exportFlagOn ef = addToFM acc on ef
| otherwise = acc
where
+ n = getName rn
ef = export_fn n
+ on = origName "from_wired" n
+ (OrigName _ str) = on
+ on_in_acc = maybeToBool (lookupFM acc on)
--------------
- maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag)
+ maybe_add :: FiniteMap OrigName ExportFlag -> RnName -> FiniteMap OrigName ExportFlag
maybe_add acc rn
- | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
+ | on_in_acc = trace "maybe_add?" acc -- surprising!
+ | exportFlagOn ef = addToFM acc on ef
| otherwise = acc
where
- n = getName rn
ef = nameExportFlag n
+ n = getName rn
+ on = origName "maybe_add" n
+ on_in_acc = maybeToBool (lookupFM acc on)
--------------
maybe_add_list acc [] = acc
module AbsCStixGen ( genCodeAbstractC ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import AbsCSyn
import Stix
module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(Handle))
import MachMisc
import MachRegs
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) )
-import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) )
+import Unpretty ( uppPutStr, uppShow, uppAboves, SYN_IE(Unpretty) )
\end{code}
The 96/03 native-code generator has machine-independent and
IMP_Ubiq(){-uitous-}
-import MachCode ( InstrList(..) )
+import MachCode ( SYN_IE(InstrList) )
import MachMisc ( Instr )
import MachRegs
import RegAllocInfo
#include "HsVersions.h"
#include "nativeGen/NCG.h"
-module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
+module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
IMP_Ubiq(){-uitious-}
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> trivialCode (CMP LT) y x
+ CharGtOp -> trivialCode (CMP LTT) y x
CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQ) x y
+ CharEqOp -> trivialCode (CMP EQQ) x y
CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LT) x y
+ CharLtOp -> trivialCode (CMP LTT) x y
CharLeOp -> trivialCode (CMP LE) x y
- IntGtOp -> trivialCode (CMP LT) y x
+ IntGtOp -> trivialCode (CMP LTT) y x
IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQ) x y
+ IntEqOp -> trivialCode (CMP EQQ) x y
IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LT) x y
+ IntLtOp -> trivialCode (CMP LTT) x y
IntLeOp -> trivialCode (CMP LE) x y
WordGtOp -> trivialCode (CMP ULT) y x
WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQ) x y
+ WordEqOp -> trivialCode (CMP EQQ) x y
WordNeOp -> int_NE_code x y
WordLtOp -> trivialCode (CMP ULT) x y
WordLeOp -> trivialCode (CMP ULE) x y
AddrGtOp -> trivialCode (CMP ULT) y x
AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQ) x y
+ AddrEqOp -> trivialCode (CMP EQQ) x y
AddrNeOp -> int_NE_code x y
AddrLtOp -> trivialCode (CMP ULT) x y
AddrLeOp -> trivialCode (CMP ULE) x y
- FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y
- FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- FloatLtOp -> cmpF_code (FCMP TF LT) NE x y
+ FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y
+ DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
IntAddOp -> trivialCode (ADD Q False) x y
int_NE_code :: StixTree -> StixTree -> UniqSM Register
int_NE_code x y
- = trivialCode (CMP EQ) x y `thenUs` \ register ->
+ = trivialCode (CMP EQQ) x y `thenUs` \ register ->
getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
result = registerName register tmp
code__2 dst = code . mkSeqInstrs [
- OR zero (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zero (RIReg zero) dst,
+ OR zeroh (RIImm (ImmInt 1)) dst,
+ BF cond result (ImmCLbl lbl),
+ OR zeroh (RIReg zeroh) dst,
LABEL lbl]
in
returnUs (Any IntRep code__2)
getRegister (StInt i)
| fits8Bits i
= let
- code dst = mkSeqInstr (OR zero (RIImm src) dst)
+ code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
in
returnUs (Any IntRep code)
| otherwise
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> condIntReg GT x y
+ CharGtOp -> condIntReg GTT x y
CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
+ CharEqOp -> condIntReg EQQ x y
CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
+ CharLtOp -> condIntReg LTT x y
CharLeOp -> condIntReg LE x y
- IntGtOp -> condIntReg GT x y
+ IntGtOp -> condIntReg GTT x y
IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
+ IntEqOp -> condIntReg EQQ x y
IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
+ IntLtOp -> condIntReg LTT x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
+ WordEqOp -> condIntReg EQQ x y
WordNeOp -> condIntReg NE x y
WordLtOp -> condIntReg LU x y
WordLeOp -> condIntReg LEU x y
AddrGtOp -> condIntReg GU x y
AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
+ AddrEqOp -> condIntReg EQQ x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
- FloatGtOp -> condFltReg GT x y
+ FloatGtOp -> condFltReg GTT x y
FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
+ FloatEqOp -> condFltReg EQQ x y
FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
+ FloatLtOp -> condFltReg LTT x y
FloatLeOp -> condFltReg LE x y
- DoubleGtOp -> condFltReg GT x y
+ DoubleGtOp -> condFltReg GTT x y
DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
+ DoubleEqOp -> condFltReg EQQ x y
DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
+ DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> condIntReg GT x y
+ CharGtOp -> condIntReg GTT x y
CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
+ CharEqOp -> condIntReg EQQ x y
CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
+ CharLtOp -> condIntReg LTT x y
CharLeOp -> condIntReg LE x y
- IntGtOp -> condIntReg GT x y
+ IntGtOp -> condIntReg GTT x y
IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
+ IntEqOp -> condIntReg EQQ x y
IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
+ IntLtOp -> condIntReg LTT x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
+ WordEqOp -> condIntReg EQQ x y
WordNeOp -> condIntReg NE x y
WordLtOp -> condIntReg LU x y
WordLeOp -> condIntReg LEU x y
AddrGtOp -> condIntReg GU x y
AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
+ AddrEqOp -> condIntReg EQQ x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
- FloatGtOp -> condFltReg GT x y
+ FloatGtOp -> condFltReg GTT x y
FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
+ FloatEqOp -> condFltReg EQQ x y
FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
+ FloatLtOp -> condFltReg LTT x y
FloatLeOp -> condFltReg LE x y
- DoubleGtOp -> condFltReg GT x y
+ DoubleGtOp -> condFltReg GTT x y
DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
+ DoubleEqOp -> condFltReg EQQ x y
DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
+ DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
IntAddOp -> trivialCode (ADD False False) x y
getCondCode (StPrim primop [x, y])
= case primop of
- CharGtOp -> condIntCode GT x y
+ CharGtOp -> condIntCode GTT x y
CharGeOp -> condIntCode GE x y
- CharEqOp -> condIntCode EQ x y
+ CharEqOp -> condIntCode EQQ x y
CharNeOp -> condIntCode NE x y
- CharLtOp -> condIntCode LT x y
+ CharLtOp -> condIntCode LTT x y
CharLeOp -> condIntCode LE x y
- IntGtOp -> condIntCode GT x y
+ IntGtOp -> condIntCode GTT x y
IntGeOp -> condIntCode GE x y
- IntEqOp -> condIntCode EQ x y
+ IntEqOp -> condIntCode EQQ x y
IntNeOp -> condIntCode NE x y
- IntLtOp -> condIntCode LT x y
+ IntLtOp -> condIntCode LTT x y
IntLeOp -> condIntCode LE x y
WordGtOp -> condIntCode GU x y
WordGeOp -> condIntCode GEU x y
- WordEqOp -> condIntCode EQ x y
+ WordEqOp -> condIntCode EQQ x y
WordNeOp -> condIntCode NE x y
WordLtOp -> condIntCode LU x y
WordLeOp -> condIntCode LEU x y
AddrGtOp -> condIntCode GU x y
AddrGeOp -> condIntCode GEU x y
- AddrEqOp -> condIntCode EQ x y
+ AddrEqOp -> condIntCode EQQ x y
AddrNeOp -> condIntCode NE x y
AddrLtOp -> condIntCode LU x y
AddrLeOp -> condIntCode LEU x y
- FloatGtOp -> condFltCode GT x y
+ FloatGtOp -> condFltCode GTT x y
FloatGeOp -> condFltCode GE x y
- FloatEqOp -> condFltCode EQ x y
+ FloatEqOp -> condFltCode EQQ x y
FloatNeOp -> condFltCode NE x y
- FloatLtOp -> condFltCode LT x y
+ FloatLtOp -> condFltCode LTT x y
FloatLeOp -> condFltCode LE x y
- DoubleGtOp -> condFltCode GT x y
+ DoubleGtOp -> condFltCode GTT x y
DoubleGeOp -> condFltCode GE x y
- DoubleEqOp -> condFltCode EQ x y
+ DoubleEqOp -> condFltCode EQQ x y
DoubleNeOp -> condFltCode NE x y
- DoubleLtOp -> condFltCode LT x y
+ DoubleLtOp -> condFltCode LTT x y
DoubleLeOp -> condFltCode LE x y
#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
fix_FP_cond :: Cond -> Cond
fix_FP_cond GE = GEU
-fix_FP_cond GT = GU
-fix_FP_cond LT = LU
+fix_FP_cond GTT = GU
+fix_FP_cond LTT = LU
fix_FP_cond LE = LEU
fix_FP_cond any = any
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
let
- dst__2 = registerName register1 zero
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
let
- dst__2 = registerName register1 zero
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
+ | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
where
target = ImmCLbl lbl
target = registerName register pv
in
if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
+ returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
else
- returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+ returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnSeq code [BI (cmpOp op) value target]
where
- cmpOp CharGtOp = GT
+ cmpOp CharGtOp = GTT
cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQ
+ cmpOp CharEqOp = EQQ
cmpOp CharNeOp = NE
- cmpOp CharLtOp = LT
+ cmpOp CharLtOp = LTT
cmpOp CharLeOp = LE
- cmpOp IntGtOp = GT
+ cmpOp IntGtOp = GTT
cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQ
+ cmpOp IntEqOp = EQQ
cmpOp IntNeOp = NE
- cmpOp IntLtOp = LT
+ cmpOp IntLtOp = LTT
cmpOp IntLeOp = LE
cmpOp WordGtOp = NE
cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQ
+ cmpOp WordEqOp = EQQ
cmpOp WordNeOp = NE
cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQ
+ cmpOp WordLeOp = EQQ
cmpOp AddrGtOp = NE
cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQ
+ cmpOp AddrEqOp = EQQ
cmpOp AddrNeOp = NE
cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQ
+ cmpOp AddrLeOp = EQQ
genCondJump lbl (StPrim op [x, StDouble 0.0])
= getRegister x `thenUs` \ register ->
in
returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
where
- cmpOp FloatGtOp = GT
+ cmpOp FloatGtOp = GTT
cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQ
+ cmpOp FloatEqOp = EQQ
cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LT
+ cmpOp FloatLtOp = LTT
cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GT
+ cmpOp DoubleGtOp = GTT
cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQ
+ cmpOp DoubleEqOp = EQQ
cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LT
+ cmpOp DoubleLtOp = LTT
cmpOp DoubleLeOp = LE
genCondJump lbl (StPrim op [x, y])
DoubleLeOp -> True
_ -> False
(instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQ)
- FloatGeOp -> (FCMP TF LT, EQ)
- FloatEqOp -> (FCMP TF EQ, NE)
- FloatNeOp -> (FCMP TF EQ, EQ)
- FloatLtOp -> (FCMP TF LT, NE)
+ FloatGtOp -> (FCMP TF LE, EQQ)
+ FloatGeOp -> (FCMP TF LTT, EQQ)
+ FloatEqOp -> (FCMP TF EQQ, NE)
+ FloatNeOp -> (FCMP TF EQQ, EQQ)
+ FloatLtOp -> (FCMP TF LTT, NE)
FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQ)
- DoubleGeOp -> (FCMP TF LT, EQ)
- DoubleEqOp -> (FCMP TF EQ, NE)
- DoubleNeOp -> (FCMP TF EQ, EQ)
- DoubleLtOp -> (FCMP TF LT, NE)
+ DoubleGtOp -> (FCMP TF LE, EQQ)
+ DoubleGeOp -> (FCMP TF LTT, EQQ)
+ DoubleEqOp -> (FCMP TF EQQ, NE)
+ DoubleNeOp -> (FCMP TF EQQ, EQQ)
+ DoubleLtOp -> (FCMP TF LTT, NE)
DoubleLeOp -> (FCMP TF LE, NE)
genCondJump lbl (StPrim op [x, y])
returnUs (code . mkSeqInstr (BI cond result target))
where
(instr, cond) = case op of
- CharGtOp -> (CMP LE, EQ)
- CharGeOp -> (CMP LT, EQ)
- CharEqOp -> (CMP EQ, NE)
- CharNeOp -> (CMP EQ, EQ)
- CharLtOp -> (CMP LT, NE)
+ CharGtOp -> (CMP LE, EQQ)
+ CharGeOp -> (CMP LTT, EQQ)
+ CharEqOp -> (CMP EQQ, NE)
+ CharNeOp -> (CMP EQQ, EQQ)
+ CharLtOp -> (CMP LTT, NE)
CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQ)
- IntGeOp -> (CMP LT, EQ)
- IntEqOp -> (CMP EQ, NE)
- IntNeOp -> (CMP EQ, EQ)
- IntLtOp -> (CMP LT, NE)
+ IntGtOp -> (CMP LE, EQQ)
+ IntGeOp -> (CMP LTT, EQQ)
+ IntEqOp -> (CMP EQQ, NE)
+ IntNeOp -> (CMP EQQ, EQQ)
+ IntLtOp -> (CMP LTT, NE)
IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQ)
- WordGeOp -> (CMP ULT, EQ)
- WordEqOp -> (CMP EQ, NE)
- WordNeOp -> (CMP EQ, EQ)
+ WordGtOp -> (CMP ULE, EQQ)
+ WordGeOp -> (CMP ULT, EQQ)
+ WordEqOp -> (CMP EQQ, NE)
+ WordNeOp -> (CMP EQQ, EQQ)
WordLtOp -> (CMP ULT, NE)
WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQ)
- AddrGeOp -> (CMP ULT, EQ)
- AddrEqOp -> (CMP EQ, NE)
- AddrNeOp -> (CMP EQ, EQ)
+ AddrGtOp -> (CMP ULE, EQQ)
+ AddrGeOp -> (CMP ULT, EQQ)
+ AddrEqOp -> (CMP EQQ, NE)
+ AddrNeOp -> (CMP EQQ, EQQ)
AddrLtOp -> (CMP ULT, NE)
AddrLeOp -> (CMP ULE, NE)
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-condIntReg EQ x (StInt 0)
+condIntReg EQQ x (StInt 0)
= getRegister x `thenUs` \ register ->
getNewRegNCG IntRep `thenUs` \ tmp ->
let
in
returnUs (Any IntRep code__2)
-condIntReg EQ x y
+condIntReg EQQ x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
getNewRegNCG IntRep `thenUs` \ tmp1 ->
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia
+IMPORT_1_3(Char(isDigit))
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
data Cond
#if alpha_TARGET_ARCH
= ALWAYS -- For BI (same as BR)
- | EQ -- For CMP and BI
+ | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
| GE -- For BI only
- | GT -- For BI only
+ | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
| LE -- For CMP and BI
- | LT -- For CMP and BI
+ | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
| NE -- For BI only
| NEVER -- For BI (null instruction)
| ULE -- For CMP only
#endif
#if i386_TARGET_ARCH
= ALWAYS -- What's really used? ToDo
- | EQ
+ | EQQ
| GE
| GEU
- | GT
+ | GTT
| GU
| LE
| LEU
- | LT
+ | LTT
| LU
| NE
| NEG
#endif
#if sparc_TARGET_ARCH
= ALWAYS -- What's really used? ToDo
- | EQ
+ | EQQ
| GE
| GEU
- | GT
+ | GTT
| GU
| LE
| LEU
- | LT
+ | LTT
| LU
| NE
| NEG
Imm(..),
Addr(..),
RegLoc(..),
- RegNo(..),
+ SYN_IE(RegNo),
addrOffset,
argRegs,
, allArgRegs
, fits8Bits
, fReg
- , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zero
+ , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
#endif
#if i386_TARGET_ARCH
, eax, ebx, ecx, edx, esi, esp
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppStr, Unpretty(..) )
+import Unpretty ( uppStr, SYN_IE(Unpretty) )
import Util ( panic )
\end{code}
fReg :: Int -> Int
fReg x = (32 + x)
-v0, f0, ra, pv, gp, sp, zero :: Reg
-v0 = realReg 0
-f0 = realReg (fReg 0)
-ra = FixedReg ILIT(26)
-pv = t12
-gp = FixedReg ILIT(29)
-sp = FixedReg ILIT(30)
-zero = FixedReg ILIT(31)
+v0, f0, ra, pv, gp, sp, zeroh :: Reg
+v0 = realReg 0
+f0 = realReg (fReg 0)
+ra = FixedReg ILIT(26)
+pv = t12
+gp = FixedReg ILIT(29)
+sp = FixedReg ILIT(30)
+zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method)
t9, t10, t11, t12 :: Reg
t9 = realReg 23
freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at)
freeReg ILIT(29) = _FALSE_ -- global pointer (gp)
freeReg ILIT(30) = _FALSE_ -- stack pointer (sp)
-freeReg ILIT(31) = _FALSE_ -- always zero (zero)
+freeReg ILIT(31) = _FALSE_ -- always zero (zeroh)
freeReg ILIT(63) = _FALSE_ -- always zero (f31)
#endif
__exports__
MachMisc underscorePrefix (..)
MachMisc fmtAsmLbl (..)
+StixPrim amodeToStix (..)
\end{code}
module PprMach ( pprInstr ) where
IMP_Ubiq(){-uitious-}
+IMPORT_1_3(Char(isPrint,isDigit))
+IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
+#if __GLASGOW_HASKELL__ >= 200
+# define A_HASH GHCbase.A#
+#else
+# define A_HASH A#
+#endif
import MachRegs -- may differ per-platform
import MachMisc
pprCond c = uppPStr (case c of {
#if alpha_TARGET_ARCH
- EQ -> SLIT("eq");
- LT -> SLIT("lt");
+ EQQ -> SLIT("eq");
+ LTT -> SLIT("lt");
LE -> SLIT("le");
ULT -> SLIT("ult");
ULE -> SLIT("ule");
NE -> SLIT("ne");
- GT -> SLIT("gt");
+ GTT -> SLIT("gt");
GE -> SLIT("ge")
#endif
#if i386_TARGET_ARCH
GEU -> SLIT("ae"); LU -> SLIT("b");
- EQ -> SLIT("e"); GT -> SLIT("g");
+ EQQ -> SLIT("e"); GTT -> SLIT("g");
GE -> SLIT("ge"); GU -> SLIT("a");
- LT -> SLIT("l"); LE -> SLIT("le");
+ LTT -> SLIT("l"); LE -> SLIT("le");
LEU -> SLIT("be"); NE -> SLIT("ne");
NEG -> SLIT("s"); POS -> SLIT("ns");
ALWAYS -> SLIT("mp") -- hack
#if sparc_TARGET_ARCH
ALWAYS -> SLIT(""); NEVER -> SLIT("n");
GEU -> SLIT("geu"); LU -> SLIT("lu");
- EQ -> SLIT("e"); GT -> SLIT("g");
+ EQQ -> SLIT("e"); GTT -> SLIT("g");
GE -> SLIT("ge"); GU -> SLIT("gu");
- LT -> SLIT("l"); LE -> SLIT("le");
+ LTT -> SLIT("l"); LE -> SLIT("le");
LEU -> SLIT("leu"); NE -> SLIT("ne");
NEG -> SLIT("neg"); POS -> SLIT("pos");
VC -> SLIT("vc"); VS -> SLIT("vs")
pprImm (LO i)
= uppBesides [ pp_lo, pprImm i, uppRparen ]
where
- pp_lo = uppPStr (_packCString (A# "%lo("#))
+ pp_lo = uppPStr (_packCString (A_HASH "%lo("#))
pprImm (HI i)
= uppBesides [ pp_hi, pprImm i, uppRparen ]
where
- pp_hi = uppPStr (_packCString (A# "%hi("#))
+ pp_hi = uppPStr (_packCString (A_HASH "%hi("#))
#endif
\end{code}
]
where
pp_lab = pprCLabel_asm clab
- pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+
+#if __GLASGOW_HASKELL__ >= 200
+# define PACK_STR packCString
+#else
+# define PACK_STR _packCString
+#endif
+ pp_ldgp = uppPStr (PACK_STR (A_HASH ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = uppPStr (PACK_STR (A_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
pprInstr (FUNEND clab)
= uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
pprReg reg1
]
-pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#))
-pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
-pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
-pp_comma_a = uppPStr (_packCString (A# ",a"#))
+pp_ld_lbracket = uppPStr (PACK_STR (A_HASH "\tld\t["#))
+pp_rbracket_comma = uppPStr (PACK_STR (A_HASH "],"#))
+pp_comma_lbracket = uppPStr (PACK_STR (A_HASH ",["#))
+pp_comma_a = uppPStr (PACK_STR (A_HASH ",a"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
regUsage,
FutureLive(..),
- RegAssignment(..),
- RegConflicts(..),
+ SYN_IE(RegAssignment),
+ SYN_IE(RegConflicts),
RegFuture(..),
RegHistory(..),
RegInfo(..),
regLiveness,
spillReg,
- RegSet(..),
+ SYN_IE(RegSet),
elementOfRegSet,
emptyRegSet,
isEmptyRegSet,
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
import MachMisc
import MachRegs
-import MachCode ( InstrList(..) )
+import MachCode ( SYN_IE(InstrList) )
import AbsCSyn ( MagicId )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
-import FiniteMap ( addToFM, lookupFM )
+import FiniteMap ( addToFM, lookupFM, FiniteMap )
import OrdList ( mkUnitList, OrdList )
import PrimRep ( PrimRep(..) )
import Stix ( StixTree, CodeSegment )
#include "HsVersions.h"
module Stix (
- CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..),
+ CodeSegment(..), StixReg(..), StixTree(..), SYN_IE(StixTreeList),
sStLitLbl,
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CLabel ( mkAsmTempLabel )
import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) )
-import Unpretty ( uppPStr, Unpretty(..) )
+import Unpretty ( uppPStr, SYN_IE(Unpretty) )
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
import PprStyle ( PprStyle(..) )
import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
import Stix
-import StixMacro ( heapCheck, smStablePtrTable )
+import StixMacro ( heapCheck )
import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
import Unpretty ( uppBeside, uppPStr, uppInt )
import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
import PrimOp ( PrimOp )
import RnHsSyn ( RnName )
-import Type ( mkSigmaTy, mkFunTys, GenType )
+import Type ( mkSigmaTy, mkFunTy, mkFunTys, GenType )
import TyVar ( GenTyVar )
import Unique ( Unique )
import Usage ( GenUsage )
mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
mkFunTys :: [GenType a b] -> GenType a b -> GenType a b
+mkFunTy :: GenType a b -> GenType a b -> GenType a b
primOpNameInfo :: PrimOp -> (_PackedString, RnName)
\end{code}
Name mkWiredInName (..)
Type mkSigmaTy (..)
Type mkFunTys (..)
+Type mkFunTy (..)
IdUtils primOpNameInfo (..)
\end{code}
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
- mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+ mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep
)
import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
statePrimTyCon VoidRep [realWorldTy]
where
primio_ish_ty result
- = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [result, mkStateTy realWorldTy])
+ = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
\end{code}
%************************************************************************
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
Compare str ty -> compare_fun_ty ty
- Coercing str ty1 ty2 -> mkFunTys [ty1] ty2
+ Coercing str ty1 ty2 -> mkFunTy ty1 ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
Utils:
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTys [ty] ty
+monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
mkTupleTy,
nilDataCon,
primIoTyCon,
- primIoDataCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
stTyCon,
+ stDataCon,
stablePtrTyCon,
stateAndAddrPrimTyCon,
stateAndArrayPrimTyCon,
NewOrData(..), TyCon
)
import Type ( mkTyConTy, applyTyCon, mkSigmaTy,
- mkFunTys, maybeAppTyCon,
+ mkFunTy, maybeAppTyCon,
GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
import TyVar ( tyVarKind, alphaTyVar, betaTyVar )
import Unique
where
tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
+pcSynTyCon key mod str kind arity tyvars expansion
+ = mkSynTyCon
+ (mkWiredInName key (OrigName mod str) ExportAll)
+ kind arity tyvars expansion
+
pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
-> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
pcDataCon key mod str tyvars context arg_tys tycon specenv
mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon]
- where
- ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
- stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
+stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
+ where
+ ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
\end{code}
%************************************************************************
%* *
-\subsection[TysWiredIn-IO]{The @PrimIO@ and @IO@ monadic-I/O types}
+\subsection[TysWiredIn-IO]{The @PrimIO@ monadic-I/O type}
%* *
%************************************************************************
\begin{code}
-mkPrimIoTy a = applyTyCon primIoTyCon [a]
+mkPrimIoTy a = mkStateTransformerTy realWorldTy a
-primIoTyCon = pcNewTyCon primIoTyConKey gHC__ SLIT("PrimIO") alpha_tyvar [primIoDataCon]
-
-primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO")
- alpha_tyvar [] [ty] primIoTyCon nullSpecEnv
- where
- ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy])
+primIoTyCon
+ = pcSynTyCon
+ primIoTyConKey gHC__ SLIT("PrimIO")
+ (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
+ 1 alpha_tyvar (mkPrimIoTy alphaTy)
\end{code}
%************************************************************************
IMP_Ubiq()
IMPORT_1_3(IO(hPutStr, stderr))
+IMPORT_1_3(GHCio(stThen))
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
\begin{code}
#if __GLASGOW_HASKELL__ >= 200
# define PACK_STR packCString
-# define CCALL_THEN `GHCbase.ccallThen`
+# define CCALL_THEN `stThen`
#else
# define PACK_STR _packCString
# define CCALL_THEN `thenPrimIO`
(\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
msg = ppShow 100 (err PprForUser)
in
+#if __GLASGOW_HASKELL__ >= 200
+ ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
+ ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
+#else
ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
+#endif
returnUgn (error "ReadPrefix")
) `thenUgn` \ (n, arg_pats) ->
ctype :: { RdrNamePolyType }
ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 }
- | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
- | context DARROW type {{-ToDo:rm-} HsPreForAllTy $1 $3 }
- | type {{-ToDo:change-} HsPreForAllTy [] $1 }
+ | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
+ | type { HsForAllTy [] [] $1 }
type :: { RdrNameMonoType }
type : btype { $1 }
| instdecls instd { $1 `snocBag` $2 }
instd :: { RdrIfaceInst }
-instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (Just (map Unqual $4)) $6 $8 $9 }
- | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (Just (map Unqual $4)) [] $6 $7 }
- | INSTANCE context DARROW gtycon restrict_inst SEMI {{-ToDo:rm-} mk_inst Nothing $2 $4 $5 }
- | INSTANCE gtycon general_inst SEMI {{-ToDo:rm-} mk_inst Nothing [] $2 $3 }
+instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (map Unqual $4) $6 $8 $9 }
+ | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (map Unqual $4) [] $6 $7 }
+ | INSTANCE gtycon general_inst SEMI { mk_inst [] [] $2 $3 }
restrict_inst :: { RdrNameMonoType }
restrict_inst : gtycon { MonoTyApp $1 [] }
where
opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
-mk_inst :: Maybe [RdrName] -- ToDo: de-maybe
+mk_inst :: [RdrName]
-> RdrNameContext
-> RdrName -- class
-> RdrNameMonoType -- fish the tycon out yourself...
mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty
= let
- ty = case tvs of
- Nothing -> HsPreForAllTy ctxt mono_ty -- ToDo: get rid of this
- Just ts -> HsForAllTy ts ctxt mono_ty
+ ty = HsForAllTy tvs ctxt mono_ty
in
-- pprTrace "mk_inst:" (ppr PprDebug ty) $
InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
import PreludeGlaST ( thenPrimIO )
IMP_Ubiq()
+IMPORT_1_3(List(partition))
import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
-import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
+import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired )
--ToDo:rm: all for debugging only
-import Maybes
-import Name
-import Outputable
-import RnIfaces
-import PprStyle
-import Pretty
-import FiniteMap
-import Util (pprPanic, pprTrace)
+--import Maybes
+--import Name
+--import Outputable
+--import RnIfaces
+--import PprStyle
+--import Pretty
+--import FiniteMap
+--import Util (pprPanic, pprTrace)
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
UsagesMap(..), VersionsMap(..)
)
import RnMonad
-import RnNames ( getGlobalNames, GlobalNameInfo(..) )
+import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) )
import RnSource ( rnSource )
import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache )
import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
+import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, lookupFM{-ToDo:rm-}, FiniteMap )
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..), ExportFlag(..) )
+import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
+ origName,
+ Name, RdrName(..), ExportFlag(..)
+ )
+import PprStyle -- ToDo:rm
import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import Pretty -- ToDo:rm
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic )
+import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
\begin{code}
IMP_Ubiq()
-import PreludeGlaST ( thenPrimIO, seqPrimIO, newVar, readVar, writeVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
+#if __GLASGOW_HASKELL__ >= 200
+# define ST_THEN `stThen`
+# define TRY_IO tryIO
+IMPORT_1_3(GHCio(stThen,tryIO))
+#else
+# define ST_THEN `thenPrimIO`
+# define TRY_IO try
+#endif
import HsSyn
import HsPragmas ( noGenPragmas )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, addListToFM, keysFM{-ToDo:rm-}
+ plusFM_C, addListToFM, keysFM{-ToDo:rm-}, FiniteMap
)
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
isLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) )
import Pretty
-import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
import Util ( sortLt, removeDups, cmpPString, startsWith,
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
data IfaceCache
= IfaceCache
Module -- the name of the module being compiled
BuiltinNames -- so we can avoid going after things
-- the compiler already knows about
- (MutableVar _RealWorld
+ (MutableVar REAL_WORLD
(ModuleToIfaceContents, -- interfaces for individual interface files
ModuleToIfaceContents, -- merged interfaces based on module name
-- used for extracting info about original names
ModuleToIfaceFilePath))
initIfaceCache mod hi_files
- = newVar (emptyFM,emptyFM,hi_files) `thenPrimIO` \ iface_var ->
+ = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
return (IfaceCache mod b_names iface_var)
where
b_names = case builtinNameInfo of (b_names,_,_) -> b_names
-> IO (MaybeErr ParsedIface Error)
cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
- = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
+ = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
case (lookupFM iface_fm modname) of
Just iface -> return (want_iface iface orig_fm)
iface_fm' = addToFM iface_fm modname iface
orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
in
- writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO`
+ writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
return (want_iface iface orig_fm')
where
want_iface iface orig_fm
readIface file modname item
= --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >>
- readFile file `thenPrimIO` \ read_result ->
+ TRY_IO (readFile file) >>= \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
Right contents -> --hPutStr stderr ".." >>
| AddedSig RenamedSig
rnIfaceDecl :: RdrIfaceDecl
- -> RnM_Fixes _RealWorld
+ -> RnM_Fixes REAL_WORLD
(AddedDecl, -- the resulting decl to add to the pot
([(RdrName,RnName)], [(RdrName,RnName)]),
-- new val/tycon-class names that have
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
- = readVar iface_var `thenPrimIO` \ (iface_fm, _, _) ->
+ = readVar iface_var ST_THEN \ (iface_fm, _, _) ->
let
imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
-- Assert that instance modules given by direct imports contains
-- instance modules extracted from all visited modules
- readVar iface_var `thenPrimIO` \ (all_iface_fm, _, _) ->
+ readVar iface_var ST_THEN \ (all_iface_fm, _, _) ->
let
all_ifaces = eltsFM all_iface_fm
(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
= -- all the instance decls we might even want to consider
-- are in the ParsedIfaces that are in our cache
- readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
all_insts = concat (map get_insts all_ifaces)
\end{code}
\begin{code}
-rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes _RealWorld RenamedInstDecl
+rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
\end{code}
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
- readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
-- all the interfaces we have looked at
\begin{code}
interface RnLoop_1_3 1
__exports__
-Outputable Outputable (..)
+RnBinds rnBinds (..)
+RnBinds FreeVars
+RnSource rnPolyType (..)
\end{code}
module RnNames (
getGlobalNames,
- GlobalNameInfo(..)
+ SYN_IE(GlobalNameInfo)
) where
-import PreludeGlaST ( MutableVar(..) )
+import PreludeGlaST ( SYN_IE(MutableVar) )
IMP_Ubiq()
unionManyBags, mapBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
+import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
= let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec -- NB: a no-op ToDo:rm
in
(if mod == gHC_BUILTINS then
return (Succeeded (panic "doImport:GHC fake import!"),
)
getBuiltins _ modname maybe_spec
- | modname `notElem` modulesWithBuiltins
+--OLD: | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
+{-
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
_ -> panic "importing builtin names (2)"
where
(vals, tcs, ies_left) = do_builtin ies
+-}
-------------------------
getOrigIEs :: ParsedIface
IMP_Ubiq()
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMPORT_1_3(List(partition))
import HsSyn
import HsPragmas
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
+import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty
+ prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
module SimplCore ( core2core ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hPutStr,stderr))
import AnalFBWW ( analFBWW )
import Bag ( isEmptyBag, foldBag )
import CoreUnfold
import CoreUtils ( substCoreBindings, manifestlyWHNF )
import ErrUtils ( ghcExit )
+import FiniteMap ( FiniteMap )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(SmplLoop) -- paranoia checking
+IMPORT_1_3(List(partition))
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
+import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
-import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
- TcTyVarSet(..), TcTyVar(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
+ SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars
)
import Unify ( unifyTauTy )
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake
)
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcExpr), tcIdType )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Class ( GenClass )
Inst(..), -- Visible only to TcSimplify
InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
+ SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
- InstanceMapper(..),
+ SYN_IE(InstanceMapper),
newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
) where
IMP_Ubiq()
+IMPORT_1_3(Ratio(Rational))
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
InPat, OutPat, Stmt, Qualifier, Match,
ArithSeqInfo, PolyType, Fake )
-import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
-import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
+import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr),
+ RnName{-instance NamedThing-}
+ )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
mkHsTyApp, mkHsDictApp, tcIdTyVars )
import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
-import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
tcInstType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
import Class ( isCcallishClass, isNoDictClass, classInstEnv,
- SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv)
+ SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( GenId, idType, mkInstId )
import PprType ( GenClass, TyCon, GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
-import RnHsSyn ( RnName{-instance NamedThing-} )
import SpecEnv ( SYN_IE(SpecEnv) )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
HsExpr, Match, PolyType, InPat, OutPat(..),
GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
collectBinders )
-import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
- RenamedMonoBinds(..), RnName(..)
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..),
+ SYN_IE(RenamedMonoBinds), RnName(..)
)
-import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
- TcIdOcc(..), TcIdBndr(..) )
+import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds),
+ TcIdOcc(..), SYN_IE(TcIdBndr) )
import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
-import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
+import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
import Maybes ( assocMaybe, catMaybes )
-import Name ( pprNonSym )
+import Name ( pprNonSym, Name )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
-import RnHsSyn ( RnName ) -- instances
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
\begin{code}
#include "HsVersions.h"
-module TcClassDcl (
- tcClassDecl1, tcClassDecls2
- ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
IMP_Ubiq()
Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
- RenamedClassOpSig(..), RenamedMonoBinds(..),
+ RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
RenamedGenPragmas(..), RenamedContext(..),
RnName{-instance Uniquable-}
)
-import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
-import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts, newMethod )
+import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
import TcInstDcls ( processInstBinds )
-import TcKind ( TcKind )
-import TcKind ( unifyKind )
+import TcKind ( unifyKind, TcKind )
import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType, tcMonoType, tcContext )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
import Bag ( foldBag, unionManyBags )
import Class ( GenClass, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
- classOpTagByString
+ classOpTagByString, SYN_IE(ClassOp)
)
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
ArithSeqInfo, Fake, MonoType )
import HsPragmas ( InstancePragmas(..) )
-import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) )
+import RnHsSyn ( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
import TcMonad
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
import TcKind ( TcKind )
import TcGenDeriv -- Deriv stuff
IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
import Id ( SYN_IE(Id), GenId, idType, mkUserLocal )
-import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
+import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) )
import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
newTyVarTys, tcInstTyVars, zonkTcTyVars
)
import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
-import Type ( tyVarsOfTypes )
+import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity )
import Class ( SYN_IE(Class), GenClass, classSig )
import PprStyle
import Pretty
import RnHsSyn ( RnName(..) )
-import Type ( splitForAllTy )
import Unique ( pprUnique10, pprUnique{-ToDo:rm-} )
import UniqFM
import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
failureFreePat, collectPatBinders )
-import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
- RenamedStmt(..), RenamedRecordBinds(..),
+import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
+ SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
RnName{-instance Outputable-}
)
-import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
- TcIdOcc(..), TcRecordBinds(..),
+import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
+ TcIdOcc(..), SYN_IE(TcRecordBinds),
mkHsTyApp
)
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
+ SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
-import TcType ( TcType(..), TcMaybe(..),
+import TcType ( SYN_IE(TcType), TcMaybe(..),
tcInstId, tcInstType, tcInstSigTcType,
tcInstSigType, tcInstTcType, tcInstTheta,
newTyVarTy, zonkTcTyVars, zonkTcType )
)
import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy
+ floatPrimTy, addrPrimTy, realWorldTy
)
import TysWiredIn ( addrTy,
boolTy, charTy, stringTy, mkListTy,
- mkTupleTy, mkPrimIoTy, primIoDataCon
+ mkTupleTy, mkPrimIoTy, stDataCon
)
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsCon primIoDataCon [result_ty] [CCall lbl args' may_gc is_asm result_ty],
+ returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty],
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
mkPrimIoTy result_ty)
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
-import RnHsSyn ( RenamedGRHSsAndBinds(..), RenamedGRHS(..) )
-import TcHsSyn ( TcGRHSsAndBinds(..), TcGRHS(..), TcIdOcc(..) )
+import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
+import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, LIE(..), plusLIE )
+import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr )
-import TcType ( TcType(..) )
+import TcType ( SYN_IE(TcType) )
import Unify ( unifyTauTy )
import TysWiredIn ( boolTy )
#include "HsVersions.h"
module TcHsSyn (
- TcIdBndr(..), TcIdOcc(..),
+ SYN_IE(TcIdBndr), TcIdOcc(..),
- TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
- TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
- TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
- TcHsModule(..),
+ SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
+ SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
+ SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
+ SYN_IE(TcHsModule),
- TypecheckedHsBinds(..), TypecheckedBind(..),
- TypecheckedMonoBinds(..), TypecheckedPat(..),
- TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
- TypecheckedQual(..), TypecheckedStmt(..),
- TypecheckedMatch(..), TypecheckedHsModule(..),
- TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedRecordBinds(..),
+ SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
+ SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
+ SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
+ SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt),
+ SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
+ SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
+ SYN_IE(TypecheckedRecordBinds),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
-- friends:
import HsSyn -- oodles of it
-import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
+import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
SYN_IE(DictVar), idType,
SYN_IE(IdEnv), growIdEnvList, lookupIdEnv
)
-- others:
import Name ( Name{--O only-} )
import TcMonad hiding ( rnMtoTcM )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..),
+import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
zonkTcTypeToType, zonkTcTyVarToTyVar
)
import Usage ( SYN_IE(UVar) )
InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Stmt, Qualifier, ArithSeqInfo, Fake,
PolyType(..), MonoType )
-import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
RenamedInstDecl(..), RenamedFixityDecl(..),
RenamedSig(..), RenamedSpecInstSig(..),
RnName(..){-incl instance Outputable-}
)
-import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
- TcMonoBinds(..), TcExpr(..), tcIdType,
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds),
+ SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars )
-import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
- newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
+ newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
import TcDeriv ( tcDeriving )
import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcContext, tcMonoTypeKind )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
)
import Unify ( unifyTauTy, unifyTauTyLists )
IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
-import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
+import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList )
import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
- classBigSig, classOps, classOpLocalType )
+ classBigSig, classOps, classOpLocalType,
+ SYN_IE(ClassOp)
+ )
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
\begin{code}
interface TcLoop_1_3 1
__exports__
-Outputable Outputable (..)
+TcGRHSs tcGRHSsAndBinds (..)
\end{code}
\begin{code}
interface TcMLoop_1_3 1
__exports__
-Outputable Outputable (..)
+TcEnv TcEnv
+TcEnv initEnv (..)
+TcType TcMaybe
\end{code}
import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
HsExpr, HsBinds, OutPat, Fake,
collectPatBinders, pprMatch )
-import RnHsSyn ( RenamedMatch(..) )
-import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
+import RnHsSyn ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, LIE(..), plusLIE )
+import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
-import TcType ( TcType(..), TcMaybe, zonkTcType )
+import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
import Kind ( Kind, mkTypeKind )
import Pretty
-import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
import Util
\end{code}
module TcModule (
typecheckModule,
- TcResults(..),
- TcResultBinds(..),
- TcIfaceInfo(..),
- TcSpecialiseRequests(..),
- TcDDumpDeriv(..)
+ SYN_IE(TcResults),
+ SYN_IE(TcResultBinds),
+ SYN_IE(TcIfaceInfo),
+ SYN_IE(TcSpecialiseRequests),
+ SYN_IE(TcDDumpDeriv)
) where
IMP_Ubiq(){-uitous-}
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
FixityDecl, IE, ImportDecl
)
-import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
-import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
TcIdOcc(..), zonkBinds, zonkDictBinds )
import TcMonad hiding ( rnMtoTcM )
import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
import Util
-import FiniteMap ( emptyFM )
+import FiniteMap ( emptyFM, FiniteMap )
tycon_specs = emptyFM
\end{code}
#include "HsVersions.h"
module TcMonad(
- TcM(..), NF_TcM(..), TcDown, TcEnv,
+ SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
SST_R, FSST_R,
initTc,
rnMtoTcM,
- TcError(..), TcWarning(..),
+ SYN_IE(TcError), SYN_IE(TcWarning),
mkTcErr, arityErr,
-- For closure
- MutableVar(..), _MutableArray
+ SYN_IE(MutableVar),
+#if __GLASGOW_HASKELL__ >= 200
+ GHCbase.MutableArray
+#else
+ _MutableArray
+#endif
) where
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
import Type ( SYN_IE(Type), GenType )
import TyVar ( SYN_IE(TyVar), GenTyVar )
import Usage ( SYN_IE(Usage), GenUsage )
-import ErrUtils ( SYN_IE(Error), SYN_IE(Message), ErrCtxt(..),
- SYN_IE(Warning) )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
import SST
import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
foldBag, unitBag, unionBags, snocBag )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
-import ErrUtils ( SYN_IE(Error) )
import Maybes ( MaybeErr(..) )
--import Name ( Name )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
\end{code}
\begin{code}
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
-- With a builtin polymorphic type for runSST the type for
-- initTc should use TcM s r instead of TcM RealWorld r
initTc :: UniqSupply
- -> TcM _RealWorld r
+ -> TcM REAL_WORLD r
-> MaybeErr (r, Bag Warning)
(Bag Error, Bag Warning)
%~~~~~~~~~~~~~~~~~~
\begin{code}
-rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
+rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
rnMtoTcM rn_env rn_action down env
= readMutVarSST u_var `thenSST` \ uniq_supply ->
import HsSyn ( PolyType(..), MonoType(..), Fake )
import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
- RenamedContext(..), RnName(..)
+ RenamedContext(..), RnName(..),
+ isRnLocal, isRnClass, isRnTyCon
)
-
import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
tcTyVarScope, tcTyVarScopeGivenKinds
)
import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
- mkSigmaTy
+ mkSigmaTy, mkDictTy
)
import TyVar ( GenTyVar, SYN_IE(TyVar) )
-import Type ( mkDictTy )
import Class ( cCallishClassKeys )
import TyCon ( TyCon )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
import Pretty
-import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon,
- RnName{-instance NamedThing-}
- )
import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
\end{code}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Match, HsBinds, Qualifier, PolyType,
ArithSeqInfo, Stmt, Fake )
-import RnHsSyn ( RenamedPat(..) )
-import TcHsSyn ( TcPat(..), TcIdOcc(..) )
+import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
- emptyLIE, plusLIE, plusLIEs, LIE(..),
+ emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
newMethod, newOverloadedLit
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
-import TcType ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
+import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
import PprType ( GenType, GenTyVar )
import PprStyle--ToDo:rm
import Pretty
-import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
SYN_IE(Type), GenType
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, Qualifier, PolyType, ArithSeqInfo,
GRHSsAndBinds, Stmt, Fake )
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( lookupInst, lookupSimpleInst,
matchesInst, instToId, instBindingRequired,
instCanBeGeneralised, newDictsAtLoc,
pprInst,
- Inst(..), LIE(..), zonkLIE, emptyLIE,
+ Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE,
plusLIE, unitLIE, consLIE, InstOrigin(..),
OverloadedLit )
import TcEnv ( tcGetGlobalTyVars )
-import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
import Unify ( unifyTauTy )
import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
RnName(..){-instance Uniquable-}
)
-import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
+import TcHsSyn ( SYN_IE(TcHsBinds), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcTyVarScope, tcGetEnv )
+ tcTyVarScope )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl, mkDataBinds )
RnName{-instance Outputable-}
)
import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
- TcHsBinds(..), TcIdOcc(..)
+ SYN_IE(TcHsBinds), TcIdOcc(..)
)
import Inst ( newDicts, InstOrigin(..), Inst )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
import TcMonad hiding ( rnMtoTcM )
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
-import PprType ( GenClass, GenType{-instance Outputable-} )
+import PprType ( GenClass, GenType{-instance Outputable-},
+ GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
+ )
import Class ( GenClass{-instance Eq-}, classInstEnv )
import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
dataConFieldLabels, dataConStrictMarks,
applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
splitFunTy, mkTyVarTy, getTyVar_maybe
)
-import PprType ( GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} )
import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
import Unique ( Unique {- instance Eq -}, evalClassKey )
import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
module TcType (
- TcTyVar(..),
+ SYN_IE(TcTyVar),
newTcTyVar,
newTyVarTy, -- Kind -> NF_TcM s (TcType s)
newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s]
- TcTyVarSet(..),
+ SYN_IE(TcTyVarSet),
-----------------------------------------
- TcType(..), TcMaybe(..),
- TcTauType(..), TcThetaType(..), TcRhoType(..),
+ SYN_IE(TcType), TcMaybe(..),
+ SYN_IE(TcTauType), SYN_IE(TcThetaType), SYN_IE(TcRhoType),
-- Find the type to which a type variable is bound
tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
tcConvert bind_fn occ_fn env ty_to_convert
- = do env ty_to_convert
+ = doo env ty_to_convert
where
- do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
+ doo env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
- do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' ->
- do env ty `thenNF_Tc` \ ty' ->
+ doo env (SynTy tycon tys ty) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' ->
+ doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (SynTy tycon tys' ty')
- do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
- do env res `thenNF_Tc` \ res' ->
+ doo env (FunTy arg res usage) = doo env arg `thenNF_Tc` \ arg' ->
+ doo env res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res' usage)
- do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
- do env arg `thenNF_Tc` \ arg' ->
+ doo env (AppTy fun arg) = doo env fun `thenNF_Tc` \ fun' ->
+ doo env arg `thenNF_Tc` \ arg' ->
returnNF_Tc (AppTy fun' arg')
- do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
+ doo env (DictTy clas ty usage)= doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy clas ty' usage)
- do env (ForAllUsageTy u us ty) = do env ty `thenNF_Tc` \ ty' ->
+ doo env (ForAllUsageTy u us ty) = doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllUsageTy u us ty')
-- The two interesting cases!
- do env (TyVarTy tv) = occ_fn env tv
+ doo env (TyVarTy tv) = occ_fn env tv
- do env (ForAllTy tyvar ty)
+ doo env (ForAllTy tyvar ty)
= bind_fn tyvar `thenNF_Tc` \ tyvar' ->
let
new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar')
in
- do new_env ty `thenNF_Tc` \ ty' ->
+ doo new_env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllTy tyvar' ty')
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
-import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
+import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar),
newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
-- TyVars and "sets" containing TyVars:
SYN_IE(TyVarEnv),
nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
- growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
+ growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
SYN_IE(GenTyVarSet), SYN_IE(TyVarSet),
emptyTyVarSet, unitTyVarSet, unionTyVarSets,
-- others
import UniqSet -- nearly all of it
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
- plusUFM, sizeUFM, UniqFM
+ plusUFM, sizeUFM, delFromUFM, UniqFM
)
import Name ( mkLocalName, changeUnique, Name, RdrName(..) )
import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
isNullTyVarEnv :: TyVarEnv a -> Bool
lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a
+delFromTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a
nullTyVarEnv = emptyUFM
mkTyVarEnv = listToUFM
addOneToTyVarEnv = addToUFM
lookupTyVarEnv = lookupUFM
+delFromTyVarEnv = delFromUFM
growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
isNullTyVarEnv env = sizeUFM env == 0
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
- unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+ unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
+
+-- applyTypeEnv applies a type environment to a type.
+-- It can handle shadowing; for example:
+-- f = /\ t1 t2 -> \ d ->
+-- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
+-- in f' t1
+-- Here, when we clone t1 to t1', say, we'll come across shadowing
+-- when applying the clone environment to the type of f'.
+--
+-- As a sanity check, we should also check that name capture
+-- doesn't occur, but that means keeping track of the free variables of the
+-- range of the TyVarEnv, which I don't do just yet.
+--
+-- We don't use instant_help because we need to carry in the environment
+
applyTypeEnvToTy tenv ty
- = instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
+ = go tenv ty
where
- lookup_tv = lookupTyVarEnv tenv
- deflt_tv tv = TyVarTy tv
- choose_tycon ty _ _ = ty
- if_usage ty = ty
- if_forall ty = ty
- bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
- deflt_forall_tv tv = case (lookup_tv tv) of
- Nothing -> tv
- Just (TyVarTy tv2) -> tv2
- _ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty))
+ go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
+ Nothing -> ty
+ Just ty -> ty
+ go tenv ty@(TyConTy tycon usage) = ty
+ go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
+ go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
+ go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
+ go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
+ go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
+ go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
+ where
+ tenv' = case lookupTyVarEnv tenv tv of
+ Nothing -> tenv
+ Just _ -> delFromTyVarEnv tenv tv
\end{code}
\begin{code}
interface Ubiq_1_3 1
__exports__
GHCbase trace (..)
-GHCbase PrimIO -- this is here because of the bug preventing it getting into PreludeGlaST
+GHCps tailPS (..)
GHCps nilPS (..)
--- GHCps substrPS (..)
--- GHCps tailPS (..)
GHCps appendPS (..)
GHCps concatPS (..)
GHCps consPS (..)
CLabel CLabel
Class Class
ClosureInfo ClosureInfo
+CmdLineOpts SwitchResult
CoreSyn GenCoreExpr
CoreUnfold UnfoldingDetails
CoreUnfold UnfoldingGuidance
Name RdrName (..)
Outputable Outputable (..)
PprStyle PprStyle
+PragmaInfo PragmaInfo
PrimOp PrimOp
PrimRep PrimRep
SrcLoc SrcLoc
projects / ghc-hetmet.git / commitdiff