structure should not be too overwhelming.
\begin{code}
-module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
+module MachCode ( stmt2Instrs, InstrBlock ) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import MachMisc -- may differ per-platform
import MachRegs
-
+import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
+ snocOL, consOL, concatOL )
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
import Maybes ( maybeToBool, expectJust )
-import OrdList -- quite a bit of it
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
-import Stix ( getUniqLabelNCG, StixTree(..),
+import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
- pprStixTrees, ppStixReg
- )
-import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
- mapAccumLUs, UniqSM
+ pprStixTrees, ppStixReg,
+ NatM, thenNat, returnNat, mapNat, mapAndUnzipNat,
+ getDeltaNat, setDeltaNat
)
import Outputable
+
+\end{code}
+
+@InstrBlock@s are the insn sequences generated by the insn selectors.
+They are really trees of insns to facilitate fast appending, where a
+left-to-right traversal (pre-order?) yields the insns in the correct
+order.
+
+\begin{code}
+
+type InstrBlock = OrdList Instr
+
+infixr 3 `bind`
+x `bind` f = f x
+
\end{code}
Code extractor for an entire stix tree---stix statement level.
\begin{code}
-stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
+stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
stmt2Instrs stmt = case stmt of
- StComment s -> returnInstr (COMMENT s)
- StSegment seg -> returnInstr (SEGMENT seg)
+ StComment s -> returnNat (unitOL (COMMENT s))
+ StSegment seg -> returnNat (unitOL (SEGMENT seg))
- StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
- StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
- StLabel lab -> returnInstr (LABEL lab)
+ StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
+ LABEL lab)))
+ StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
+ returnNat nilOL)
+ StLabel lab -> returnNat (unitOL (LABEL lab))
StJump arg -> genJump arg
StCondJump lab arg -> genCondJump lab arg
-- When falling through on the Alpha, we still have to load pv
-- with the address of the next routine, so that it can load gp.
-> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
- ,returnUs id)
+ ,returnNat nilOL)
StData kind args
- -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
- returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
- (foldr (.) id codes xs))
+ -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
+ returnNat (DATA (primRepToSize kind) imms
+ `consOL` concatOL codes)
where
- getData :: StixTree -> UniqSM (InstrBlock, Imm)
+ getData :: StixTree -> NatM (InstrBlock, Imm)
- getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, ImmDouble d)
- getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StCLbl l) = returnUs (id, ImmCLbl l)
+ getData (StInt i) = returnNat (nilOL, ImmInteger i)
+ getData (StDouble d) = returnNat (nilOL, ImmDouble d)
+ getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
+ getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
getData (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- returnUs (mkSeqInstrs [LABEL lbl,
- ASCII True (_UNPK_ s)],
- ImmCLbl lbl)
+ getNatLabelNCG `thenNat` \ lbl ->
+ returnNat (toOL [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)))
+ returnNat (nilOL,
+ ImmIndex lbl (fromInteger (off * sizeOf rep)))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type InstrList = OrdList Instr
-type InstrBlock = InstrList -> InstrList
-
-asmVoid :: InstrList
-asmVoid = mkEmptyList
-
-asmInstr :: Instr -> InstrList
-asmInstr i = mkUnitList i
-
-asmSeq :: [Instr] -> InstrList
-asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
-
-asmParThen :: [InstrList] -> InstrBlock
-asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-
-returnInstr :: Instr -> UniqSM InstrBlock
-returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-
-returnInstrs :: [Instr] -> UniqSM InstrBlock
-returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-
-returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
-returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
-
-mkSeqInstr :: Instr -> InstrBlock
-mkSeqInstr instr code = mkSeqList (asmInstr instr) code
-
-mkSeqInstrs :: [Instr] -> InstrBlock
-mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
-\end{code}
-
-\begin{code}
mangleIndexTree :: StixTree -> StixTree
mangleIndexTree (StIndex pk base (StInt i))
registerCodeF (Fixed _ _ code) = code
registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
+registerCodeA (Any _ code) = code
+registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
+
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
registerName (Any _ _) reg = reg
registerRep (Fixed pk _ _) = pk
registerRep (Any pk _) = pk
-isFixed, isFloat :: Register -> Bool
+{-# INLINE registerCode #-}
+{-# INLINE registerCodeF #-}
+{-# INLINE registerName #-}
+{-# INLINE registerNameF #-}
+{-# INLINE registerRep #-}
+{-# INLINE isFixed #-}
+{-# INLINE isAny #-}
+
+isFixed, isAny :: Register -> Bool
isFixed (Fixed _ _ _) = True
isFixed (Any _ _) = False
-isFloat = not . isFixed
+isAny = not . isFixed
\end{code}
Generate code to get a subtree into a @Register@:
\begin{code}
-getRegister :: StixTree -> UniqSM Register
+getRegister :: StixTree -> NatM Register
getRegister (StReg (StixMagicId stgreg))
= case (magicIdRegMaybe stgreg) of
- Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
+ Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
-- cannae be Nothing
getRegister (StReg (StixTemp u pk))
- = returnUs (Fixed pk (UnmappedReg u pk) id)
+ = returnNat (Fixed pk (UnmappedReg u pk) nilOL)
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
getRegister (StCall fn cconv kind args)
- = genCCall fn cconv kind args `thenUs` \ call ->
- returnUs (Fixed kind reg call)
+ = genCCall fn cconv kind args `thenNat` \ call ->
+ returnNat (Fixed kind reg call)
where
reg = if isFloatingRep kind
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)
- = getUniqLabelNCG `thenUs` \ lbl ->
+ = getNatLabelNCG `thenNat` \ lbl ->
let
imm_lbl = ImmCLbl lbl
- code dst = mkSeqInstrs [
+ code dst = toOL [
SEGMENT DataSegment,
LABEL lbl,
ASCII True (_UNPK_ s),
#endif
]
in
- returnUs (Any PtrRep code)
+ returnNat (Any PtrRep code)
#if alpha_TARGET_ARCH
getRegister (StDouble d)
- = getUniqLabelNCG `thenUs` \ lbl ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
LDA tmp (AddrImm (ImmCLbl lbl)),
LD TF dst (AddrReg tmp)]
in
- returnUs (Any DoubleRep code)
+ returnNat (Any DoubleRep code)
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
any kind leave the result in a floating point register, so we
need to wrangle an integer register out of things.
-}
- int_NE_code :: StixTree -> StixTree -> UniqSM Register
+ int_NE_code :: StixTree -> StixTree -> NatM Register
int_NE_code x y
- = trivialCode (CMP EQQ) x y `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = trivialCode (CMP EQQ) x y `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
{- ------------------------------------------------------------
Comments for int_NE_code also apply to cmpF_code
:: (Reg -> Reg -> Reg -> Instr)
-> Cond
-> StixTree -> StixTree
- -> UniqSM Register
+ -> NatM Register
cmpF_code instr cond x y
- = trivialFCode pr instr x y `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- getUniqLabelNCG `thenUs` \ lbl ->
+ = trivialFCode pr instr x y `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
+ getNatLabelNCG `thenNat` \ lbl ->
let
code = registerCode register tmp
result = registerName register tmp
OR zeroh (RIReg zeroh) dst,
LABEL lbl]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
where
pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
------------------------------------------------------------
getRegister (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
src = amodeAddr amode
size = primRepToSize pk
code__2 dst = code . mkSeqInstr (LD size dst src)
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
getRegister (StInt i)
| fits8Bits i
= let
code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
in
- returnUs (Any IntRep code)
+ returnNat (Any IntRep code)
| otherwise
= let
code dst = mkSeqInstr (LDI Q dst src)
in
- returnUs (Any IntRep code)
+ returnNat (Any IntRep code)
where
src = ImmInt (fromInteger i)
= let
code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
in
- returnUs (Any PtrRep code)
+ returnNat (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
#if i386_TARGET_ARCH
getRegister (StDouble d)
- = getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
+
+ | d == 0.0
+ = let code dst = unitOL (GLDZ dst)
+ in trace "nativeGen: GLDZ"
+ (returnNat (Any DoubleRep code))
+
+ | d == 1.0
+ = let code dst = unitOL (GLD1 dst)
+ in trace "nativeGen: GLD1"
+ returnNat (Any DoubleRep code)
+
+ | otherwise
+ = getNatLabelNCG `thenNat` \ lbl ->
+ let code dst = toOL [
SEGMENT DataSegment,
LABEL lbl,
DATA DF [ImmDouble d],
GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
]
in
- returnUs (Any DoubleRep code)
+ returnNat (Any DoubleRep code)
--- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix
+-- Calculate the offset for (i+1) words above the _initial_
+-- %esp value by first determining the current offset of it.
getRegister (StScratchWord i)
| i >= 0 && i < 6
- = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst))
- in returnUs (Any PtrRep code)
+ = getDeltaNat `thenNat` \ current_stack_offset ->
+ let j = i+1 - (current_stack_offset `div` 4)
+ code dst
+ = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
+ in
+ returnNat (Any PtrRep code)
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
FloatExpOp -> (True, SLIT("exp"))
FloatLogOp -> (True, SLIT("log"))
- --FloatSinOp -> (True, SLIT("sin"))
- --FloatCosOp -> (True, SLIT("cos"))
- --FloatTanOp -> (True, SLIT("tan"))
-
FloatAsinOp -> (True, SLIT("asin"))
FloatAcosOp -> (True, SLIT("acos"))
FloatAtanOp -> (True, SLIT("atan"))
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
- --DoubleSinOp -> (False, SLIT("sin"))
- --DoubleCosOp -> (False, SLIT("cos"))
- --DoubleTanOp -> (False, SLIT("tan"))
-
DoubleAsinOp -> (False, SLIT("asin"))
DoubleAcosOp -> (False, SLIT("acos"))
DoubleAtanOp -> (False, SLIT("atan"))
shift_code :: (Imm -> Operand -> Instr)
-> StixTree
-> StixTree
- -> UniqSM Register
+ -> NatM 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` \ regx ->
+ = getRegister x `thenNat` \ regx ->
let mkcode dst
- = if isFloat regx
- then registerCode regx dst `bind` \ code_x ->
- code_x .
- mkSeqInstr (instr imm__2 (OpReg dst))
+ = if isAny regx
+ then registerCodeA regx dst `bind` \ code_x ->
+ code_x `snocOL`
+ instr imm__2 (OpReg dst)
else registerCodeF regx `bind` \ code_x ->
registerNameF regx `bind` \ r_x ->
- code_x .
- mkSeqInstr (MOV L (OpReg r_x) (OpReg dst)) .
- mkSeqInstr (instr imm__2 (OpReg dst))
+ code_x `snocOL`
+ MOV L (OpReg r_x) (OpReg dst) `snocOL`
+ instr imm__2 (OpReg dst)
in
- returnUs (Any IntRep mkcode)
+ returnNat (Any IntRep mkcode)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-- use it here to do non-immediate shifts. No big deal --
-- they are only very rare, and we can use an equivalent
-- test-and-jump sequence which doesn't use ECX.
- -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
+ -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
-- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
shift_code instr x y{-amount-}
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getUniqLabelNCG `thenUs` \ lbl_test3 ->
- getUniqLabelNCG `thenUs` \ lbl_test2 ->
- getUniqLabelNCG `thenUs` \ lbl_test1 ->
- getUniqLabelNCG `thenUs` \ lbl_test0 ->
- getUniqLabelNCG `thenUs` \ lbl_after ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNatLabelNCG `thenNat` \ lbl_test3 ->
+ getNatLabelNCG `thenNat` \ lbl_test2 ->
+ getNatLabelNCG `thenNat` \ lbl_test1 ->
+ getNatLabelNCG `thenNat` \ lbl_test0 ->
+ getNatLabelNCG `thenNat` \ lbl_after ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let code__2 dst
= let src_val = registerName register1 dst
code_val = registerCode register1 dst
r_dst = OpReg dst
r_tmp = OpReg tmp
in
- code_amt .
- mkSeqInstr (MOV L (OpReg src_amt) r_tmp) .
- code_val .
- mkSeqInstr (MOV L (OpReg src_val) r_dst) .
- mkSeqInstrs [
+ code_amt `snocOL`
+ MOV L (OpReg src_amt) r_tmp `appOL`
+ code_val `snocOL`
+ MOV L (OpReg src_val) r_dst `appOL`
+ toOL [
COMMENT (_PK_ "begin shift sequence"),
MOV L (OpReg src_val) r_dst,
MOV L (OpReg src_amt) r_tmp,
COMMENT (_PK_ "end shift sequence")
]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
--------------------
- add_code :: Size -> StixTree -> StixTree -> UniqSM Register
+ add_code :: Size -> StixTree -> StixTree -> NatM Register
add_code sz x (StInt y)
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst
- = code .
- mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst))
+ = code `snocOL`
+ LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
- add_code sz x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- 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)
+ add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
--------------------
- sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
+ sub_code :: Size -> StixTree -> StixTree -> NatM Register
sub_code sz x (StInt y)
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
code__2 dst
- = code .
- mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst))
+ = code `snocOL`
+ LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
sub_code sz x y = trivialCode (SUB sz) Nothing x y
:: Size
-> StixTree -> StixTree
-> Bool -- True => division, False => remainder operation
- -> UniqSM Register
+ -> NatM Register
-- x must go into eax, edx must be a sign-extension of eax, and y
-- should go in some other register (or memory), so that we get
- -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
- -- put y in memory (if it is not there already)
-
- -- quot_code needs further checking in the Rules-of-the-Game(x86) audit
- quot_code sz x (StInd pk mem) is_division
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 = asmParThen [code1, code2] .
- mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr src2)]
- in
- returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-
- quot_code sz x (StInt i) is_division
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- src2 = ImmInt (fromInteger i)
- code__2 = asmParThen [code1] .
- mkSeqInstrs [-- we put src2 in (ebx)
- 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)
+ -- edx:eax / reg -> eax (remainder in edx). Currently we choose
+ -- to put y on the C stack, since that avoids tying up yet another
+ -- precious register.
quot_code sz x y is_division
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ getDeltaNat `thenNat` \ delta ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- 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)
- ]
- else mkSeqInstrs [ -- we put src2 in (ebx)
- 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)))
- ]
+ code1 = registerCode register1 tmp
+ src1 = registerName register1 tmp
+ code2 = registerCode register2 tmp
+ src2 = registerName register2 tmp
+ code__2 = code2 `snocOL` -- src2 := y
+ PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
+ DELTA (delta-4) `appOL`
+ code1 `snocOL` -- src1 := x
+ MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
+ CLTD `snocOL`
+ IDIV sz (OpAddr (spRel 0)) `snocOL`
+ ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
+ DELTA delta
in
- returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
+ returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
getRegister (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
src = amodeAddr amode
size = primRepToSize pk
- code__2 dst = code .
- if pk == DoubleRep || pk == FloatRep
- then mkSeqInstr (GLD size src dst)
- else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+ code__2 dst = code `snocOL`
+ if pk == DoubleRep || pk == FloatRep
+ then GLD size src dst
+ else case size of
+ L -> MOV L (OpAddr src) (OpReg dst)
+ B -> MOVZxL B (OpAddr src) (OpReg dst)
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
getRegister (StInt i)
= let
src = ImmInt (fromInteger i)
- code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
+ code dst
+ | i == 0
+ = unitOL (XOR L (OpReg dst) (OpReg dst))
+ | otherwise
+ = unitOL (MOV L (OpImm src) (OpReg dst))
in
- returnUs (Any IntRep code)
+ returnNat (Any IntRep code)
getRegister leaf
| maybeToBool imm
- = let
- code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+ = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
in
- returnUs (Any PtrRep code)
+ returnNat (Any PtrRep code)
| otherwise
= pprPanic "getRegister(x86)" (pprStixTrees [leaf])
where
#if sparc_TARGET_ARCH
getRegister (StDouble d)
- = getUniqLabelNCG `thenUs` \ lbl ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
- returnUs (Any DoubleRep code)
+ returnNat (Any DoubleRep code)
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
getRegister (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
src = amodeAddr amode
size = primRepToSize pk
code__2 dst = code . mkSeqInstr (LD size src dst)
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
getRegister (StInt i)
| fits13Bits i
src = ImmInt (fromInteger i)
code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
in
- returnUs (Any IntRep code)
+ returnNat (Any IntRep code)
getRegister leaf
| maybeToBool imm
SETHI (HI imm__2) dst,
OR False dst (RIImm (LO imm__2)) dst]
in
- returnUs (Any PtrRep code)
+ returnNat (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
Now, given a tree (the argument to an StInd) that references memory,
produce a suitable addressing mode.
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to. So you can't put
+anything in between, lest it overwrite some of those registers. If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+ code
+ LEA amode, tmp
+ ... other computation ...
+ ... (tmp) ...
+
\begin{code}
-getAmode :: StixTree -> UniqSM Amode
+getAmode :: StixTree -> NatM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
#if alpha_TARGET_ARCH
getAmode (StPrim IntSubOp [x, StInt i])
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnNat (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnNat (Amode (AddrRegImm reg off) code)
getAmode leaf
| maybeToBool imm
- = returnUs (Amode (AddrImm imm__2) id)
+ = returnNat (Amode (AddrImm imm__2) id)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister other `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
in
- returnUs (Amode (AddrReg reg) code)
+ returnNat (Amode (AddrReg reg) code)
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
getAmode (StPrim IntSubOp [x, StInt i])
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| maybeToBool imm
- = let
- code = mkSeqInstrs []
- in
- returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+ = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
getAmode (StPrim IntAddOp [x, StInt i])
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
| shift == 0 || shift == 1 || shift == 2 || shift == 3
- = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1
reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2
reg2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2]
+ code__2 = code1 `appOL` code2
base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
in
- returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
- code__2)
+ returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
+ code__2)
getAmode leaf
| maybeToBool imm
- = let
- code = mkSeqInstrs []
- in
- returnUs (Amode (ImmAddr imm__2 0) code)
+ = returnNat (Amode (ImmAddr imm__2 0) nilOL)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister other `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
- off = Nothing
in
- returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
getAmode (StPrim IntSubOp [x, StInt i])
| fits13Bits (-i)
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnNat (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| fits13Bits i
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister x `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnNat (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, y])
- = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
reg2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2]
+ code__2 = asmSeqThen [code1, code2]
in
- returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+ returnNat (Amode (AddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other
- = getNewRegNCG PtrRep `thenUs` \ tmp ->
- getRegister other `thenUs` \ register ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt 0
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnNat (Amode (AddrRegImm reg off) code)
#endif {- sparc_TARGET_ARCH -}
\end{code}
Set up a condition code for a conditional branch.
\begin{code}
-getCondCode :: StixTree -> UniqSM CondCode
+getCondCode :: StixTree -> NatM CondCode
#if alpha_TARGET_ARCH
getCondCode = panic "MachCode.getCondCode: not on Alphas"
getCondCode (StPrim primop [x, y])
= case primop of
CharGtOp -> condIntCode GTT x y
- CharGeOp -> condIntCode GE x y
+ CharGeOp -> condIntCode GE x y
CharEqOp -> condIntCode EQQ x y
- CharNeOp -> condIntCode NE x y
+ CharNeOp -> condIntCode NE x y
CharLtOp -> condIntCode LTT x y
- CharLeOp -> condIntCode LE x y
+ CharLeOp -> condIntCode LE x y
IntGtOp -> condIntCode GTT x y
- IntGeOp -> condIntCode GE x y
+ IntGeOp -> condIntCode GE x y
IntEqOp -> condIntCode EQQ x y
- IntNeOp -> condIntCode NE x y
+ IntNeOp -> condIntCode NE x y
IntLtOp -> condIntCode LTT x y
- IntLeOp -> condIntCode LE x y
+ IntLeOp -> condIntCode LE x y
- WordGtOp -> condIntCode GU x y
- WordGeOp -> condIntCode GEU x y
+ WordGtOp -> condIntCode GU x y
+ WordGeOp -> condIntCode GEU x y
WordEqOp -> condIntCode EQQ x y
- WordNeOp -> condIntCode NE x y
- WordLtOp -> condIntCode LU x y
- WordLeOp -> condIntCode LEU 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
+ AddrGtOp -> condIntCode GU x y
+ AddrGeOp -> condIntCode GEU x y
AddrEqOp -> condIntCode EQQ x y
- AddrNeOp -> condIntCode NE x y
- AddrLtOp -> condIntCode LU x y
- AddrLeOp -> condIntCode LEU x y
+ AddrNeOp -> condIntCode NE x y
+ AddrLtOp -> condIntCode LU x y
+ AddrLeOp -> condIntCode LEU x y
FloatGtOp -> condFltCode GTT x y
- FloatGeOp -> condFltCode GE x y
+ FloatGeOp -> condFltCode GE x y
FloatEqOp -> condFltCode EQQ x y
- FloatNeOp -> condFltCode NE x y
+ FloatNeOp -> condFltCode NE x y
FloatLtOp -> condFltCode LTT x y
- FloatLeOp -> condFltCode LE x y
+ FloatLeOp -> condFltCode LE x y
DoubleGtOp -> condFltCode GTT x y
- DoubleGeOp -> condFltCode GE x y
+ DoubleGeOp -> condFltCode GE x y
DoubleEqOp -> condFltCode EQQ x y
- DoubleNeOp -> condFltCode NE x y
+ DoubleNeOp -> condFltCode NE x y
DoubleLtOp -> condFltCode LTT x y
- DoubleLeOp -> condFltCode LE x y
+ DoubleLeOp -> condFltCode LE x y
#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
\end{code}
passed back up the tree.
\begin{code}
-condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
+condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
--- some condIntCode clauses look pretty dodgy to me
-condIntCode cond (StInd _ x) y
+-- memory vs immediate
+condIntCode cond (StInd pk x) y
| maybeToBool imm
- = getAmode x `thenUs` \ amode ->
+ = getAmode x `thenNat` \ amode ->
let
- code1 = amodeCode amode asmVoid
- y__2 = amodeAddr amode
- code__2 = asmParThen [code1] .
- mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
+ code1 = amodeCode amode
+ x__2 = amodeAddr amode
+ sz = primRepToSize pk
+ code__2 = code1 `snocOL`
+ CMP sz (OpImm imm__2) (OpAddr x__2)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
+-- anything vs zero
condIntCode cond x (StInt 0)
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ = getRegister x `thenNat` \ register1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
- mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
+ code__2 = code1 `snocOL`
+ TEST L (OpReg src1) (OpReg src1)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
+-- anything vs immediate
condIntCode cond x y
| maybeToBool imm
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ = getRegister x `thenNat` \ register1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
- mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
+ code__2 = code1 `snocOL`
+ CMP L (OpImm imm__2) (OpReg src1)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-condIntCode cond (StInd _ x) y
- = getAmode x `thenUs` \ amode ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = amodeCode amode asmVoid
- src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
- in
- returnUs (CondCode False cond code__2)
-
-condIntCode cond y (StInd _ x)
- = getAmode x `thenUs` \ amode ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = amodeCode amode asmVoid
- src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
- in
- returnUs (CondCode False cond code__2)
-
+-- memory vs anything
+condIntCode cond (StInd pk x) y
+ = getAmode x `thenNat` \ amode_x ->
+ getRegister y `thenNat` \ reg_y ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ c_x = amodeCode amode_x
+ am_x = amodeAddr amode_x
+ c_y = registerCode reg_y tmp
+ r_y = registerName reg_y tmp
+ sz = primRepToSize pk
+
+ -- optimisation: if there's no code for x, just an amode,
+ -- use whatever reg y winds up in. Assumes that c_y doesn't
+ -- clobber any regs in the amode am_x, which I'm not sure is
+ -- justified. The otherwise clause makes the same assumption.
+ code__2 | isNilOL c_x
+ = c_y `snocOL`
+ CMP sz (OpReg r_y) (OpAddr am_x)
+
+ | otherwise
+ = c_y `snocOL`
+ MOV L (OpReg r_y) (OpReg tmp) `appOL`
+ c_x `snocOL`
+ CMP sz (OpReg tmp) (OpAddr am_x)
+ in
+ returnNat (CondCode False cond code__2)
+
+-- anything vs memory
+--
+condIntCode cond y (StInd pk x)
+ = getAmode x `thenNat` \ amode_x ->
+ getRegister y `thenNat` \ reg_y ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ c_x = amodeCode amode_x
+ am_x = amodeAddr amode_x
+ c_y = registerCode reg_y tmp
+ r_y = registerName reg_y tmp
+ sz = primRepToSize pk
+ -- same optimisation and nagging doubts as previous clause
+ code__2 | isNilOL c_x
+ = c_y `snocOL`
+ CMP sz (OpAddr am_x) (OpReg r_y)
+
+ | otherwise
+ = c_y `snocOL`
+ MOV L (OpReg r_y) (OpReg tmp) `appOL`
+ c_x `snocOL`
+ CMP sz (OpAddr am_x) (OpReg tmp)
+ in
+ returnNat (CondCode False cond code__2)
+
+-- anything vs anything
condIntCode cond x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
+ code__2 = code1 `snocOL`
+ MOV L (OpReg src1) (OpReg tmp1) `appOL`
+ code2 `snocOL`
+ CMP L (OpReg src2) (OpReg tmp1)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
-----------
condFltCode cond x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
+ `thenNat` \ tmp1 ->
getNewRegNCG (registerRep register2)
- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ `thenNat` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
pk1 = registerRep register1
code1 = registerCode register1 tmp1
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
+ code__2 | isAny register1
+ = code1 `appOL` -- result in tmp1
+ code2 `snocOL`
+ GCMP (primRepToSize pk1) tmp1 src2
+
+ | otherwise
+ = code1 `snocOL`
+ GMOV src1 tmp1 `appOL`
+ code2 `snocOL`
+ GCMP (primRepToSize pk1) tmp1 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 GE = GEU
fix_FP_cond GTT = GU
fix_FP_cond LTT = LU
- fix_FP_cond LE = LEU
- fix_FP_cond any = any
+ fix_FP_cond LE = LEU
+ fix_FP_cond any = any
in
- returnUs (CondCode True (fix_FP_cond cond) code__2)
+ returnNat (CondCode True (fix_FP_cond cond) code__2)
condIntCode cond x (StInt y)
| fits13Bits y
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
condIntCode cond x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code__2 = asmSeqThen [code1, code2] .
mkSeqInstr (SUB False True src1 (RIReg src2) g0)
in
- returnUs (CondCode False cond code__2)
+ returnNat (CondCode False cond code__2)
-----------
condFltCode cond x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
+ `thenNat` \ tmp1 ->
getNewRegNCG (registerRep register2)
- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ `thenNat` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
promote x = asmInstr (FxTOy F DF x tmp)
code__2 =
if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
+ asmSeqThen [code1 [], code2 []] .
mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
+ asmSeqThen [code1 (promote src1), code2 []] .
mkSeqInstr (FCMP True DF tmp src2)
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
+ asmSeqThen [code1 [], code2 (promote src2)] .
mkSeqInstr (FCMP True DF src1 tmp)
in
- returnUs (CondCode True cond code__2)
+ returnNat (CondCode True cond code__2)
#endif {- sparc_TARGET_ARCH -}
\end{code}
\begin{code}
assignIntCode, assignFltCode
- :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
+ :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
#if alpha_TARGET_ARCH
assignIntCode pk (StInd _ dst) src
- = getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ = getNewRegNCG IntRep `thenNat` \ tmp ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
let
- code1 = amodeCode amode asmVoid
+ code1 = amodeCode amode []
dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
+ code2 = registerCode register tmp []
src__2 = registerName register tmp
sz = primRepToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnUs code__2
+ returnNat code__2
assignIntCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
let
dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
else code
in
- returnUs code__2
+ returnNat code__2
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
--- looks dodgy to me
-assignIntCode pk dd@(StInd _ dst) src
- = getAmode dst `thenUs` \ amode ->
- get_op_RI src `thenUs` \ (codesrc, opsrc) ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2))
- in
- returnUs code__2
+-- Destination of an assignment can only be reg or mem.
+-- This is the mem case.
+assignIntCode pk (StInd _ dst) src
+ = getAmode dst `thenNat` \ amode ->
+ get_op_RI src `thenNat` \ (codesrc, opsrc) ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let
+ -- In general, if the address computation for dst may require
+ -- some insns preceding the addressing mode itself. So there's
+ -- no guarantee that the code for dst and the code for src won't
+ -- write the same register. This means either the address or
+ -- the value needs to be copied into a temporary. We detect the
+ -- common case where the amode has no code, and elide the copy.
+ codea = amodeCode amode
+ dst__a = amodeAddr amode
+
+ code | isNilOL codea
+ = codesrc `snocOL`
+ MOV (primRepToSize pk) opsrc (OpAddr dst__a)
+ | otherwise
+
+ = codea `snocOL`
+ LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
+ codesrc `snocOL`
+ MOV (primRepToSize pk) opsrc
+ (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
+ in
+ returnNat code
where
get_op_RI
:: StixTree
- -> UniqSM (InstrBlock,Operand) -- code, operator
+ -> NatM (InstrBlock,Operand) -- code, operator
get_op_RI op
| maybeToBool imm
- = returnUs (asmParThen [], OpImm imm_op)
+ = returnNat (nilOL, OpImm imm_op)
where
imm = maybeImm op
imm_op = case imm of Just x -> x
get_op_RI op
- = getRegister op `thenUs` \ register ->
+ = getRegister op `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
+ `thenNat` \ tmp ->
+ let code = registerCode register tmp
reg = registerName register tmp
in
- returnUs (code, OpReg reg)
+ returnNat (code, OpReg reg)
+-- Assign; dst is a reg, rhs is mem
assignIntCode pk dst (StInd pks src)
- = getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode src `thenUs` \ amode ->
- getRegister dst `thenUs` \ register ->
- let
- code1 = amodeCode amode asmVoid
- src__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
- dst__2 = registerName register tmp
- szs = primRepToSize pks
- code__2 = asmParThen [code1, code2] .
- case szs of
- L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2))
- B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2))
- in
- returnUs code__2
-
-assignIntCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getAmode src `thenNat` \ amode ->
+ getRegister dst `thenNat` \ reg_dst ->
let
- dst__2 = registerName register1 tmp
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 && dst__2 /= src__2
- then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
- else code
+ c_addr = amodeCode amode
+ am_addr = amodeAddr amode
+
+ c_dst = registerCode reg_dst tmp -- should be empty
+ r_dst = registerName reg_dst tmp
+ szs = primRepToSize pks
+ opc = case szs of L -> MOV L ; B -> MOVZxL B
+
+ code | isNilOL c_dst
+ = c_addr `snocOL`
+ opc (OpAddr am_addr) (OpReg r_dst)
+ | otherwise
+ = pprPanic "assignIntCode(x86): bad dst(2)" empty
in
- returnUs code__2
+ returnNat code
+
+-- dst is a reg, but src could be anything
+assignIntCode pk dst src
+ = getRegister dst `thenNat` \ registerd ->
+ getRegister src `thenNat` \ registers ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ r_dst = registerName registerd tmp
+ c_dst = registerCode registerd tmp -- should be empty
+ r_src = registerName registers r_dst
+ c_src = registerCode registers r_dst
+
+ code | isNilOL c_dst
+ = c_src `snocOL`
+ MOV L (OpReg r_src) (OpReg r_dst)
+ | otherwise
+ = pprPanic "assignIntCode(x86): bad dst(3)" empty
+ in
+ returnNat code
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
assignIntCode pk (StInd _ dst) src
- = getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ = getNewRegNCG IntRep `thenNat` \ tmp ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
let
- code1 = amodeCode amode asmVoid
+ code1 = amodeCode amode []
dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
+ code2 = registerCode register tmp []
src__2 = registerName register tmp
sz = primRepToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnUs code__2
+ returnNat code__2
assignIntCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
let
dst__2 = registerName register1 g0
code = registerCode register2 dst__2
then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
else code
in
- returnUs code__2
+ returnNat code__2
#endif {- sparc_TARGET_ARCH -}
\end{code}
#if alpha_TARGET_ARCH
assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ = getNewRegNCG pk `thenNat` \ tmp ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
let
- code1 = amodeCode amode asmVoid
+ code1 = amodeCode amode []
dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
+ code2 = registerCode register tmp []
src__2 = registerName register tmp
sz = primRepToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnUs code__2
+ returnNat code__2
assignFltCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
let
dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
then code . mkSeqInstr (FMOV src__2 dst__2)
else code
in
- returnUs code__2
+ returnNat code__2
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
- = getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode src `thenUs` \ amodesrc ->
- getAmode dst `thenUs` \ amodedst ->
- let
- codesrc1 = amodeCode amodesrc asmVoid
- addrsrc1 = amodeAddr amodesrc
- codedst1 = amodeCode amodedst asmVoid
- addrdst1 = amodeAddr amodedst
- addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
- addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
-
- code__2 = asmParThen [codesrc1, codedst1] .
- mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst1)]
- ++
- if pk == DoubleRep
- then [MOV L (OpAddr addrsrc2) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst2)]
- else [])
- in
- returnUs code__2
-
-assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+-- dst is memory
+assignFltCode pk (StInd pk_dst addr) src
+ | pk /= pk_dst
+ = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
+ | otherwise
+ = getRegister src `thenNat` \ reg_src ->
+ getRegister addr `thenNat` \ reg_addr ->
+ getNewRegNCG pk `thenNat` \ tmp_src ->
+ getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
+ let r_src = registerName reg_src tmp_src
+ c_src = registerCode reg_src tmp_src
+ r_addr = registerName reg_addr tmp_addr
+ c_addr = registerCode reg_addr tmp_addr
+ sz = primRepToSize pk
+
+ code = c_src `appOL`
+ -- no need to preserve r_src across the addr computation,
+ -- since r_src must be a float reg
+ -- whilst r_addr is an int reg
+ c_addr `snocOL`
+ GST sz r_src
+ (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
+ in
+ returnNat code
+
+-- dst must be a (FP) register
+assignFltCode pk dst src
+ = getRegister dst `thenNat` \ reg_dst ->
+ getRegister src `thenNat` \ reg_src ->
+ getNewRegNCG pk `thenNat` \ tmp ->
let
- sz = primRepToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode asmVoid
- code2 = registerCode register tmp asmVoid
+ r_dst = registerName reg_dst tmp
+ c_dst = registerCode reg_dst tmp -- should be empty
- src__2 = registerName register tmp
+ r_src = registerName reg_src r_dst
+ c_src = registerCode reg_src r_dst
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (GST sz src__2 dst__2)
+ code | isNilOL c_dst
+ = if isFixed reg_src
+ then c_src `snocOL` GMOV r_src r_dst
+ else c_src
+ | otherwise
+ = pprPanic "assignFltCode(x86): lhs is not mem or reg"
+ empty
in
- returnUs code__2
+ returnNat code
-assignFltCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
- getNewRegNCG pk `thenUs` \ tmp ->
- let
- -- 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 = if isFixed register2
- then code . mkSeqInstr (GMOV src__2 dst__2)
- else code
- in
- returnUs code__2
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenUs` \ tmp1 ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ = getNewRegNCG pk `thenNat` \ tmp1 ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
let
sz = primRepToSize pk
dst__2 = amodeAddr amode
- code1 = amodeCode amode asmVoid
- code2 = registerCode register tmp1 asmVoid
+ code1 = amodeCode amode []
+ code2 = registerCode register tmp1 []
src__2 = registerName register tmp1
pk__2 = registerRep register
sz__2 = primRepToSize pk__2
- code__2 = asmParThen [code1, code2] .
+ code__2 = asmSeqThen [code1, code2] ++
if pk == pk__2 then
mkSeqInstr (ST sz src__2 dst__2)
else
mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
in
- returnUs code__2
+ returnNat code__2
assignFltCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
let
pk__2 = registerRep register2
sz__2 = primRepToSize pk__2
in
- getNewRegNCG pk__2 `thenUs` \ tmp ->
+ getNewRegNCG pk__2 `thenNat` \ tmp ->
let
sz = primRepToSize pk
dst__2 = registerName register1 g0 -- must be Fixed
else
code
in
- returnUs code__2
+ returnNat code__2
#endif {- sparc_TARGET_ARCH -}
\end{code}
register allocator.
\begin{code}
-genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
+genJump :: StixTree{-the branch target-} -> NatM InstrBlock
#if alpha_TARGET_ARCH
target = ImmCLbl lbl
genJump tree
- = getRegister tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let
dst = registerName register pv
code = registerCode register pv
if isFixed register then
returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
else
- returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
+ returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-{-
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
- | otherwise = returnInstrs [JMP (OpImm target)]
- where
- target = ImmCLbl lbl
--}
-
genJump (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
- returnSeq code [JMP (OpAddr target)]
+ returnNat (code `snocOL` JMP (OpAddr target))
genJump tree
| maybeToBool imm
- = returnInstr (JMP (OpImm target))
+ = returnNat (unitOL (JMP (OpImm target)))
| otherwise
- = getRegister tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (OpReg target)]
+ returnNat (code `snocOL` JMP (OpReg target))
where
imm = maybeImm tree
target = case imm of Just x -> x
target = ImmCLbl lbl
genJump tree
- = getRegister tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
genCondJump
:: CLabel -- the branch target
-> StixTree -- the condition on which to branch
- -> UniqSM InstrBlock
+ -> NatM InstrBlock
#if alpha_TARGET_ARCH
genCondJump lbl (StPrim op [x, StInt 0])
- = getRegister x `thenUs` \ register ->
+ = getRegister x `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
code = registerCode register tmp
value = registerName register tmp
cmpOp AddrLeOp = EQQ
genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenUs` \ register ->
+ = getRegister x `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
code = registerCode register tmp
value = registerName register tmp
pk = registerRep register
target = ImmCLbl lbl
in
- returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
+ returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
where
cmpOp FloatGtOp = GTT
cmpOp FloatGeOp = GE
genCondJump lbl (StPrim op [x, y])
| fltCmpOp op
- = trivialFCode pr instr x y `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ = trivialFCode pr instr x y `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
code = registerCode register tmp
result = registerName register tmp
target = ImmCLbl lbl
in
- returnUs (code . mkSeqInstr (BF cond result target))
+ returnNat (code . mkSeqInstr (BF cond result target))
where
pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
DoubleLeOp -> (FCMP TF LE, NE)
genCondJump lbl (StPrim op [x, y])
- = trivialCode instr x y `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = trivialCode instr x y `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
result = registerName register tmp
target = ImmCLbl lbl
in
- returnUs (code . mkSeqInstr (BI cond result target))
+ returnNat (code . mkSeqInstr (BI cond result target))
where
(instr, cond) = case op of
CharGtOp -> (CMP LE, EQQ)
#if i386_TARGET_ARCH
genCondJump lbl bool
- = getCondCode bool `thenUs` \ condition ->
+ = getCondCode bool `thenNat` \ condition ->
let
code = condCode condition
cond = condName condition
target = ImmCLbl lbl
in
- returnSeq code [JXX cond lbl]
+ returnNat (code `snocOL` JXX cond lbl)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
genCondJump lbl bool
- = getCondCode bool `thenUs` \ condition ->
+ = getCondCode bool `thenNat` \ condition ->
let
code = condCode condition
cond = condName condition
-> CallConv
-> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> UniqSM InstrBlock
+ -> NatM InstrBlock
#if alpha_TARGET_ARCH
genCCall fn cconv kind args
- = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenUs` \ ((unused,_), argCode) ->
+ = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+ `thenNat` \ ((unused,_), argCode) ->
let
nRegs = length allArgRegs - length unused
- code = asmParThen (map ($ asmVoid) argCode)
+ code = asmSeqThen (map ($ []) argCode)
in
returnSeq code [
LDA pv (AddrImm (ImmLab (ptext fn))),
registers to be assigned for this call and the next stack
offset to use for overflowing arguments. This way,
@get_Arg@ can be applied to all of a call's arguments using
- @mapAccumLUs@.
+ @mapAccumLNat@.
-}
get_arg
:: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
-> StixTree -- Current argument
- -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
+ -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-- We have to use up all of our argument registers first...
get_arg ((iDst,fDst):dsts, offset) arg
- = getRegister arg `thenUs` \ register ->
+ = getRegister arg `thenNat` \ register ->
let
reg = if isFloatingRep pk then fDst else iDst
code = registerCode register reg
src = registerName register reg
pk = registerRep register
in
- returnUs (
+ returnNat (
if isFloatingRep pk then
((dsts, offset), if isFixed register then
code . mkSeqInstr (FMOV src fDst)
-- stack...
get_arg ([], offset) arg
- = getRegister arg `thenUs` \ register ->
+ = getRegister arg `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
pk = registerRep register
sz = primRepToSize pk
in
- returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
genCCall fn cconv 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")))))]
+ = let call = toOL [
+ MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ CALL (ImmLit (ptext (if underscorePrefix
+ then (SLIT ("_PerformGC_wrapper"))
+ else (SLIT ("PerformGC_wrapper")))))
+ ]
in
- returnInstrs call
+ returnNat call
genCCall fn cconv kind args
- = get_call_args args `thenUs` \ (tot_arg_size, argCode) ->
- let
- code2 = asmParThen (map ($ asmVoid) argCode)
- call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
- CALL fn__2 ,
- ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
+ = mapNat get_call_arg
+ (reverse args) `thenNat` \ sizes_n_codes ->
+ getDeltaNat `thenNat` \ delta ->
+ let (sizes, codes) = unzip sizes_n_codes
+ tot_arg_size = sum sizes
+ code2 = concatOL codes
+ call = toOL [
+ CALL fn__2,
+ ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
+ DELTA (delta + tot_arg_size)
]
in
- returnSeq code2 call
+ setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
+ returnNat (code2 `appOL` call)
where
-- function names that begin with '.' are assumed to be special
arg_size _ = 4
------------
- -- do get_call_arg on each arg, threading the total arg size along
- -- process the args right-to-left
- get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock])
- get_call_args args
- = f 0 args
- where
- f curr_sz []
- = returnUs (curr_sz, [])
- f curr_sz (arg:args)
- = f curr_sz args `thenUs` \ (new_sz, iblocks) ->
- get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) ->
- returnUs (new_sz2, iblock:iblocks)
-
-
- ------------
get_call_arg :: StixTree{-current argument-}
- -> Int{-running total of arg sizes seen so far-}
- -> UniqSM (Int, InstrBlock) -- updated tot argsz, code
-
- get_call_arg arg old_sz
- = get_op arg `thenUs` \ (code, reg, sz) ->
- let new_sz = old_sz + arg_size sz
- in if (case sz of DF -> True; F -> True; _ -> False)
- then returnUs (new_sz,
- code .
- mkSeqInstr (GST DF reg
- (AddrBaseIndex (Just esp)
- Nothing (ImmInt (- new_sz))))
- )
- else returnUs (new_sz,
- code .
- mkSeqInstr (MOV L (OpReg reg)
- (OpAddr
- (AddrBaseIndex (Just esp)
- Nothing (ImmInt (- new_sz)))))
- )
+ -> NatM (Int, InstrBlock) -- argsz, code
+
+ get_call_arg arg
+ = get_op arg `thenNat` \ (code, reg, sz) ->
+ getDeltaNat `thenNat` \ delta ->
+ arg_size sz `bind` \ size ->
+ setDeltaNat (delta-size) `thenNat` \ _ ->
+ if (case sz of DF -> True; F -> True; _ -> False)
+ then returnNat (size,
+ code `appOL`
+ toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
+ DELTA (delta-size),
+ GST DF reg (AddrBaseIndex (Just esp)
+ Nothing
+ (ImmInt 0))]
+ )
+ else returnNat (size,
+ code `snocOL`
+ PUSH L (OpReg reg) `snocOL`
+ DELTA (delta-size)
+ )
------------
get_op
:: StixTree
- -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size
+ -> NatM (InstrBlock, Reg, Size) -- code, reg, size
get_op op
- = getRegister op `thenUs` \ register ->
+ = getRegister op `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
code = registerCode register tmp
reg = registerName register tmp
pk = registerRep register
sz = primRepToSize pk
in
- returnUs (code, reg, sz)
+ returnNat (code, reg, sz)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
genCCall fn cconv kind args
- = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenUs` \ ((unused,_), argCode) ->
+ = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+ `thenNat` \ ((unused,_), argCode) ->
let
nRegs = length allArgRegs - length unused
call = CALL fn__2 nRegs False
- code = asmParThen (map ($ asmVoid) argCode)
+ code = asmSeqThen (map ($ []) argCode)
in
returnSeq code [call, NOP]
where
get_arg
:: ([Reg],Int) -- Argument registers and stack offset (accumulator)
-> StixTree -- Current argument
- -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
+ -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
-- We have to use up all of our argument registers first...
get_arg (dst:dsts, offset) arg
- = getRegister arg `thenUs` \ register ->
+ = getRegister arg `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
reg = if isFloatingRep pk then tmp else dst
code = registerCode register reg
src = registerName register reg
pk = registerRep register
in
- returnUs (case pk of
+ returnNat (case pk of
DoubleRep ->
case dsts of
[] -> (([], offset + 1), code . mkSeqInstrs [
-- stack...
get_arg ([], offset) arg
- = getRegister arg `thenUs` \ register ->
+ = getRegister arg `thenNat` \ register ->
getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
+ `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
sz = primRepToSize pk
words = if pk == DoubleRep then 2 else 1
in
- returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
#endif {- sparc_TARGET_ARCH -}
\end{code}
register allocator.
\begin{code}
-condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
+condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
#if alpha_TARGET_ARCH
condIntReg = panic "MachCode.condIntReg (not on Alpha)"
#if i386_TARGET_ARCH
condIntReg cond x y
- = condIntCode cond x y `thenUs` \ condition ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- --getRegister dst `thenUs` \ register ->
+ = condIntCode cond x y `thenNat` \ condition ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
- --code2 = registerCode register tmp asmVoid
- --dst__2 = registerName register tmp
code = condCode condition
cond = condName condition
- -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
SETCC cond (OpReg tmp),
AND L (OpImm (ImmInt 1)) (OpReg tmp),
MOV L (OpReg tmp) (OpReg dst)]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condFltReg cond x y
- = getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condFltCode cond x y `thenUs` \ condition ->
+ = getNatLabelNCG `thenNat` \ lbl1 ->
+ getNatLabelNCG `thenNat` \ lbl2 ->
+ condFltCode cond x y `thenNat` \ condition ->
let
code = condCode condition
cond = condName condition
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
JXX cond lbl1,
MOV L (OpImm (ImmInt 0)) (OpReg dst),
JXX ALWAYS lbl2,
MOV L (OpImm (ImmInt 1)) (OpReg dst),
LABEL lbl2]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
condIntReg EQQ x (StInt 0)
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
SUB False True g0 (RIReg src) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condIntReg EQQ x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+ code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condIntReg NE x (StInt 0)
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
SUB False True g0 (RIReg src) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condIntReg NE x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+ code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condIntReg cond x y
- = getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condIntCode cond x y `thenUs` \ condition ->
+ = getNatLabelNCG `thenNat` \ lbl1 ->
+ getNatLabelNCG `thenNat` \ lbl2 ->
+ condIntCode cond x y `thenNat` \ condition ->
let
code = condCode condition
cond = condName condition
OR False g0 (RIImm (ImmInt 1)) dst,
LABEL lbl2]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
condFltReg cond x y
- = getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condFltCode cond x y `thenUs` \ condition ->
+ = getNatLabelNCG `thenNat` \ lbl1 ->
+ getNatLabelNCG `thenNat` \ lbl2 ->
+ condFltCode cond x y `thenNat` \ condition ->
let
code = condCode condition
cond = condName condition
OR False g0 (RIImm (ImmInt 1)) dst,
LABEL lbl2]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- sparc_TARGET_ARCH -}
\end{code}
,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
,)))
-> StixTree -> StixTree -- the two arguments
- -> UniqSM Register
+ -> NatM Register
trivialFCode
:: PrimRep
,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
-> StixTree -> StixTree -- the two arguments
- -> UniqSM Register
+ -> NatM Register
trivialUCode
:: IF_ARCH_alpha((RI -> Reg -> Instr)
,IF_ARCH_sparc((RI -> Reg -> Instr)
,)))
-> StixTree -- the one argument
- -> UniqSM Register
+ -> NatM Register
trivialUFCode
:: PrimRep
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
-> StixTree -- the one argument
- -> UniqSM Register
+ -> NatM Register
#if alpha_TARGET_ARCH
trivialCode instr x (StInt y)
| fits8Bits y
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
trivialCode instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
+ code__2 dst = asmSeqThen [code1, code2] .
mkSeqInstr (instr src1 (RIReg src2) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
------------
trivialUCode instr x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
------------
trivialFCode _ instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenNat` \ 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] .
+ code__2 dst = asmSeqThen [code1 [], code2 []] .
mkSeqInstr (instr src1 src2 dst)
in
- returnUs (Any DoubleRep code__2)
+ returnNat (Any DoubleRep code__2)
trivialUFCode _ instr x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr src dst)
in
- returnUs (Any DoubleRep code__2)
+ returnNat (Any DoubleRep code__2)
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
The Rules of the Game are:
* You cannot assume anything about the destination register dst;
- it may be anything, includind a fixed reg.
+ it may be anything, including a fixed reg.
* You may compute an operand into a fixed reg, but you may not
subsequently change the contents of that fixed reg. If you
\begin{code}
-infixr 3 `bind`
-x `bind` f = f x
-
trivialCode instr maybe_revinstr a b
| is_imm_b
- = getRegister a `thenUs` \ rega ->
+ = getRegister a `thenNat` \ rega ->
let mkcode dst
- = if isFloat rega
+ = if isAny rega
then registerCode rega dst `bind` \ code_a ->
- code_a .
- mkSeqInstr (instr (OpImm imm_b) (OpReg dst))
+ code_a `snocOL`
+ instr (OpImm imm_b) (OpReg dst)
else registerCodeF rega `bind` \ code_a ->
registerNameF rega `bind` \ r_a ->
- code_a .
- mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) .
- mkSeqInstr (instr (OpImm imm_b) (OpReg dst))
+ code_a `snocOL`
+ MOV L (OpReg r_a) (OpReg dst) `snocOL`
+ instr (OpImm imm_b) (OpReg dst)
in
- returnUs (Any IntRep mkcode)
+ returnNat (Any IntRep mkcode)
| is_imm_a
- = getRegister b `thenUs` \ regb ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister b `thenNat` \ regb ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let revinstr_avail = maybeToBool maybe_revinstr
revinstr = case maybe_revinstr of Just ri -> ri
mkcode dst
| revinstr_avail
- = if isFloat regb
+ = if isAny regb
then registerCode regb dst `bind` \ code_b ->
- code_b .
- mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst))
+ code_b `snocOL`
+ revinstr (OpImm imm_a) (OpReg dst)
else registerCodeF regb `bind` \ code_b ->
registerNameF regb `bind` \ r_b ->
- code_b .
- mkSeqInstr (MOV L (OpReg r_b) (OpReg dst)) .
- mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst))
+ code_b `snocOL`
+ MOV L (OpReg r_b) (OpReg dst) `snocOL`
+ revinstr (OpImm imm_a) (OpReg dst)
| otherwise
- = if isFloat regb
+ = if isAny regb
then registerCode regb tmp `bind` \ code_b ->
- code_b .
- mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) .
- mkSeqInstr (instr (OpReg tmp) (OpReg dst))
+ code_b `snocOL`
+ MOV L (OpImm imm_a) (OpReg dst) `snocOL`
+ instr (OpReg tmp) (OpReg dst)
else registerCodeF regb `bind` \ code_b ->
registerNameF regb `bind` \ r_b ->
- code_b .
- mkSeqInstr (MOV L (OpReg r_b) (OpReg tmp)) .
- mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) .
- mkSeqInstr (instr (OpReg tmp) (OpReg dst))
+ code_b `snocOL`
+ MOV L (OpReg r_b) (OpReg tmp) `snocOL`
+ MOV L (OpImm imm_a) (OpReg dst) `snocOL`
+ instr (OpReg tmp) (OpReg dst)
in
- returnUs (Any IntRep mkcode)
+ returnNat (Any IntRep mkcode)
| otherwise
- = getRegister a `thenUs` \ rega ->
- getRegister b `thenUs` \ regb ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister a `thenNat` \ rega ->
+ getRegister b `thenNat` \ regb ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let mkcode dst
- = case (isFloat rega, isFloat regb) of
+ = case (isAny rega, isAny regb) of
(True, True)
-> registerCode regb tmp `bind` \ code_b ->
registerCode rega dst `bind` \ code_a ->
- code_b .
- code_a .
- mkSeqInstr (instr (OpReg tmp) (OpReg dst))
+ code_b `appOL`
+ code_a `snocOL`
+ instr (OpReg tmp) (OpReg dst)
(True, False)
-> registerCode rega tmp `bind` \ code_a ->
registerCodeF regb `bind` \ code_b ->
registerNameF regb `bind` \ r_b ->
- code_a .
- code_b .
- mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) .
- mkSeqInstr (MOV L (OpReg tmp) (OpReg dst))
+ code_a `appOL`
+ code_b `snocOL`
+ instr (OpReg r_b) (OpReg tmp) `snocOL`
+ MOV L (OpReg tmp) (OpReg dst)
(False, True)
-> registerCode regb tmp `bind` \ code_b ->
registerCodeF rega `bind` \ code_a ->
registerNameF rega `bind` \ r_a ->
- code_b .
- code_a .
- mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) .
- mkSeqInstr (instr (OpReg tmp) (OpReg dst))
+ code_b `appOL`
+ code_a `snocOL`
+ MOV L (OpReg r_a) (OpReg dst) `snocOL`
+ instr (OpReg tmp) (OpReg dst)
(False, False)
-> registerCodeF rega `bind` \ code_a ->
registerNameF rega `bind` \ r_a ->
registerCodeF regb `bind` \ code_b ->
registerNameF regb `bind` \ r_b ->
- code_a .
- mkSeqInstr (MOV L (OpReg r_a) (OpReg tmp)) .
- code_b .
- mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) .
- mkSeqInstr (MOV L (OpReg tmp) (OpReg dst))
+ code_a `snocOL`
+ MOV L (OpReg r_a) (OpReg tmp) `appOL`
+ code_b `snocOL`
+ instr (OpReg r_b) (OpReg tmp) `snocOL`
+ MOV L (OpReg tmp) (OpReg dst)
in
- returnUs (Any IntRep mkcode)
+ returnNat (Any IntRep mkcode)
where
maybe_imm_a = maybeImm a
-----------
trivialUCode instr x
- = getRegister x `thenUs` \ register ->
+ = getRegister x `thenNat` \ register ->
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),
- instr (OpReg dst)]
- else mkSeqInstr (instr (OpReg src))
+ in code `appOL`
+ if isFixed register && dst /= src
+ then toOL [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else unitOL (instr (OpReg src))
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
-----------
trivialFCode pk instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenNat` \ 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)
+ code__2 dst
+ -- treat the common case specially: both operands in
+ -- non-fixed regs.
+ | isAny register1 && isAny register2
+ = code1 `appOL`
+ code2 `snocOL`
+ instr (primRepToSize pk) src1 src2 dst
+
+ -- be paranoid (and inefficient)
+ | otherwise
+ = code1 `snocOL` GMOV src1 tmp1 `appOL`
+ code2 `snocOL`
+ instr (primRepToSize pk) tmp1 src2 dst
in
- returnUs (Any DoubleRep code__2)
+ returnNat (Any DoubleRep code__2)
-------------
trivialUFCode pk instr x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG pk `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG pk `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
+ code__2 dst = code `snocOL` instr src dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
trivialCode instr x (StInt y)
| fits13Bits y
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
trivialCode instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
+ code1 = registerCode register1 tmp1 []
src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 []
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
+ code__2 dst = asmSeqThen [code1, code2] .
mkSeqInstr (instr src1 (RIReg src2) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
------------
trivialFCode pk instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
+ `thenNat` \ tmp1 ->
getNewRegNCG (registerRep register2)
- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ `thenNat` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
promote x = asmInstr (FxTOy F DF x tmp)
code__2 dst =
if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
+ asmSeqThen [code1 [], code2 []] .
mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
+ asmSeqThen [code1 (promote src1), code2 []] .
mkSeqInstr (instr DF tmp src2 dst)
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
+ asmSeqThen [code1 [], code2 (promote src2)] .
mkSeqInstr (instr DF src1 tmp dst)
in
- returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
+ returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
------------
trivialUCode instr x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
-------------
trivialUFCode pk instr x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG pk `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG pk `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr src dst)
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
#endif {- sparc_TARGET_ARCH -}
\end{code}
between the integer and the floating point register sets.
\begin{code}
-coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
-coerceFltCode :: StixTree -> UniqSM Register
+coerceIntCode :: PrimRep -> StixTree -> NatM Register
+coerceFltCode :: StixTree -> NatM Register
-coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
-coerceFP2Int :: StixTree -> UniqSM Register
+coerceInt2FP :: PrimRep -> StixTree -> NatM Register
+coerceFP2Int :: StixTree -> NatM Register
coerceIntCode pk x
- = getRegister x `thenUs` \ register ->
- returnUs (
+ = getRegister x `thenNat` \ register ->
+ returnNat (
case register of
Fixed _ reg code -> Fixed pk reg code
Any _ code -> Any pk code
-------------
coerceFltCode x
- = getRegister x `thenUs` \ register ->
- returnUs (
+ = getRegister x `thenNat` \ register ->
+ returnNat (
case register of
Fixed _ reg code -> Fixed DoubleRep reg code
Any _ code -> Any DoubleRep code
#if alpha_TARGET_ARCH
coerceInt2FP _ x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
let
code = registerCode register reg
src = registerName register reg
LD TF dst (spRel 0),
CVTxy Q TF dst dst]
in
- returnUs (Any DoubleRep code__2)
+ returnNat (Any DoubleRep code__2)
-------------
coerceFP2Int x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
ST TF tmp (spRel 0),
LD Q dst (spRel 0)]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
coerceInt2FP pk x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
let
code = registerCode register reg
src = registerName register reg
opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
- code__2 dst = code .
- mkSeqInstr (opc src dst)
+ code__2 dst = code `snocOL` opc src dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
------------
coerceFP2Int x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
pk = registerRep register
opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
- code__2 dst = code .
- mkSeqInstr (opc src dst)
+ code__2 dst = code `snocOL` opc src dst
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
coerceInt2FP pk x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
let
code = registerCode register reg
src = registerName register reg
LD W (spRel (-2)) dst,
FxTOy W (primRepToSize pk) dst dst]
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
------------
coerceFP2Int x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getNewRegNCG FloatRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
+ getNewRegNCG FloatRep `thenNat` \ tmp ->
let
code = registerCode register reg
src = registerName register reg
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- sparc_TARGET_ARCH -}
\end{code}
in one step if the original object is in memory.
\begin{code}
-chrCode :: StixTree -> UniqSM Register
+chrCode :: StixTree -> NatM Register
#if alpha_TARGET_ARCH
chrCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
chrCode x
- = getRegister x `thenUs` \ register ->
+ = getRegister x `thenNat` \ register ->
let
code__2 dst = let
code = registerCode register dst
src = registerName register dst
- in code .
- if isFixed register && src /= dst
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- AND L (OpImm (ImmInt 255)) (OpReg dst)]
- else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+ in code `appOL`
+ if isFixed register && src /= dst
+ then toOL [MOV L (OpReg src) (OpReg dst),
+ AND L (OpImm (ImmInt 255)) (OpReg dst)]
+ else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
chrCode (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
src = amodeAddr amode
LD (primRepToSize pk) src dst,
AND False dst (RIImm (ImmInt 255)) dst]
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
chrCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
#endif {- sparc_TARGET_ARCH -}
\end{code}
projects / ghc-hetmet.git / commitdiff