Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
9d4c0380
Commit
9d4c0380
authored
Jun 30, 1996
by
partain
Browse files
[project @ 1996-06-30 15:56:44 by partain]
partain 1.3 changes through 960629
parent
da3d8948
Changes
84
Hide whitespace changes
Inline
Side-by-side
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, mkFunTy
s
,
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 empty
Bag
{-init accum-})
(from_binds binds empty
FM
{-init accum-})
sigs)
classdecls)
typedecls)
tcs_wired)
vals_wired
sorted_pairs = sortLt lexical_lt (
bag
ToList name_flag_pairs)
sorted_pairs = sortLt lexical_lt (
fm
ToList 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 LT
T
) y x
CharGeOp -> trivialCode (CMP LE) y x
CharEqOp -> trivialCode (CMP EQ) x y
CharEqOp -> trivialCode (CMP EQ
Q
) x y
CharNeOp -> int_NE_code x y
CharLtOp -> trivialCode (CMP LT) x y
CharLtOp -> trivialCode (CMP LT
T
) x y
CharLeOp -> trivialCode (CMP LE) x y
IntGtOp -> trivialCode (CMP LT) y x
IntGtOp -> trivialCode (CMP LT
T
) y x
IntGeOp -> trivialCode (CMP LE) y x
IntEqOp -> trivialCode (CMP EQ) x y
IntEqOp -> trivialCode (CMP EQ
Q
) x y
IntNeOp -> int_NE_code x y
IntLtOp -> trivialCode (CMP LT) x y
IntLtOp -> trivialCode (CMP LT
T
) 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 EQ
Q
) 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 EQ
Q
) 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) EQ
Q
x y
FloatGeOp -> cmpF_code (FCMP TF LT
T
) EQ
Q
x y
FloatEqOp -> cmpF_code (FCMP TF EQ
Q
) NE x y
FloatNeOp -> cmpF_code (FCMP TF EQ
Q
) EQ
Q
x y
FloatLtOp -> cmpF_code (FCMP TF LT
T
) 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) EQ
Q
x y
DoubleGeOp -> cmpF_code (FCMP TF LT
T
) EQ
Q
x y
DoubleEqOp -> cmpF_code (FCMP TF EQ
Q
) NE x y
DoubleNeOp -> cmpF_code (FCMP TF EQ
Q
) EQ
Q
x y
DoubleLtOp -> cmpF_code (FCMP TF LT
T
) 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 EQ
Q
) 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 zero
h
(RIImm (ImmInt 1)) dst,
BF cond
result (ImmCLbl lbl),
OR zero
h
(RIReg zero
h
) 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 zero
h
(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 GT
T
x y
CharGeOp -> condIntReg GE x y
CharEqOp -> condIntReg EQ x y
CharEqOp -> condIntReg EQ
Q
x y
CharNeOp -> condIntReg NE x y
CharLtOp -> condIntReg LT x y
CharLtOp -> condIntReg LT
T
x y
CharLeOp -> condIntReg LE x y
IntGtOp -> condIntReg GT x y
IntGtOp -> condIntReg GT
T
x y
IntGeOp -> condIntReg GE x y
IntEqOp -> condIntReg EQ x y
IntEqOp -> condIntReg EQ
Q
x y
IntNeOp -> condIntReg NE x y
IntLtOp -> condIntReg LT x y
IntLtOp -> condIntReg LT
T
x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
WordEqOp -> condIntReg EQ x y
WordEqOp -> condIntReg EQ
Q
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 EQ
Q
x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
FloatGtOp -> condFltReg GT x y
FloatGtOp -> condFltReg GT
T
x y
FloatGeOp -> condFltReg GE x y
FloatEqOp -> condFltReg EQ x y
FloatEqOp -> condFltReg EQ
Q
x y
FloatNeOp -> condFltReg NE x y
FloatLtOp -> condFltReg LT x y
FloatLtOp -> condFltReg LT
T
x y
FloatLeOp -> condFltReg LE x y
DoubleGtOp -> condFltReg GT x y
DoubleGtOp -> condFltReg GT
T
x y
DoubleGeOp -> condFltReg GE x y
DoubleEqOp -> condFltReg EQ x y
DoubleEqOp -> condFltReg EQ
Q
x y
DoubleNeOp -> condFltReg NE x y
DoubleLtOp -> condFltReg LT x y
DoubleLtOp -> condFltReg LT
T
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 GT
T
x y
CharGeOp -> condIntReg GE x y
CharEqOp -> condIntReg EQ x y
CharEqOp -> condIntReg EQ
Q
x y
CharNeOp -> condIntReg NE x y
CharLtOp -> condIntReg LT x y
CharLtOp -> condIntReg LT
T
x y
CharLeOp -> condIntReg LE x y
IntGtOp -> condIntReg GT x y
IntGtOp -> condIntReg GT
T
x y
IntGeOp -> condIntReg GE x y
IntEqOp -> condIntReg EQ x y
IntEqOp -> condIntReg EQ
Q
x y
IntNeOp -> condIntReg NE x y
IntLtOp -> condIntReg LT x y
IntLtOp -> condIntReg LT
T
x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
WordEqOp -> condIntReg EQ x y
WordEqOp -> condIntReg EQ
Q
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 EQ
Q
x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
FloatGtOp -> condFltReg GT x y
FloatGtOp -> condFltReg GT
T
x y
FloatGeOp -> condFltReg GE x y
FloatEqOp -> condFltReg EQ x y
FloatEqOp -> condFltReg EQ
Q
x y
FloatNeOp -> condFltReg NE x y
FloatLtOp -> condFltReg LT x y
FloatLtOp -> condFltReg LT
T
x y
FloatLeOp -> condFltReg LE x y
DoubleGtOp -> condFltReg GT x y
DoubleGtOp -> condFltReg GT
T
x y
DoubleGeOp -> condFltReg GE x y
DoubleEqOp -> condFltReg EQ x y
DoubleEqOp -> condFltReg EQ
Q
x y
DoubleNeOp -> condFltReg NE x y
DoubleLtOp -> condFltReg LT x y
DoubleLtOp -> condFltReg LT
T
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 GT
T
x y
CharGeOp -> condIntCode GE x y
CharEqOp -> condIntCode EQ x y
CharEqOp -> condIntCode EQ
Q
x y
CharNeOp -> condIntCode NE x y
CharLtOp -> condIntCode LT x y
CharLtOp -> condIntCode LT
T
x y
CharLeOp -> condIntCode LE x y
IntGtOp -> condIntCode GT x y
IntGtOp -> condIntCode GT
T
x y
IntGeOp -> condIntCode GE x y
IntEqOp -> condIntCode EQ x y
IntEqOp -> condIntCode EQ
Q
x y
IntNeOp -> condIntCode NE x y
IntLtOp -> condIntCode LT x y
IntLtOp -> condIntCode LT
T
x y
IntLeOp -> condIntCode LE x y
WordGtOp -> condIntCode GU x y
WordGeOp -> condIntCode GEU x y
WordEqOp -> condIntCode EQ x y
WordEqOp -> condIntCode EQ
Q
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 EQ
Q
x y
AddrNeOp -> condIntCode NE x y
AddrLtOp -> condIntCode LU x y