%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}
structure should not be too overwhelming.
\begin{code}
+module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
+
#include "HsVersions.h"
#include "nativeGen/NCG.h"
-module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
-
-IMP_Ubiq(){-uitious-}
-
import MachMisc -- may differ per-platform
import MachRegs
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( isAsmTemp )
+import CallConv ( CallConv )
+import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
-import Pretty ( prettyToUn, ppRational )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
+import CallConv ( cCallConv )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
- mapAccumLUs, UniqSM(..)
+ mapAccumLUs, UniqSM
)
-import Unpretty ( uppPStr )
-import Util ( panic, assertPanic )
+import Outputable
\end{code}
Code extractor for an entire stix tree---stix statement level.
stmt2Instrs stmt = case stmt of
StComment s -> returnInstr (COMMENT s)
StSegment seg -> returnInstr (SEGMENT seg)
+
+#if 1
+ -- StFunBegin, normal non-debugging code for all architectures
StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
+#else
+ -- StFunBegin, special tracing code for x86-Linux only
+ -- requires you to supply
+ -- void native_trace ( char* str )
+ StFunBegin lab -> getUniqLabelNCG `thenUs` \ str_lbl ->
+ returnUs (mkSeqInstrs [
+ LABEL lab,
+ COMMENT SLIT("begin trace sequence"),
+ SEGMENT DataSegment,
+ LABEL str_lbl,
+ ASCII True (showSDoc (pprCLabel_asm lab)),
+ SEGMENT TextSegment,
+ PUSHA,
+ PUSH L (OpImm (ImmCLbl str_lbl)),
+ CALL (ImmLit (text "native_trace")),
+ ADD L (OpImm (ImmInt 4)) (OpReg esp),
+ POPA,
+ COMMENT SLIT("end trace sequence")
+ ])
+#endif
+
StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
StLabel lab -> returnInstr (LABEL lab)
StJump arg -> genJump arg
StCondJump lab arg -> genCondJump lab arg
- StCall fn VoidRep args -> genCCall fn VoidRep args
+ StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
StAssign pk dst src
| isFloatingRep pk -> assignFltCode pk dst src
StData kind args
-> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
- (foldr1 (.) codes xs))
+ (foldr (.) id codes xs))
where
getData :: StixTree -> UniqSM (InstrBlock, Imm)
getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, dblImmLit d)
+ getData (StDouble d) = returnUs (id, ImmDouble d)
getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
getData (StCLbl l) = returnUs (id, ImmCLbl l)
getData (StString s) =
getUniqLabelNCG `thenUs` \ lbl ->
returnUs (mkSeqInstrs [LABEL lbl,
ASCII True (_UNPK_ s)],
ImmCLbl lbl)
+ -- the linker can handle simple arithmetic...
+ getData (StIndex rep (StCLbl lbl) (StInt off)) =
+ returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
\end{code}
%************************************************************************
where
off = StInt (i * sizeOf pk)
+#ifndef i386_TARGET_ARCH
mangleIndexTree (StIndex pk base off)
= StPrim IntAddOp [base,
case pk of
StPrim SllOp [off, StInt s]
]
where
- shift DoubleRep = 3
+ shift DoubleRep = 3::Integer
shift _ = IF_ARCH_alpha(3,2)
+#else
+-- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
+-- that do include the size of the primitive kind we're addressing. When StIndex
+-- is expanded to actual code, the index (in units) is by the above code approp.
+-- shifted to get the no. of bytes. Since Address amodes do contain size info
+-- explicitly, we disable the shifting for x86s.
+mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
+#endif
+
\end{code}
\begin{code}
maybeImm :: StixTree -> Maybe Imm
maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
maybeImm (StCLbl l) = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off)) =
+ Just (ImmIndex l (fromInteger (off * sizeOf rep)))
+
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
-getRegister (StCall fn kind args)
- = genCCall fn kind args `thenUs` \ call ->
+getRegister (StCall fn cconv kind args)
+ = genCCall fn cconv kind args `thenUs` \ call ->
returnUs (Fixed kind reg call)
where
reg = if isFloatingRep kind
- then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
+ then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
getRegister (StString s)
in
returnUs (Any PtrRep code)
-getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- imm_lbl = ImmCLbl lbl
- code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII False (init xs),
- SEGMENT TextSegment,
-#if alpha_TARGET_ARCH
- LDA dst (AddrImm imm_lbl)
-#endif
-#if i386_TARGET_ARCH
- MOV L (OpImm imm_lbl) (OpReg dst)
-#endif
-#if sparc_TARGET_ARCH
- SETHI (HI imm_lbl) dst,
- OR False dst (RIImm (LO imm_lbl)) dst
-#endif
- ]
- in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
-- end of machine-"independent" bit; here we go on the rest...
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA TF [ImmLab (prettyToUn (ppRational d))],
+ DATA TF [ImmLab (rational d)],
SEGMENT TextSegment,
LDA tmp (AddrImm (ImmCLbl lbl)),
LD TF dst (AddrReg tmp)]
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEG Q False) x
- IntAbsOp -> trivialUCode (ABS Q) x
NotOp -> trivialUCode NOT x
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn DoubleRep [x])
+ other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
where
fn = case other_op of
FloatExpOp -> SLIT("exp")
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
IntQuotOp -> trivialCode (DIV Q False) x y
IntRemOp -> trivialCode (REM Q False) x y
+ WordQuotOp -> trivialCode (DIV Q True) x y
+ WordRemOp -> trivialCode (REM Q True) x y
+
FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
AndOp -> trivialCode AND x y
OrOp -> trivialCode OR x y
+ XorOp -> trivialCode XOR x y
SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "AlphaGen:isll"
- ISraOp -> panic "AlphaGen:isra"
- ISrlOp -> panic "AlphaGen:isrl"
+ ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+ ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+ ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
where
{- ------------------------------------------------------------
Some bizarre special code for getting condition codes into
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
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
-
-getRegister (StDouble 0.0)
- = let
- code dst = mkSeqInstrs [FLDZ]
- in
- returnUs (Any DoubleRep code)
-
-getRegister (StDouble 1.0)
- = let
- code dst = mkSeqInstrs [FLD1]
- in
- returnUs (Any DoubleRep code)
-
getRegister (StDouble d)
= getUniqLabelNCG `thenUs` \ lbl ->
- --getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
- FLD DF (OpImm (ImmCLbl lbl))
+ GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
]
in
returnUs (Any DoubleRep code)
+
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEGI L) x
- IntAbsOp -> absIntCode x
-
NotOp -> trivialUCode (NOT L) x
- FloatNegOp -> trivialUFCode FloatRep FCHS x
- FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
- DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+ FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
+ DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
+
+ FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
+ DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
- DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+ Double2FloatOp -> trivialUFCode FloatRep GDTOF x
+ Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
OrdOp -> coerceIntCode IntRep x
ChrOp -> chrCode x
Double2IntOp -> coerceFP2Int x
Int2DoubleOp -> coerceInt2FP DoubleRep x
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
other_op ->
let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
in
- getRegister (StCall fn DoubleRep [x])
+ getRegister (StCall fn cCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
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)...
IntRemOp -> quot_code L x y False{-remainder-}
IntMulOp -> trivialCode (IMUL L) x y {-True-}
- FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
- FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
- FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
- FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
+ FloatAddOp -> trivialFCode FloatRep GADD x y
+ FloatSubOp -> trivialFCode FloatRep GSUB x y
+ FloatMulOp -> trivialFCode FloatRep GMUL x y
+ FloatDivOp -> trivialFCode FloatRep GDIV x y
- DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
- DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
- DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
- DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
+ DoubleAddOp -> trivialFCode DoubleRep GADD x y
+ DoubleSubOp -> trivialFCode DoubleRep GSUB x y
+ DoubleMulOp -> trivialFCode DoubleRep GMUL x y
+ DoubleDivOp -> trivialFCode DoubleRep GDIV x y
AndOp -> trivialCode (AND L) x y {-True-}
OrOp -> trivialCode (OR L) x y {-True-}
- SllOp -> trivialCode (SHL L) x y {-False-}
- SraOp -> trivialCode (SAR L) x y {-False-}
- SrlOp -> trivialCode (SHR L) x y {-False-}
-
- ISllOp -> panic "I386Gen:isll"
- ISraOp -> panic "I386Gen:isra"
- ISrlOp -> panic "I386Gen:isrl"
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+ XorOp -> trivialCode (XOR L) x y {-True-}
+
+ {- Shift ops on x86s have constraints on their source, it
+ either has to be Imm, CL or 1
+ => trivialCode's is not restrictive enough (sigh.)
+ -}
+
+ SllOp -> shift_code (SHL L) x y {-False-}
+ SrlOp -> shift_code (SHR L) x y {-False-}
+
+ ISllOp -> shift_code (SHL L) x y {-False-}
+ ISraOp -> shift_code (SAR L) x y {-False-}
+ ISrlOp -> shift_code (SHR L) x y {-False-}
+
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [x, y])
where
+
+ --------------------
+ shift_code :: (Operand -> Operand -> Instr)
+ -> StixTree
+ -> StixTree
+ -> UniqSM Register
+
+ {- Case1: shift length as immediate -}
+ -- Code is the same as the first eq. for trivialCode -- sigh.
+ shift_code instr x y{-amount-}
+ | maybeToBool imm
+ = getRegister x `thenUs` \ register ->
+ let
+ op_imm = OpImm imm__2
+ code__2 dst =
+ let
+ code = registerCode register dst
+ src = registerName register dst
+ in
+ mkSeqInstr (COMMENT SLIT("shift_code")) .
+ code .
+ if isFixed register && src /= dst
+ then
+ mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr op_imm (OpReg dst)]
+ else
+ mkSeqInstr (instr op_imm (OpReg src))
+ in
+ returnUs (Any IntRep code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+ {- Case2: shift length is complex (non-immediate) -}
+ shift_code instr x y{-amount-}
+ = getRegister y `thenUs` \ register1 ->
+ getRegister x `thenUs` \ register2 ->
+ let
+ -- Note: we force the shift length to be loaded
+ -- into ECX, so that we can use CL when shifting.
+ -- (only register location we are allowed
+ -- to put shift amounts.)
+ --
+ -- The shift instruction is fed ECX as src reg,
+ -- but we coerce this into CL when printing out.
+ src1 = registerName register1 ecx
+ code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
+ registerCode register1 ecx .
+ mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
+ else
+ registerCode register1 ecx
+ code__2 =
+ let
+ code2 = registerCode register2 eax
+ src2 = registerName register2 eax
+ in
+ code1 . code2 .
+ mkSeqInstr (instr (OpReg ecx) (OpReg eax))
+ in
+ returnUs (Fixed IntRep eax code__2)
+
+ --------------------
add_code :: Size -> StixTree -> StixTree -> UniqSM Register
add_code sz x (StInt y)
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
- in
- returnUs (Any IntRep code__2)
-
- add_code sz x (StInd _ mem)
- = getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
- in
- returnUs (Any IntRep code__2)
-
- add_code sz (StInd _ mem) y
- = getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- fixedname = registerName register2 eax
- code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+ code__2 dst
+ = code .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ code__2 dst
+ = asmParThen [code1, code2] .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1))
+ (ImmInt 0)))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst
+ = code .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
src2 = ImmInt (fromInteger i)
code__2 = asmParThen [code1] .
mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ MOV L (OpImm src2)
+ (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1)))
+ ]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
src2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2] .
if src2 == ecx || src2 == esi
- then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpReg src2)]
+ then mkSeqInstrs [
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)
+ ]
else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ MOV L (OpReg src2)
+ (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1)))
+ ]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
= getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode
- src = amodeAddr amode
+ src = amodeAddr amode
size = primRepToSize pk
code__2 dst = code .
if pk == DoubleRep || pk == FloatRep
- then mkSeqInstr (FLD {-DF-} size (OpAddr src))
+ then mkSeqInstr (GLD size src dst)
else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
in
returnUs (Any pk code__2)
-
getRegister (StInt i)
= let
src = ImmInt (fromInteger i)
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (SUB False False g0) x
- IntAbsOp -> absIntCode x
-
NotOp -> trivialUCode (XNOR False g0) x
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
then StPrim Float2DoubleOp [x]
else x
in
- getRegister (StCall fn DoubleRep [x])
+ getRegister (StCall fn cCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
FloatExpOp -> (True, SLIT("exp"))
FloatLogOp -> (True, SLIT("log"))
+ FloatSqrtOp -> (True, SLIT("sqrt"))
FloatSinOp -> (True, SLIT("sin"))
FloatCosOp -> (True, SLIT("cos"))
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
+ DoubleSqrtOp -> (True, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
+ _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
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
DoubleDivOp -> trivialFCode DoubleRep FDIV x y
AndOp -> trivialCode (AND False) x y
- OrOp -> trivialCode (OR False) x y
+ OrOp -> trivialCode (OR False) x y
+ XorOp -> trivialCode (XOR False) x y
SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "SparcGen:isll"
- ISraOp -> panic "SparcGen:isra"
- ISrlOp -> panic "SparcGen:isrl"
+ ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
+ ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
+ ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
+-- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
where
- imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+ imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
getRegister (StInd pk mem)
= getAmode mem `thenUs` \ amode ->
@Amode@s: Memory addressing modes passed up the tree.
\begin{code}
-data Amode = Amode Addr InstrBlock
+data Amode = Amode MachRegsAddr InstrBlock
amodeAddr (Amode addr _) = addr
amodeCode (Amode _ code) = code
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| maybeToBool imm
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, y])
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
getAmode leaf
| maybeToBool imm
reg = registerName register tmp
off = Nothing
in
- returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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 -}
returnUs (CondCode False cond code__2)
-----------
-
-condFltCode cond x (StDouble 0.0)
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
- let
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code__2 = asmParThen [code1 asmVoid] .
- mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (CondCode True (fix_FP_cond cond) code__2)
-
condFltCode cond x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
`thenUs` \ tmp1 ->
getNewRegNCG (registerRep register2)
`thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerRep register1
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
+ pk2 = registerRep register2
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
- mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ code__2 = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
+
+ {- On the 486, the flags set by FP compare are the unsigned ones!
+ (This looks like a HACK to me. WDP 96/03)
+ -}
+ fix_FP_cond :: Cond -> Cond
+
+ fix_FP_cond GE = GEU
+ fix_FP_cond GTT = GU
+ fix_FP_cond LTT = LU
+ fix_FP_cond LE = LEU
+ fix_FP_cond any = any
in
returnUs (CondCode True (fix_FP_cond cond) code__2)
-{- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
--}
-
-fix_FP_cond :: Cond -> Cond
-fix_FP_cond GE = GEU
-fix_FP_cond GT = GU
-fix_FP_cond LT = LU
-fix_FP_cond LE = LEU
-fix_FP_cond any = any
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
assignIntCode pk (StInd _ dst) src
= getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ getRegister src `thenUs` \ register ->
let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
= 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
= getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode src `thenUs` \ amodesrc ->
getAmode dst `thenUs` \ amodedst ->
- --getRegister src `thenUs` \ register ->
let
codesrc1 = amodeCode amodesrc asmVoid
addrsrc1 = amodeAddr amodesrc
returnUs code__2
assignFltCode pk (StInd _ dst) src
- = --getNewRegNCG pk `thenUs` \ tmp ->
+ = getNewRegNCG pk `thenUs` \ tmp ->
getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ getRegister src `thenUs` \ register ->
let
sz = primRepToSize pk
dst__2 = amodeAddr amode
code1 = amodeCode amode asmVoid
- code2 = registerCode register {-tmp-}st0 asmVoid
+ code2 = registerCode register tmp asmVoid
- --src__2= registerName register tmp
- pk__2 = registerRep register
- sz__2 = primRepToSize pk__2
+ src__2 = registerName register tmp
code__2 = asmParThen [code1, code2] .
- mkSeqInstr (FSTP sz (OpAddr dst__2))
+ mkSeqInstr (GST sz src__2 dst__2)
in
returnUs code__2
assignFltCode pk dst src
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp ->
+ getNewRegNCG pk `thenUs` \ tmp ->
let
- sz = primRepToSize pk
- dst__2 = registerName register1 st0 --tmp
-
- code = registerCode register2 dst__2
+ -- the register which is dst
+ dst__2 = registerName register1 tmp
+ -- the register into which src is computed, preferably dst__2
src__2 = registerName register2 dst__2
+ -- code to compute src into src__2
+ code = registerCode register2 dst__2
- code__2 = code
+ code__2 = if isFixed register2
+ then code . mkSeqInstr (GMOV src__2 dst__2)
+ else code
in
returnUs code__2
#if sparc_TARGET_ARCH
assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenUs` \ tmp ->
+ = getNewRegNCG pk `thenUs` \ tmp1 ->
getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ getRegister src `thenUs` \ register ->
let
sz = primRepToSize pk
dst__2 = amodeAddr amode
code1 = amodeCode amode asmVoid
- code2 = registerCode register tmp asmVoid
+ code2 = registerCode register tmp1 asmVoid
- src__2 = registerName register tmp
+ src__2 = registerName register tmp1
pk__2 = registerRep register
sz__2 = primRepToSize pk__2
code__2 = asmParThen [code1, code2] .
if pk == pk__2 then
- mkSeqInstr (ST sz src__2 dst__2)
+ mkSeqInstr (ST sz src__2 dst__2)
else
- mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
+ mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
in
returnUs code__2
assignFltCode pk dst src
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
- getNewRegNCG (registerRep register2)
- `thenUs` \ tmp ->
+ let
+ pk__2 = registerRep register2
+ sz__2 = primRepToSize pk__2
+ in
+ getNewRegNCG pk__2 `thenUs` \ tmp ->
let
sz = primRepToSize pk
dst__2 = registerName register1 g0 -- must be Fixed
+
reg__2 = if pk /= pk__2 then tmp else dst__2
code = registerCode register2 reg__2
+
src__2 = registerName register2 reg__2
- pk__2 = registerRep register2
- sz__2 = primRepToSize pk__2
- code__2 = if pk /= pk__2 then
+ code__2 =
+ if pk /= pk__2 then
code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
else if isFixed register2 then
code . mkSeqInstr (FMOV sz src__2 dst__2)
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)
\begin{code}
genCCall
:: FAST_STRING -- function to call
+ -> CallConv
-> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
-> UniqSM InstrBlock
#if alpha_TARGET_ARCH
-genCCall fn kind args
+genCCall fn cconv kind args
= mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
`thenUs` \ ((unused,_), argCode) ->
let
code = asmParThen (map ($ asmVoid) argCode)
in
returnSeq code [
- LDA pv (AddrImm (ImmLab (uppPStr fn))),
+ LDA pv (AddrImm (ImmLab (ptext fn))),
JSR ra (AddrReg pv) nRegs,
LDGP gp (AddrReg ra)]
where
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-genCCall fn kind [StInt i]
+genCCall fn cconv kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
- LABEL lbl]
+ = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ CALL (ImmLit (ptext (if underscorePrefix
+ then (SLIT ("_PerformGC_wrapper"))
+ else (SLIT ("PerformGC_wrapper")))))]
in
returnInstrs call
-genCCall fn kind args
- = mapUs get_call_arg args `thenUs` \ argCode ->
+
+genCCall fn cconv kind args
+ = mapUs get_call_arg args `thenUs` \ sizes_and_argCodes ->
let
- nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
+ (sizes, argCode) = unzip sizes_and_argCodes
+ tot_arg_size = sum (map (\sz -> case sz of DF -> 8; _ -> 4) sizes)
+
code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL fn__2 -- ,
- -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
+ call = [CALL fn__2 ,
+ ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
+ ]
in
- returnSeq (code1 . code2) call
+ returnSeq (code2) call
+
where
-- function names that begin with '.' are assumed to be special
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------
- get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
+ get_call_arg :: StixTree{-current argument-}
+ -> UniqSM (Size, InstrBlock) -- arg size, code
get_call_arg arg
= get_op arg `thenUs` \ (code, op, sz) ->
- returnUs (code . mkSeqInstr (PUSH sz op))
+ case sz of
+ DF -> --getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ returnUs (sz,
+ code .
+ --mkSeqInstr (GLD DF op tmp) .
+ mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
+ mkSeqInstr (GST DF {-tmp-}op (AddrBaseIndex
+ (Just esp)
+ Nothing (ImmInt 0)))
+ )
+ _ -> returnUs (sz,
+ code . mkSeqInstr (PUSH sz (OpReg op)))
------------
get_op
:: StixTree
- -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
-
+ -> UniqSM (InstrBlock, {-Operand-}Reg, Size) -- code, operator, size
+{-
get_op (StInt i)
= returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
sz = primRepToSize pk
in
returnUs (code, OpAddr addr, sz)
-
+-}
get_op op
= getRegister op `thenUs` \ register ->
getNewRegNCG (registerRep register)
pk = registerRep register
sz = primRepToSize pk
in
- returnUs (code, OpReg reg, sz)
+ returnUs (code, {-OpReg-} reg, sz)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-genCCall fn kind args
+genCCall fn cconv kind args
= mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
`thenUs` \ ((unused,_), argCode) ->
let
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------------------------------
{- Try to get a value into a specific register (or registers) for
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 ->
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (
- {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
- (Size -> Operand -> Instr)
- -> (Size -> Operand -> Instr) {-reversed instr-}
- -> Instr {-pop-}
- -> Instr {-reversed instr: pop-}
+ ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
-> StixTree -> StixTree -- the two arguments
-> UniqSM Register
trivialUFCode
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (Instr
+ ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
-> StixTree -- the one argument
trivialCode instr x y
| maybeToBool imm
= getRegister x `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
trivialCode instr x y
| maybeToBool imm
= getRegister y `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
+ then mkSeqInstrs [MOV L (OpImm imm__2) (OpReg dst),
+ instr (OpReg src1) (OpReg dst)]
else
mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
in
imm = maybeImm x
imm__2 = case imm of Just x -> x
-trivialCode instr x (StInd pk mem)
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-
-trivialCode instr (StInd pk mem) y
- = getRegister y `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let
- code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-
trivialCode instr x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- fixedname = registerName register1 eax
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = let
-----------
trivialUCode instr x
= getRegister x `thenUs` \ register ->
--- getNewRegNCG IntRep `thenUs` \ tmp ->
let
--- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
returnUs (Any IntRep code__2)
-----------
+{-
trivialFCode pk _ instrr _ _ (StInd pk' mem) y
= getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
getAmode mem `thenUs` \ amode ->
let
code1 = amodeCode amode
trivialFCode pk instr _ _ _ x (StInd pk' mem)
= getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
getAmode mem `thenUs` \ amode ->
let
code2 = amodeCode amode
trivialFCode pk _ _ _ instrpr x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerRep register1
mkSeqInstr instrpr
in
returnUs (Any pk1 code__2)
+-}
+
+trivialFCode pk instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+ in
+ returnUs (Any DoubleRep code__2)
+
-------------
+trivialUFCode pk instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG pk `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
+ in
+ returnUs (Any pk code__2)
+
+{-
trivialUFCode pk instr (StInd pk' mem)
= getAmode mem `thenUs` \ amode ->
let
trivialUFCode pk instr x
= getRegister x `thenUs` \ register ->
- --getNewRegNCG pk `thenUs` \ tmp ->
let
code__2 dst = let
code = registerCode register dst
in code . mkSeqInstrs [instr]
in
returnUs (Any pk code__2)
-
+-}
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
let
code = registerCode register reg
src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
+ code__2 dst = code .
+ mkSeqInstr (opc src dst)
in
returnUs (Any pk code__2)
src = registerName register tmp
pk = registerRep register
- code__2 dst = let
- in code . mkSeqInstrs [
- FRNDINT,
- FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
+ code__2 dst = code .
+ mkSeqInstr (opc src dst)
in
returnUs (Any IntRep code__2)
= getRegister x `thenUs` \ register ->
--getNewRegNCG IntRep `thenUs` \ reg ->
let
- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
#endif {- sparc_TARGET_ARCH -}
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Absolute value on integers}
-%* *
-%************************************************************************
-
-Absolute value on integers, mostly for gmp size check macros. Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-If applicable, do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-absIntCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-absIntCode = panic "MachCode.absIntCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
projects / ghc-hetmet.git / blobdiff