Skip to content

GitLab

Commit 9d4c0380 authored by partain's avatar partain
Browse files

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

partain 1.3 changes through 960629
parent da3d8948
Hide whitespace changes
Inline Side-by-side
Showing with 242 additions and 207 deletions
ghc/compiler/deSugar/DsBinds.lhs
View file @ 9d4c0380
......@@ -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 )
......
ghc/compiler/deSugar/DsExpr.lhs
View file @ 9d4c0380
......@@ -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 )
......
ghc/compiler/deSugar/DsGRHSs.lhs
View file @ 9d4c0380
......@@ -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}
ghc/compiler/deSugar/DsHsSyn.lhs
View file @ 9d4c0380
......@@ -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 )
......
ghc/compiler/deSugar/DsListComp.lhs
View file @ 9d4c0380
......@@ -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] ->
......
ghc/compiler/deSugar/DsLoop_1_3.lhi
View file @ 9d4c0380
\begin{code}
interface DsLoop_1_3 1
__exports__
Outputable Outputable (..)
Match match (..)
Match matchSimply (..)
DsBinds dsBinds (..)
DsExpr dsExpr (..)
\end{code}
ghc/compiler/deSugar/DsMonad.lhs
View file @ 9d4c0380
......@@ -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,
......
ghc/compiler/deSugar/DsUtils.lhs
View file @ 9d4c0380
......@@ -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),
......
ghc/compiler/deSugar/Match.lhs
View file @ 9d4c0380
......@@ -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
......
ghc/compiler/deSugar/MatchLit.lhs
View file @ 9d4c0380
......@@ -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) )
......
ghc/compiler/main/Main.lhs
View file @ 9d4c0380
......@@ -9,6 +9,7 @@
module Main ( main ) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
import HsSyn
......
ghc/compiler/main/MkIface.lhs
View file @ 9d4c0380
......@@ -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
-- 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
......
ghc/compiler/nativeGen/AbsCStixGen.lhs
View file @ 9d4c0380
......@@ -8,6 +8,7 @@
module AbsCStixGen ( genCodeAbstractC ) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(Ratio(Rational))
import AbsCSyn
import Stix
......
ghc/compiler/nativeGen/AsmCodeGen.lhs
View file @ 9d4c0380
......@@ -8,6 +8,7 @@
module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(Handle))
import MachMisc
import MachRegs
......@@ -23,7 +24,7 @@ import PrimRep ( PrimRep{-instance Eq-} )
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
......
ghc/compiler/nativeGen/AsmRegAlloc.lhs
View file @ 9d4c0380
......@@ -10,7 +10,7 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
IMP_Ubiq(){-uitous-}
import MachCode ( InstrList(..) )
import MachCode ( SYN_IE(InstrList) )
import MachMisc ( Instr )
import MachRegs
import RegAllocInfo
......
ghc/compiler/nativeGen/MachCode.lhs
View file @ 9d4c0380
......@@ -12,7 +12,7 @@ structure should not be too overwhelming.
#include "HsVersions.h"
#include "nativeGen/NCG.h"
module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
IMP_Ubiq(){-uitious-}
......@@ -334,46 +334,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
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
......@@ -416,7 +416,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
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
......@@ -443,9 +443,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
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)
......@@ -466,7 +466,7 @@ getRegister (StInd pk mem)
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
......@@ -584,46 +584,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
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)...
......@@ -931,46 +931,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
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
......@@ -1263,46 +1263,46 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas"
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