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 Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
-import PprStyle
+import Outputable ( PprStyle(..) )
import Pretty ( ptext, rational )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..), showPrimOp )
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}
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
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-}
-
+ 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-}
+ SraOp -> shift_code (SAR L) x y {-False-}
+ SrlOp -> shift_code (SHR L) x y {-False-}
+
+ {- ToDo: nuke? -}
ISllOp -> panic "I386Gen:isll"
ISraOp -> panic "I386Gen:isra"
ISrlOp -> panic "I386Gen:isrl"
where promote x = StPrim Float2DoubleOp [x]
DoublePowerOp -> getRegister (StCall SLIT("pow") 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 ->
+-- getNewRegNCG IntRep `thenUs` \ dst ->
+ 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)
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst))
in
returnUs (Any IntRep code__2)
code2 = amodeCode amode
src2 = amodeAddr amode
- fixedname = registerName register1 eax
+-- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in asmParThen [code2 asmVoid,code1 asmVoid] .
code1 = amodeCode amode
src1 = amodeAddr amode
- fixedname = registerName register2 eax
+-- fixedname = registerName register2 eax
code__2 dst = let code2 = registerCode register2 dst
src2 = registerName register2 dst
in asmParThen [code1 asmVoid,code2 asmVoid] .
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))
+ mkSeqInstr (LEA sz (OpAddr (Address (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
in
returnUs (Any IntRep code__2)
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (Address (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 (OpImm src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
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 src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
DATA DF [dblImmLit 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)
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
@Amode@s: Memory addressing modes passed up the tree.
\begin{code}
-data Amode = Amode MachRegsAddr InstrBlock
+data Amode = Amode Address InstrBlock
amodeAddr (Amode addr _) = addr
amodeCode (Amode _ code) = code
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 (Address (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 (Address (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 (Address (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 (Address (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}
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
#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}
genCCall fn kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
+ = 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
+
+{- OLD:
= 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))),
+ (OpAddr (Address (Just ebx) Nothing (ImmInt 104))),
JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
LABEL lbl]
in
returnInstrs call
+-}
genCCall fn kind args
= mapUs get_call_arg args `thenUs` \ argCode ->
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)
+{- OLD: Since there's no attempt at stealing %esp at the moment,
+ restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
+ (ditto for saving away old-esp in MainRegTable.Hp (!!) )
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Address (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
]
]
+-}
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 ,
+ -- pop args; all args word sized?
+ ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
+
+ -- Don't restore %esp (see above)
+ -- MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 80))) (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
= getRegister x `thenUs` \ register1 ->
--getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- fixedname = registerName register1 eax
+-- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
= getRegister y `thenUs` \ register1 ->
--getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- fixedname = registerName register1 eax
+-- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
--getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode mem `thenUs` \ amode ->
let
- fixedname = registerName register eax
+-- fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register dst asmVoid
--getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode mem `thenUs` \ amode ->
let
- fixedname = registerName register eax
+-- fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let
--getNewRegNCG IntRep `thenUs` \ tmp1 ->
getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- fixedname = registerName register1 eax
+-- fixedname = registerName register1 eax
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = let
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]
+ MOV L (OpReg src) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ FILD (primRepToSize pk) (Address (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
in
returnUs (Any pk code__2)
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)]
+ FIST L (Address (Just ebx) Nothing (ImmInt OFFSET_R1)),
+ MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
in
returnUs (Any IntRep code__2)
= getRegister x `thenUs` \ register ->
--getNewRegNCG IntRep `thenUs` \ reg ->
let
- fixedname = registerName register eax
+-- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
#endif {- sparc_TARGET_ARCH -}
\end{code}
+
projects / ghc-hetmet.git / blobdiff