%
-% (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, SYN_IE(InstrList) ) where
-
-IMP_Ubiq(){-uitious-}
-
import MachMisc -- may differ per-platform
-#if __GLASGOW_HASKELL__ >= 202
-import MachRegs hiding (Addr(..))
-import qualified MachRegs (Addr(..))
-#define MachRegsAddr MachRegs.Addr
-#define MachRegsAddrRegImm MachRegs.AddrRegImm
-#define MachRegsAddrRegReg MachRegs.AddrRegReg
-#else
import MachRegs
-#define MachRegsAddr Addr
-#define MachRegsAddrRegImm AddrRegImm
-#define MachRegsAddrRegReg AddrRegReg
-#endif
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( isAsmTemp, CLabel )
+import CallConv ( CallConv )
+import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
-import PprStyle
-import Pretty ( ptext, rational )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..), showPrimOp )
+import PrimOp ( PrimOp(..) )
+import CallConv ( cCallConv )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
- mapAccumLUs, SYN_IE(UniqSM)
+ mapAccumLUs, UniqSM
)
-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...
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")
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
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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
- DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+ FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
+ DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) 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
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 (MachRegsAddr (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 (MachRegsAddr (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 (MachRegsAddr (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 (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (MachRegsAddr (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 (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (MachRegsAddr (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 (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
returnUs (Any DoubleRep code)
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
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
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
+ _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
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 ->
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (MachRegsAddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
= getNewRegNCG PtrRep `thenUs` \ tmp ->
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (MachRegsAddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode leaf
| maybeToBool imm
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (MachRegsAddr (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 (MachRegsAddr (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 (MachRegsAddr (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 (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (MachRegsAddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (MachRegsAddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, y])
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2)
+ returnUs (Amode (AddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code)
+ returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
reg = registerName register tmp
off = ImmInt 0
in
- returnUs (Amode (MachRegsAddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
#endif {- sparc_TARGET_ARCH -}
\end{code}
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 GTT = GU
-fix_FP_cond LTT = 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
= 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)
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
+ returnSeq code [JMP (AddrRegReg target g0), NOP]
#endif {- sparc_TARGET_ARCH -}
\end{code}
\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
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (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 (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (MachRegsAddr (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 (MachRegsAddr (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
_ -> 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
:: 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 (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (MachRegsAddr (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 (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (MachRegsAddr (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