%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}
structure should not be too overwhelming.
\begin{code}
+module MachCode ( stmtsToInstrs, InstrBlock ) where
+
#include "HsVersions.h"
#include "nativeGen/NCG.h"
-module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
-
-import Ubiq{-uitious-}
-
+import Unique ( Unique )
import MachMisc -- may differ per-platform
import MachRegs
-
-import AbsCSyn ( MagicId )
+import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
+ snocOL, consOL, concatOL )
+import MachOp ( MachOp(..), pprMachOp )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( isAsmTemp )
-import Maybes ( maybeToBool, expectJust )
-import OrdList -- quite a bit of it
-import Pretty ( prettyToUn, ppRational )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
-import Stix ( getUniqLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..)
- )
-import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
- mapAccumLUs, UniqSM(..)
+import PprAbsC ( pprMagicId )
+import ForeignCall ( CCallConv(..) )
+import CLabel ( CLabel, labelDynamic )
+#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
+import CLabel ( isAsmTemp )
+#endif
+import Maybes ( maybeToBool )
+import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
+ getPrimRepArrayElemSize )
+import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
+ StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
+ DestInfo, hasDestInfo,
+ pprStixExpr, repOfStixExpr,
+ liftStrings,
+ NatM, thenNat, returnNat, mapNat,
+ mapAndUnzipNat, mapAccumLNat,
+ getDeltaNat, setDeltaNat, getUniqueNat,
+ ncgPrimopMoan,
+ ncg_target_is_32bit
)
-import Unpretty ( uppPStr )
-import Util ( panic, assertPanic )
+import Pretty
+import Outputable ( panic, pprPanic, showSDoc )
+import qualified Outputable
+import CmdLineOpts ( opt_Static )
+import Stix ( pprStixStmt )
+
+-- DEBUGGING ONLY
+import IOExts ( trace )
+import Outputable ( assertPanic )
+import FastString
+
+infixr 3 `bind`
\end{code}
-Code extractor for an entire stix tree---stix statement level.
+@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}
-stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
+type InstrBlock = OrdList Instr
+
+x `bind` f = f x
-stmt2Instrs stmt = case stmt of
- StComment s -> returnInstr (COMMENT s)
- StSegment seg -> returnInstr (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)
+isLeft (Left _) = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
+\end{code}
- StJump arg -> genJump arg
- StCondJump lab arg -> genCondJump lab arg
- StCall fn VoidRep args -> genCCall fn VoidRep args
+Code extractor for an entire stix tree---stix statement level.
- StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk dst src
- | otherwise -> assignIntCode pk dst src
+\begin{code}
+stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
+stmtsToInstrs stmts
+ = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
+ returnNat (concatOL instrss)
+
+
+stmtToInstrs :: StixStmt -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
+ StComment s -> returnNat (unitOL (COMMENT s))
+ StSegment seg -> returnNat (unitOL (SEGMENT seg))
+
+ 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 dsts arg -> genJump dsts (derefDLL arg)
+ StCondJump lab arg -> genCondJump lab (derefDLL arg)
+
+ -- A call returning void, ie one done for its side-effects. Note
+ -- that this is the only StVoidable we handle.
+ StVoidable (StCall fn cconv VoidRep args)
+ -> genCCall fn cconv VoidRep (map derefDLL args)
+
+ StAssignMem pk addr src
+ | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
+ | ncg_target_is_32bit
+ && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
+ | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
+ StAssignReg pk reg src
+ | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
+ | ncg_target_is_32bit
+ && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
+ | otherwise -> assignReg_IntCode pk reg (derefDLL src)
StFallThrough lbl
-- 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))
- (foldr1 (.) codes xs))
+ -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
+ returnNat (DATA (primRepToSize kind) imms
+ `consOL` concatOL codes)
where
- getData :: StixTree -> UniqSM (InstrBlock, Imm)
-
- getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, dblImmLit d)
- getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StCLbl l) = returnUs (id, ImmCLbl l)
- getData (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- returnUs (mkSeqInstrs [LABEL lbl,
- ASCII True (_UNPK_ s)],
- ImmCLbl lbl)
+ getData :: StixExpr -> NatM (InstrBlock, Imm)
+ getData (StInt i) = returnNat (nilOL, ImmInteger i)
+ getData (StDouble d) = returnNat (nilOL, ImmDouble d)
+ getData (StFloat d) = returnNat (nilOL, ImmFloat d)
+ getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
+ getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
+ -- the linker can handle simple arithmetic...
+ getData (StIndex rep (StCLbl lbl) (StInt off)) =
+ returnNat (nilOL,
+ ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
+
+ -- Top-level lifted-out string. The segment will already have been set
+ -- (see Stix.liftStrings).
+ StDataString str
+ -> returnNat (unitOL (ASCII True (unpackFS str)))
+
+#ifdef DEBUG
+ other -> pprPanic "stmtToInstrs" (pprStixStmt other)
+#endif
+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixExpr -> StixExpr
+derefDLL tree
+ | opt_Static -- short out the entire deal if not doing DLLs
+ = tree
+ | otherwise
+ = qq tree
+ where
+ qq t
+ = case t of
+ StCLbl lbl -> if labelDynamic lbl
+ then StInd PtrRep (StCLbl lbl)
+ else t
+ -- all the rest are boring
+ StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+ StMachOp mop args -> StMachOp mop (map qq args)
+ StInd pk addr -> StInd pk (qq addr)
+ StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
+ StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
+ StInt _ -> t
+ StFloat _ -> t
+ StDouble _ -> t
+ StString _ -> t
+ StReg _ -> t
+ _ -> pprPanic "derefDLL: unhandled case"
+ (pprStixExpr t)
\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 :: StixExpr -> StixExpr
mangleIndexTree (StIndex pk base (StInt i))
- = StPrim IntAddOp [base, off]
+ = StMachOp MO_Nat_Add [base, off]
where
- off = StInt (i * sizeOf pk)
+ off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
mangleIndexTree (StIndex pk base off)
- = StPrim IntAddOp [base,
- case pk of
- CharRep -> off
- _ -> let
- s = shift pk
- in
- ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
- StPrim SllOp [off, StInt s]
+ = StMachOp MO_Nat_Add [
+ base,
+ let s = shift pk
+ in if s == 0 then off
+ else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
]
where
- shift DoubleRep = 3
- shift _ = IF_ARCH_alpha(3,2)
+ shift :: PrimRep -> Int
+ shift rep = case getPrimRepArrayElemSize rep of
+ 1 -> 0
+ 2 -> 1
+ 4 -> 2
+ 8 -> 3
+ other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
+ (Outputable.int other)
\end{code}
\begin{code}
-maybeImm :: StixTree -> Maybe Imm
-
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
-maybeImm (StCLbl l) = Just (ImmCLbl l)
+maybeImm :: StixExpr -> Maybe Imm
+maybeImm (StCLbl l)
+ = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off))
+ = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
maybeImm (StInt i)
- | i >= toInteger minInt && i <= toInteger maxInt
+ | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
= Just (ImmInt (fromInteger i))
| otherwise
= Just (ImmInteger i)
%************************************************************************
%* *
+\subsection{The @Register64@ type}
+%* *
+%************************************************************************
+
+Simple support for generating 64-bit code (ie, 64 bit values and 64
+bit assignments) on 32-bit platforms. Unlike the main code generator
+we merely shoot for generating working code as simply as possible, and
+pay little attention to code quality. Specifically, there is no
+attempt to deal cleverly with the fixed-vs-floating register
+distinction; all values are generated into (pairs of) floating
+registers, even if this would mean some redundant reg-reg moves as a
+result. Only one of the VRegUniques is returned, since it will be
+of the VRegUniqueLo form, and the upper-half VReg can be determined
+by applying getHiVRegFromLo to it.
+
+\begin{code}
+
+data ChildCode64 -- a.k.a "Register64"
+ = ChildCode64
+ InstrBlock -- code
+ VRegUnique -- unique for the lower 32-bit temporary
+ -- which contains the result; use getHiVRegFromLo to find
+ -- the other VRegUnique.
+ -- Rules of this simplified insn selection game are
+ -- therefore that the returned VRegUnique may be modified
+
+assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
+iselExpr64 :: StixExpr -> NatM ChildCode64
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
+ getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ let rlo = VirtualRegI vrlo
+ rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ -- Little-endian store
+ mov_lo = MOV L (OpReg rlo)
+ (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
+ mov_hi = MOV L (OpReg rhi)
+ (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
+ in
+ returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+ let
+ r_dst_lo = mkVReg u_dst IntRep
+ r_src_lo = VirtualRegI vr_src_lo
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
+ mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
+ in
+ returnNat (
+ vcode `snocOL` mov_lo `snocOL` mov_hi
+ )
+
+assignReg_I64Code lvalue valueTree
+ = pprPanic "assignReg_I64Code(i386): invalid lvalue"
+ (pprStixReg lvalue)
+
+
+
+iselExpr64 (StInd pk addrTree)
+ | is64BitRep pk
+ = getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ getNewRegNCG IntRep `thenNat` \ rlo ->
+ let rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
+ (OpReg rlo)
+ mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
+ (OpReg rhi)
+ in
+ returnNat (
+ ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
+ (getVRegUnique rlo)
+ )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+ | is64BitRep pk
+ = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_lo = mkVReg vu IntRep
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
+ mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
+ in
+ returnNat (
+ ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 (StCall fn cconv kind args)
+ | is64BitRep kind
+ = genCCall fn cconv kind args `thenNat` \ call ->
+ getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
+ mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
+ in
+ returnNat (
+ ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
+ (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
+
+#endif {- i386_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
+ getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ let rlo = VirtualRegI vrlo
+ rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ -- Big-endian store
+ mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
+ mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
+ in
+ returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
+
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+ let
+ r_dst_lo = mkVReg u_dst IntRep
+ r_src_lo = VirtualRegI vr_src_lo
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = mkMOV r_src_lo r_dst_lo
+ mov_hi = mkMOV r_src_hi r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ returnNat (
+ vcode `snocOL` mov_hi `snocOL` mov_lo
+ )
+assignReg_I64Code lvalue valueTree
+ = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
+ (pprStixReg lvalue)
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr
+-- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
+-- = panic "iselExpr64(???)"
+
+iselExpr64 (StInd pk addrTree)
+ | is64BitRep pk
+ = getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ getNewRegNCG IntRep `thenNat` \ rlo ->
+ let rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
+ mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
+ in
+ returnNat (
+ ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique rlo)
+ )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+ | is64BitRep pk
+ = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_lo = mkVReg vu IntRep
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = mkMOV r_src_lo r_dst_lo
+ mov_hi = mkMOV r_src_hi r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ returnNat (
+ ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 (StCall fn cconv kind args)
+ | is64BitRep kind
+ = genCCall fn cconv kind args `thenNat` \ call ->
+ getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ mov_lo = mkMOV o0 r_dst_lo
+ mov_hi = mkMOV o1 r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ returnNat (
+ ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
+
+#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\end{code}
+
+%************************************************************************
+%* *
\subsection{The @Register@ type}
%* *
%************************************************************************
registerCode (Fixed _ _ code) reg = code
registerCode (Any _ code) reg = code reg
+registerCodeF (Fixed _ _ code) = code
+registerCodeF (Any _ _) = panic "registerCodeF"
+
+registerCodeA (Any _ code) = code
+registerCodeA (Fixed _ _ _) = panic "registerCodeA"
+
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
-registerName (Any _ _) reg = reg
+registerName (Any _ _) reg = reg
+
+registerNameF (Fixed _ reg _) = reg
+registerNameF (Any _ _) = panic "registerNameF"
registerRep :: Register -> PrimRep
registerRep (Fixed pk _ _) = pk
registerRep (Any pk _) = pk
-isFixed :: Register -> Bool
+swizzleRegisterRep :: Register -> PrimRep -> Register
+swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
+swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
+
+{-# INLINE registerCode #-}
+{-# INLINE registerCodeF #-}
+{-# INLINE registerName #-}
+{-# INLINE registerNameF #-}
+{-# INLINE registerRep #-}
+{-# INLINE isFixed #-}
+{-# INLINE isAny #-}
+
+isFixed, isAny :: Register -> Bool
isFixed (Fixed _ _ _) = True
isFixed (Any _ _) = False
+
+isAny = not . isFixed
\end{code}
Generate code to get a subtree into a @Register@:
\begin{code}
-getRegister :: StixTree -> UniqSM Register
-getRegister (StReg (StixMagicId stgreg))
- = case (magicIdRegMaybe stgreg) of
- Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
- -- cannae be Nothing
+getRegisterReg :: StixReg -> NatM Register
+getRegister :: StixExpr -> NatM Register
+
+
+getRegisterReg (StixMagicId mid)
+ = case get_MagicId_reg_or_addr mid of
+ Left (RealReg rrno)
+ -> let pk = magicIdPrimRep mid
+ in returnNat (Fixed pk (RealReg rrno) nilOL)
+ Right baseRegAddr
+ -- By this stage, the only MagicIds remaining should be the
+ -- ones which map to a real machine register on this platform. Hence ...
+ -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
+
+getRegisterReg (StixTemp (StixVReg u pk))
+ = returnNat (Fixed pk (mkVReg u pk) nilOL)
+
+-------------
-getRegister (StReg (StixTemp u pk))
- = returnUs (Fixed pk (UnmappedReg u pk) id)
+-- Don't delete this -- it's very handy for debugging.
+--getRegister expr
+-- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
+-- = panic "getRegister(???)"
-getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+getRegister (StReg reg)
+ = getRegisterReg reg
-getRegister (StCall fn kind args)
- = genCCall fn kind args `thenUs` \ call ->
- returnUs (Fixed kind reg call)
+getRegister tree@(StIndex _ _ _)
+ = getRegister (mangleIndexTree tree)
+
+getRegister (StCall fn cconv kind args)
+ | not (ncg_target_is_32bit && is64BitRep kind)
+ = 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( st0, IF_ARCH_sparc( f0,)))
+ then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
getRegister (StString s)
- = getUniqLabelNCG `thenUs` \ lbl ->
+ = getNatLabelNCG `thenNat` \ lbl ->
let
imm_lbl = ImmCLbl lbl
- code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII True (_UNPK_ s),
- SEGMENT TextSegment,
-#if alpha_TARGET_ARCH
- LDA dst (AddrImm imm_lbl)
-#endif
-#if i386_TARGET_ARCH
- MOV L (OpImm imm_lbl) (OpReg dst)
-#endif
-#if sparc_TARGET_ARCH
- SETHI (HI imm_lbl) dst,
- OR False dst (RIImm (LO imm_lbl)) dst
-#endif
- ]
- in
- returnUs (Any PtrRep code)
-
-getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- imm_lbl = ImmCLbl lbl
-
- code dst = mkSeqInstrs [
- SEGMENT DataSegment,
+ code dst = toOL [
+ SEGMENT RoDataSegment,
LABEL lbl,
- ASCII False (init xs),
+ ASCII True (unpackFS s),
SEGMENT TextSegment,
#if alpha_TARGET_ARCH
LDA dst (AddrImm imm_lbl)
#endif
]
in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
+ returnNat (Any PtrRep code)
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- end of machine-"independent" bit; here we go on the rest...
#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,
- DATA TF [ImmLab (prettyToUn (ppRational d))],
+ DATA TF [ImmLab (rational d)],
SEGMENT TextSegment,
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
IntNegOp -> trivialUCode (NEG Q False) x
- IntAbsOp -> trivialUCode (ABS Q) x
NotOp -> trivialUCode NOT x
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn DoubleRep [x])
+ other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
where
fn = case other_op of
- FloatExpOp -> SLIT("exp")
- FloatLogOp -> SLIT("log")
- FloatSqrtOp -> SLIT("sqrt")
- FloatSinOp -> SLIT("sin")
- FloatCosOp -> SLIT("cos")
- FloatTanOp -> SLIT("tan")
- FloatAsinOp -> SLIT("asin")
- FloatAcosOp -> SLIT("acos")
- FloatAtanOp -> SLIT("atan")
- FloatSinhOp -> SLIT("sinh")
- FloatCoshOp -> SLIT("cosh")
- FloatTanhOp -> SLIT("tanh")
- DoubleExpOp -> SLIT("exp")
- DoubleLogOp -> SLIT("log")
- DoubleSqrtOp -> SLIT("sqrt")
- DoubleSinOp -> SLIT("sin")
- DoubleCosOp -> SLIT("cos")
- DoubleTanOp -> SLIT("tan")
- DoubleAsinOp -> SLIT("asin")
- DoubleAcosOp -> SLIT("acos")
- DoubleAtanOp -> SLIT("atan")
- DoubleSinhOp -> SLIT("sinh")
- DoubleCoshOp -> SLIT("cosh")
- DoubleTanhOp -> SLIT("tanh")
+ FloatExpOp -> FSLIT("exp")
+ FloatLogOp -> FSLIT("log")
+ FloatSqrtOp -> FSLIT("sqrt")
+ FloatSinOp -> FSLIT("sin")
+ FloatCosOp -> FSLIT("cos")
+ FloatTanOp -> FSLIT("tan")
+ FloatAsinOp -> FSLIT("asin")
+ FloatAcosOp -> FSLIT("acos")
+ FloatAtanOp -> FSLIT("atan")
+ FloatSinhOp -> FSLIT("sinh")
+ FloatCoshOp -> FSLIT("cosh")
+ FloatTanhOp -> FSLIT("tanh")
+ DoubleExpOp -> FSLIT("exp")
+ DoubleLogOp -> FSLIT("log")
+ DoubleSqrtOp -> FSLIT("sqrt")
+ DoubleSinOp -> FSLIT("sin")
+ DoubleCosOp -> FSLIT("cos")
+ DoubleTanOp -> FSLIT("tan")
+ DoubleAsinOp -> FSLIT("asin")
+ DoubleAcosOp -> FSLIT("acos")
+ DoubleAtanOp -> FSLIT("atan")
+ DoubleSinhOp -> FSLIT("sinh")
+ DoubleCoshOp -> FSLIT("cosh")
+ DoubleTanhOp -> FSLIT("tanh")
where
pr = panic "MachCode.getRegister: no primrep needed for Alpha"
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> trivialCode (CMP LT) y x
+ CharGtOp -> trivialCode (CMP LTT) y x
CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQ) x y
+ CharEqOp -> trivialCode (CMP EQQ) x y
CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LT) x y
+ CharLtOp -> trivialCode (CMP LTT) x y
CharLeOp -> trivialCode (CMP LE) x y
- IntGtOp -> trivialCode (CMP LT) y x
+ IntGtOp -> trivialCode (CMP LTT) y x
IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQ) x y
+ IntEqOp -> trivialCode (CMP EQQ) x y
IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LT) x y
+ IntLtOp -> trivialCode (CMP LTT) x y
IntLeOp -> trivialCode (CMP LE) x y
WordGtOp -> trivialCode (CMP ULT) y x
WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQ) x y
+ WordEqOp -> trivialCode (CMP EQQ) x y
WordNeOp -> int_NE_code x y
WordLtOp -> trivialCode (CMP ULT) x y
WordLeOp -> trivialCode (CMP ULE) x y
AddrGtOp -> trivialCode (CMP ULT) y x
AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQ) x y
+ AddrEqOp -> trivialCode (CMP EQQ) x y
AddrNeOp -> int_NE_code x y
AddrLtOp -> trivialCode (CMP ULT) x y
AddrLeOp -> trivialCode (CMP ULE) x y
-
- FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y
- FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- FloatLtOp -> cmpF_code (FCMP TF LT) NE x y
+
+ FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y
+ DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
IntAddOp -> trivialCode (ADD Q False) x y
IntQuotOp -> trivialCode (DIV Q False) x y
IntRemOp -> trivialCode (REM Q False) x y
+ WordAddOp -> trivialCode (ADD Q False) x y
+ WordSubOp -> trivialCode (SUB Q False) x y
+ WordMulOp -> trivialCode (MUL 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
DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
+ AddrAddOp -> trivialCode (ADD Q False) x y
+ AddrSubOp -> trivialCode (SUB Q False) x y
+ AddrRemOp -> trivialCode (REM Q True) x y
+
AndOp -> trivialCode AND x y
OrOp -> trivialCode OR x y
+ XorOp -> trivialCode XOR x y
SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "AlphaGen:isll"
- ISraOp -> panic "AlphaGen:isra"
- ISrlOp -> panic "AlphaGen:isrl"
+ ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+ ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+ ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
+ FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
where
{- ------------------------------------------------------------
Some bizarre special code for getting condition codes into
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 EQ) 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
code__2 dst = code . mkSeqInstrs [
- OR zero (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zero (RIReg zero) dst,
+ OR zeroh (RIImm (ImmInt 1)) dst,
+ BF cond result (ImmCLbl lbl),
+ OR zeroh (RIReg zeroh) dst,
LABEL lbl]
in
- returnUs (Any IntRep code__2)
+ 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 zero (RIImm src) dst)
+ 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
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
+#if i386_TARGET_ARCH
-getRegister (StDouble 0.0)
- = let
- code dst = mkSeqInstrs [FLDZ]
+getRegister (StFloat f)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat f],
+ SEGMENT TextSegment,
+ GLD F (ImmAddr (ImmCLbl lbl) 0) dst
+ ]
in
- returnUs (Any DoubleRep code)
+ returnNat (Any FloatRep code)
-getRegister (StDouble 1.0)
- = let
- code dst = mkSeqInstrs [FLD1]
- in
- returnUs (Any DoubleRep code)
getRegister (StDouble d)
- = getUniqLabelNCG `thenUs` \ lbl ->
- --getNewRegNCG PtrRep `thenUs` \ tmp ->
- let code dst = mkSeqInstrs [
+
+ | d == 0.0
+ = let code dst = unitOL (GLDZ dst)
+ in returnNat (Any DoubleRep code)
+
+ | d == 1.0
+ = let code dst = unitOL (GLD1 dst)
+ in returnNat (Any DoubleRep code)
+
+ | otherwise
+ = getNatLabelNCG `thenNat` \ lbl ->
+ let code dst = toOL [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
- FLD DF (OpImm (ImmCLbl lbl))
+ GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
]
in
- returnUs (Any DoubleRep code)
+ returnNat (Any DoubleRep code)
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEGI L) x
- IntAbsOp -> absIntCode x
- NotOp -> trivialUCode (NOT L) x
+getRegister (StMachOp mop [x]) -- unary MachOps
+ = case mop of
+ MO_NatS_Neg -> trivialUCode (NEGI L) x
+ MO_Nat_Not -> trivialUCode (NOT L) x
+ MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
- FloatNegOp -> trivialUFCode FloatRep FCHS x
- FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
- DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+ MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
+ MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
- DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+ MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
+ MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
+ MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
+ MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
+ MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
+ MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
+ MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
+ MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
- other_op ->
- let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
- in
- getRegister (StCall fn DoubleRep [x])
- where
- (is_float_op, fn)
- = case primop of
- FloatExpOp -> (True, SLIT("exp"))
- FloatLogOp -> (True, SLIT("log"))
+ MO_Flt_to_NatS -> coerceFP2Int FloatRep x
+ MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+ MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
+ MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
- FloatSinOp -> (True, SLIT("sin"))
- FloatCosOp -> (True, SLIT("cos"))
- FloatTanOp -> (True, SLIT("tan"))
+ -- Conversions which are a nop on x86
+ MO_NatS_to_32U -> conversionNop WordRep x
+ MO_32U_to_NatS -> conversionNop IntRep x
- FloatAsinOp -> (True, SLIT("asin"))
- FloatAcosOp -> (True, SLIT("acos"))
- FloatAtanOp -> (True, SLIT("atan"))
+ MO_NatU_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_NatU -> conversionNop WordRep x
+ MO_NatP_to_NatU -> conversionNop WordRep x
+ MO_NatU_to_NatP -> conversionNop PtrRep x
+ MO_NatS_to_NatP -> conversionNop PtrRep x
+ MO_NatP_to_NatS -> conversionNop IntRep x
- FloatSinhOp -> (True, SLIT("sinh"))
- FloatCoshOp -> (True, SLIT("cosh"))
- FloatTanhOp -> (True, SLIT("tanh"))
+ MO_Dbl_to_Flt -> conversionNop FloatRep x
+ MO_Flt_to_Dbl -> conversionNop DoubleRep x
- DoubleExpOp -> (False, SLIT("exp"))
- DoubleLogOp -> (False, SLIT("log"))
+ -- sign-extending widenings
+ MO_8U_to_NatU -> integerExtend False 24 x
+ MO_8S_to_NatS -> integerExtend True 24 x
+ MO_16U_to_NatU -> integerExtend False 16 x
+ MO_16S_to_NatS -> integerExtend True 16 x
+ MO_8U_to_32U -> integerExtend False 24 x
- DoubleSinOp -> (False, SLIT("sin"))
- DoubleCosOp -> (False, SLIT("cos"))
- DoubleTanOp -> (False, SLIT("tan"))
+ other_op
+ -> getRegister (
+ (if is_float_op then demote else id)
+ (StCall (Left fn) CCallConv DoubleRep
+ [(if is_float_op then promote else id) x])
+ )
+ where
+ integerExtend signed nBits x
+ = getRegister (
+ StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
+ [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+ )
+
+ conversionNop new_rep expr
+ = getRegister expr `thenNat` \ e_code ->
+ returnNat (swizzleRegisterRep e_code new_rep)
+
+ promote x = StMachOp MO_Flt_to_Dbl [x]
+ demote x = StMachOp MO_Dbl_to_Flt [x]
+ (is_float_op, fn)
+ = case mop of
+ MO_Flt_Exp -> (True, FSLIT("exp"))
+ MO_Flt_Log -> (True, FSLIT("log"))
+
+ MO_Flt_Asin -> (True, FSLIT("asin"))
+ MO_Flt_Acos -> (True, FSLIT("acos"))
+ MO_Flt_Atan -> (True, FSLIT("atan"))
+
+ MO_Flt_Sinh -> (True, FSLIT("sinh"))
+ MO_Flt_Cosh -> (True, FSLIT("cosh"))
+ MO_Flt_Tanh -> (True, FSLIT("tanh"))
+
+ MO_Dbl_Exp -> (False, FSLIT("exp"))
+ MO_Dbl_Log -> (False, FSLIT("log"))
+
+ MO_Dbl_Asin -> (False, FSLIT("asin"))
+ MO_Dbl_Acos -> (False, FSLIT("acos"))
+ MO_Dbl_Atan -> (False, FSLIT("atan"))
+
+ MO_Dbl_Sinh -> (False, FSLIT("sinh"))
+ MO_Dbl_Cosh -> (False, FSLIT("cosh"))
+ MO_Dbl_Tanh -> (False, FSLIT("tanh"))
+
+ other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
+ (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic MachOps
+ = case mop of
+ MO_32U_Gt -> condIntReg GTT x y
+ MO_32U_Ge -> condIntReg GE x y
+ MO_32U_Eq -> condIntReg EQQ x y
+ MO_32U_Ne -> condIntReg NE x y
+ MO_32U_Lt -> condIntReg LTT x y
+ MO_32U_Le -> condIntReg LE x y
+
+ MO_Nat_Eq -> condIntReg EQQ x y
+ MO_Nat_Ne -> condIntReg NE x y
+
+ MO_NatS_Gt -> condIntReg GTT x y
+ MO_NatS_Ge -> condIntReg GE x y
+ MO_NatS_Lt -> condIntReg LTT x y
+ MO_NatS_Le -> condIntReg LE x y
+
+ MO_NatU_Gt -> condIntReg GU x y
+ MO_NatU_Ge -> condIntReg GEU x y
+ MO_NatU_Lt -> condIntReg LU x y
+ MO_NatU_Le -> condIntReg LEU x y
+
+ MO_Flt_Gt -> condFltReg GTT x y
+ MO_Flt_Ge -> condFltReg GE x y
+ MO_Flt_Eq -> condFltReg EQQ x y
+ MO_Flt_Ne -> condFltReg NE x y
+ MO_Flt_Lt -> condFltReg LTT x y
+ MO_Flt_Le -> condFltReg LE x y
+
+ MO_Dbl_Gt -> condFltReg GTT x y
+ MO_Dbl_Ge -> condFltReg GE x y
+ MO_Dbl_Eq -> condFltReg EQQ x y
+ MO_Dbl_Ne -> condFltReg NE x y
+ MO_Dbl_Lt -> condFltReg LTT x y
+ MO_Dbl_Le -> condFltReg LE x y
+
+ MO_Nat_Add -> add_code L x y
+ MO_Nat_Sub -> sub_code L x y
+ MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
+ MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
+ MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
+ MO_NatU_Rem -> trivialCode (REM L) Nothing x y
+ MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
+ MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
+ MO_NatS_MulMayOflo -> imulMayOflo x y
+
+ MO_Flt_Add -> trivialFCode FloatRep GADD x y
+ MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
+ MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
+ MO_Flt_Div -> trivialFCode FloatRep GDIV x y
+
+ MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
+ MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
+ MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
+ MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
+
+ MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
+ MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
+ MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
+
+ {- 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.)
+ -}
+ MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
+ MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
+ MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
+
+ MO_Flt_Pwr -> getRegister (demote
+ (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [promote x, promote y])
+ )
+ MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [x, y])
+ other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
+ where
+ promote x = StMachOp MO_Flt_to_Dbl [x]
+ demote x = StMachOp MO_Dbl_to_Flt [x]
- DoubleAsinOp -> (False, SLIT("asin"))
- DoubleAcosOp -> (False, SLIT("acos"))
- DoubleAtanOp -> (False, SLIT("atan"))
+ --------------------
+ imulMayOflo :: StixExpr -> StixExpr -> NatM Register
+ imulMayOflo a1 a2
+ = getNewRegNCG IntRep `thenNat` \ t1 ->
+ getNewRegNCG IntRep `thenNat` \ t2 ->
+ getNewRegNCG IntRep `thenNat` \ res_lo ->
+ getNewRegNCG IntRep `thenNat` \ res_hi ->
+ getRegister a1 `thenNat` \ reg1 ->
+ getRegister a2 `thenNat` \ reg2 ->
+ let code1 = registerCode reg1 t1
+ code2 = registerCode reg2 t2
+ src1 = registerName reg1 t1
+ src2 = registerName reg2 t2
+ code dst = code1 `appOL` code2 `appOL`
+ toOL [
+ MOV L (OpReg src1) (OpReg res_hi),
+ MOV L (OpReg src2) (OpReg res_lo),
+ IMUL64 res_hi res_lo, -- result in res_hi:res_lo
+ SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
+ SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
+ MOV L (OpReg res_lo) (OpReg dst)
+ -- dst==0 if high part == sign extended low part
+ ]
+ in
+ returnNat (Any IntRep code)
- DoubleSinhOp -> (False, SLIT("sinh"))
- DoubleCoshOp -> (False, SLIT("cosh"))
- DoubleTanhOp -> (False, SLIT("tanh"))
+ --------------------
+ shift_code :: (Imm -> Operand -> Instr)
+ -> StixExpr
+ -> StixExpr
+ -> 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 `thenNat` \ regx ->
+ let mkcode 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 `snocOL`
+ MOV L (OpReg r_x) (OpReg dst) `snocOL`
+ instr imm__2 (OpReg dst)
+ in
+ returnNat (Any IntRep mkcode)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+ {- Case2: shift length is complex (non-immediate) -}
+ -- Since ECX is always used as a spill temporary, we can't
+ -- 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 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 `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
+ src_amt = registerName register2 tmp
+ code_amt = registerCode register2 tmp
+ r_dst = OpReg dst
+ r_tmp = OpReg tmp
+ in
+ code_amt `snocOL`
+ MOV L (OpReg src_amt) r_tmp `appOL`
+ code_val `snocOL`
+ MOV L (OpReg src_val) r_dst `appOL`
+ toOL [
+ COMMENT (mkFastString "begin shift sequence"),
+ MOV L (OpReg src_val) r_dst,
+ MOV L (OpReg src_amt) r_tmp,
+
+ BT L (ImmInt 4) r_tmp,
+ JXX GEU lbl_test3,
+ instr (ImmInt 16) r_dst,
+
+ LABEL lbl_test3,
+ BT L (ImmInt 3) r_tmp,
+ JXX GEU lbl_test2,
+ instr (ImmInt 8) r_dst,
+
+ LABEL lbl_test2,
+ BT L (ImmInt 2) r_tmp,
+ JXX GEU lbl_test1,
+ instr (ImmInt 4) r_dst,
+
+ LABEL lbl_test1,
+ BT L (ImmInt 1) r_tmp,
+ JXX GEU lbl_test0,
+ instr (ImmInt 2) r_dst,
+
+ LABEL lbl_test0,
+ BT L (ImmInt 0) r_tmp,
+ JXX GEU lbl_after,
+ instr (ImmInt 1) r_dst,
+ LABEL lbl_after,
+
+ COMMENT (mkFastString "end shift sequence")
+ ]
+ in
+ returnNat (Any IntRep code__2)
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> condIntReg GT x y
- CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
- CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
- CharLeOp -> condIntReg LE x y
-
- IntGtOp -> condIntReg GT x y
- IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
- IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
- IntLeOp -> condIntReg LE x y
-
- WordGtOp -> condIntReg GU x y
- WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
- WordNeOp -> condIntReg NE x y
- WordLtOp -> condIntReg LU x y
- WordLeOp -> condIntReg LEU x y
-
- AddrGtOp -> condIntReg GU x y
- AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
- AddrNeOp -> condIntReg NE x y
- AddrLtOp -> condIntReg LU x y
- AddrLeOp -> condIntReg LEU x y
-
- FloatGtOp -> condFltReg GT x y
- FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
- FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
- FloatLeOp -> condFltReg LE x y
-
- DoubleGtOp -> condFltReg GT x y
- DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
- DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
- DoubleLeOp -> condFltReg LE x y
-
- IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
- -- this should be optimised by the generic Opts,
- -- I don't know why it is not (sometimes)!
- case args of
- [x, StInt 0] -> getRegister x
- _ -> add_code L x y
- -}
- add_code L x y
-
- IntSubOp -> sub_code L x y
- IntQuotOp -> quot_code L x y True{-division-}
- IntRemOp -> quot_code L x y False{-remainder-}
- IntMulOp -> trivialCode (IMUL L) x y {-True-}
-
- FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
- FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
- FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
- FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
-
- DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
- DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
- DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
- DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
-
- AndOp -> trivialCode (AND L) x y {-True-}
- OrOp -> trivialCode (OR L) x y {-True-}
- SllOp -> trivialCode (SHL L) x y {-False-}
- SraOp -> trivialCode (SAR L) x y {-False-}
- SrlOp -> trivialCode (SHR L) x y {-False-}
-
- ISllOp -> panic "I386Gen:isll"
- ISraOp -> panic "I386Gen:isra"
- ISrlOp -> panic "I386Gen:isrl"
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
- where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
- where
- add_code :: Size -> StixTree -> StixTree -> UniqSM Register
+ --------------------
+ add_code :: Size -> StixExpr -> StixExpr -> 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 (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 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 (StInd _ mem)
- = getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
- in
- returnUs (Any IntRep code__2)
-
- add_code sz (StInd _ mem) y
- = getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- fixedname = registerName register2 eax
- code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
- in
- returnUs (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 (Addr (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 -> StixExpr -> StixExpr -> 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 (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 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) x y {-False-}
-
- --------------------
- quot_code
- :: Size
- -> StixTree -> StixTree
- -> Bool -- True => division, False => remainder operation
- -> UniqSM 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 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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
- in
- returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-
- quot_code sz x y is_division
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getRegister y `thenUs` \ register2 ->
- 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 = 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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
- in
- returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
- -----------------------
+ sub_code sz x y = trivialCode (SUB sz) Nothing x y
getRegister (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+ | not (is64BitRep pk)
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
- src = amodeAddr amode
+ src = amodeAddr amode
size = primRepToSize pk
- code__2 dst = code .
- if pk == DoubleRep || pk == FloatRep
- then mkSeqInstr (FLD {-DF-} size (OpAddr src))
- else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
- in
- returnUs (Any pk code__2)
-
+ code__2 dst = code `snocOL`
+ if pk == DoubleRep || pk == FloatRep
+ then GLD size src dst
+ else (case size of
+ B -> MOVSxL B
+ Bu -> MOVZxL Bu
+ W -> MOVSxL W
+ Wu -> MOVZxL Wu
+ L -> MOV L
+ Lu -> MOV L)
+ (OpAddr src) (OpReg dst)
+ in
+ 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
+ = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
+getRegister (StFloat d)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat d],
+ SEGMENT TextSegment,
+ SETHI (HI (ImmCLbl lbl)) tmp,
+ LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ in
+ returnNat (Any FloatRep code)
+
getRegister (StDouble d)
- = getUniqLabelNCG `thenUs` \ lbl ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let code dst = mkSeqInstrs [
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
- returnUs (Any DoubleRep code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (SUB False False g0) x
- IntAbsOp -> absIntCode x
-
- NotOp -> trivialUCode (XNOR False g0) x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
+ returnNat (Any DoubleRep code)
- Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
- Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
-
- other_op ->
- let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
- in
- getRegister (StCall fn DoubleRep [x])
- where
- (is_float_op, fn)
- = case primop of
- FloatExpOp -> (True, SLIT("exp"))
- FloatLogOp -> (True, SLIT("log"))
+getRegister (StMachOp mop [x]) -- unary PrimOps
+ = case mop of
+ MO_NatS_Neg -> trivialUCode (SUB False False g0) x
+ MO_Nat_Not -> trivialUCode (XNOR False g0) x
+ MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
- FloatSinOp -> (True, SLIT("sin"))
- FloatCosOp -> (True, SLIT("cos"))
- FloatTanOp -> (True, SLIT("tan"))
+ MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
+ MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
- FloatAsinOp -> (True, SLIT("asin"))
- FloatAcosOp -> (True, SLIT("acos"))
- FloatAtanOp -> (True, SLIT("atan"))
+ MO_Dbl_to_Flt -> coerceDbl2Flt x
+ MO_Flt_to_Dbl -> coerceFlt2Dbl x
- FloatSinhOp -> (True, SLIT("sinh"))
- FloatCoshOp -> (True, SLIT("cosh"))
- FloatTanhOp -> (True, SLIT("tanh"))
+ MO_Flt_to_NatS -> coerceFP2Int FloatRep x
+ MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+ MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
+ MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
- DoubleExpOp -> (False, SLIT("exp"))
- DoubleLogOp -> (False, SLIT("log"))
+ -- Conversions which are a nop on sparc
+ MO_32U_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_32U -> conversionNop WordRep x
- DoubleSinOp -> (False, SLIT("sin"))
- DoubleCosOp -> (False, SLIT("cos"))
- DoubleTanOp -> (False, SLIT("tan"))
+ MO_NatU_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_NatU -> conversionNop WordRep x
+ MO_NatP_to_NatU -> conversionNop WordRep x
+ MO_NatU_to_NatP -> conversionNop PtrRep x
+ MO_NatS_to_NatP -> conversionNop PtrRep x
+ MO_NatP_to_NatS -> conversionNop IntRep x
- DoubleAsinOp -> (False, SLIT("asin"))
- DoubleAcosOp -> (False, SLIT("acos"))
- DoubleAtanOp -> (False, SLIT("atan"))
+ -- sign-extending widenings
+ MO_8U_to_32U -> integerExtend False 24 x
+ MO_8U_to_NatU -> integerExtend False 24 x
+ MO_8S_to_NatS -> integerExtend True 24 x
+ MO_16U_to_NatU -> integerExtend False 16 x
+ MO_16S_to_NatS -> integerExtend True 16 x
- DoubleSinhOp -> (False, SLIT("sinh"))
- DoubleCoshOp -> (False, SLIT("cosh"))
- DoubleTanhOp -> (False, SLIT("tanh"))
+ other_op ->
+ let fixed_x = if is_float_op -- promote to double
+ then StMachOp MO_Flt_to_Dbl [x]
+ else x
+ in
+ getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
+ where
+ integerExtend signed nBits x
+ = getRegister (
+ StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
+ [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+ )
+ conversionNop new_rep expr
+ = getRegister expr `thenNat` \ e_code ->
+ returnNat (swizzleRegisterRep e_code new_rep)
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> condIntReg GT x y
- CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
- CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
- CharLeOp -> condIntReg LE x y
-
- IntGtOp -> condIntReg GT x y
- IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
- IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
- IntLeOp -> condIntReg LE x y
-
- WordGtOp -> condIntReg GU x y
- WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
- WordNeOp -> condIntReg NE x y
- WordLtOp -> condIntReg LU x y
- WordLeOp -> condIntReg LEU x y
-
- AddrGtOp -> condIntReg GU x y
- AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
- AddrNeOp -> condIntReg NE x y
- AddrLtOp -> condIntReg LU x y
- AddrLeOp -> condIntReg LEU x y
-
- FloatGtOp -> condFltReg GT x y
- FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
- FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
- FloatLeOp -> condFltReg LE x y
-
- DoubleGtOp -> condFltReg GT x y
- DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
- DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
- DoubleLeOp -> condFltReg LE x y
-
- IntAddOp -> trivialCode (ADD False False) x y
- IntSubOp -> trivialCode (SUB False False) x y
-
- -- ToDo: teach about V8+ SPARC mul/div instructions
- IntMulOp -> imul_div SLIT(".umul") x y
- IntQuotOp -> imul_div SLIT(".div") x y
- IntRemOp -> imul_div SLIT(".rem") x y
-
- FloatAddOp -> trivialFCode FloatRep FADD x y
- FloatSubOp -> trivialFCode FloatRep FSUB x y
- FloatMulOp -> trivialFCode FloatRep FMUL x y
- FloatDivOp -> trivialFCode FloatRep FDIV x y
-
- DoubleAddOp -> trivialFCode DoubleRep FADD x y
- DoubleSubOp -> trivialFCode DoubleRep FSUB x y
- DoubleMulOp -> trivialFCode DoubleRep FMUL x y
- DoubleDivOp -> trivialFCode DoubleRep FDIV x y
-
- AndOp -> trivialCode (AND False) x y
- OrOp -> trivialCode (OR False) x y
- SllOp -> trivialCode SLL x y
- SraOp -> trivialCode SRA x y
- SrlOp -> trivialCode SRL x y
-
- ISllOp -> panic "SparcGen:isll"
- ISraOp -> panic "SparcGen:isra"
- ISrlOp -> panic "SparcGen:isrl"
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
- where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+ (is_float_op, fn)
+ = case mop of
+ MO_Flt_Exp -> (True, FSLIT("exp"))
+ MO_Flt_Log -> (True, FSLIT("log"))
+ MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
+
+ MO_Flt_Sin -> (True, FSLIT("sin"))
+ MO_Flt_Cos -> (True, FSLIT("cos"))
+ MO_Flt_Tan -> (True, FSLIT("tan"))
+
+ MO_Flt_Asin -> (True, FSLIT("asin"))
+ MO_Flt_Acos -> (True, FSLIT("acos"))
+ MO_Flt_Atan -> (True, FSLIT("atan"))
+
+ MO_Flt_Sinh -> (True, FSLIT("sinh"))
+ MO_Flt_Cosh -> (True, FSLIT("cosh"))
+ MO_Flt_Tanh -> (True, FSLIT("tanh"))
+
+ MO_Dbl_Exp -> (False, FSLIT("exp"))
+ MO_Dbl_Log -> (False, FSLIT("log"))
+ MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
+
+ MO_Dbl_Sin -> (False, FSLIT("sin"))
+ MO_Dbl_Cos -> (False, FSLIT("cos"))
+ MO_Dbl_Tan -> (False, FSLIT("tan"))
+
+ MO_Dbl_Asin -> (False, FSLIT("asin"))
+ MO_Dbl_Acos -> (False, FSLIT("acos"))
+ MO_Dbl_Atan -> (False, FSLIT("atan"))
+
+ MO_Dbl_Sinh -> (False, FSLIT("sinh"))
+ MO_Dbl_Cosh -> (False, FSLIT("cosh"))
+ MO_Dbl_Tanh -> (False, FSLIT("tanh"))
+
+ other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
+ (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
+ = case mop of
+ MO_32U_Gt -> condIntReg GTT x y
+ MO_32U_Ge -> condIntReg GE x y
+ MO_32U_Eq -> condIntReg EQQ x y
+ MO_32U_Ne -> condIntReg NE x y
+ MO_32U_Lt -> condIntReg LTT x y
+ MO_32U_Le -> condIntReg LE x y
+
+ MO_Nat_Eq -> condIntReg EQQ x y
+ MO_Nat_Ne -> condIntReg NE x y
+
+ MO_NatS_Gt -> condIntReg GTT x y
+ MO_NatS_Ge -> condIntReg GE x y
+ MO_NatS_Lt -> condIntReg LTT x y
+ MO_NatS_Le -> condIntReg LE x y
+
+ MO_NatU_Gt -> condIntReg GU x y
+ MO_NatU_Ge -> condIntReg GEU x y
+ MO_NatU_Lt -> condIntReg LU x y
+ MO_NatU_Le -> condIntReg LEU x y
+
+ MO_Flt_Gt -> condFltReg GTT x y
+ MO_Flt_Ge -> condFltReg GE x y
+ MO_Flt_Eq -> condFltReg EQQ x y
+ MO_Flt_Ne -> condFltReg NE x y
+ MO_Flt_Lt -> condFltReg LTT x y
+ MO_Flt_Le -> condFltReg LE x y
+
+ MO_Dbl_Gt -> condFltReg GTT x y
+ MO_Dbl_Ge -> condFltReg GE x y
+ MO_Dbl_Eq -> condFltReg EQQ x y
+ MO_Dbl_Ne -> condFltReg NE x y
+ MO_Dbl_Lt -> condFltReg LTT x y
+ MO_Dbl_Le -> condFltReg LE x y
+
+ MO_Nat_Add -> trivialCode (ADD False False) x y
+ MO_Nat_Sub -> trivialCode (SUB False False) x y
+
+ MO_NatS_Mul -> trivialCode (SMUL False) x y
+ MO_NatU_Mul -> trivialCode (UMUL False) x y
+ MO_NatS_MulMayOflo -> imulMayOflo x y
+
+ -- ToDo: teach about V8+ SPARC div instructions
+ MO_NatS_Quot -> idiv FSLIT(".div") x y
+ MO_NatS_Rem -> idiv FSLIT(".rem") x y
+ MO_NatU_Quot -> idiv FSLIT(".udiv") x y
+ MO_NatU_Rem -> idiv FSLIT(".urem") x y
+
+ MO_Flt_Add -> trivialFCode FloatRep FADD x y
+ MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
+ MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
+ MO_Flt_Div -> trivialFCode FloatRep FDIV x y
+
+ MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
+ MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
+ MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
+ MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
+
+ MO_Nat_And -> trivialCode (AND False) x y
+ MO_Nat_Or -> trivialCode (OR False) x y
+ MO_Nat_Xor -> trivialCode (XOR False) x y
+
+ MO_Nat_Shl -> trivialCode SLL x y
+ MO_Nat_Shr -> trivialCode SRL x y
+ MO_Nat_Sar -> trivialCode SRA x y
+
+ MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [promote x, promote y])
+ where promote x = StMachOp MO_Flt_to_Dbl [x]
+ MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [x, y])
+
+ other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
where
- imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+ idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
+
+ --------------------
+ imulMayOflo :: StixExpr -> StixExpr -> NatM Register
+ imulMayOflo a1 a2
+ = getNewRegNCG IntRep `thenNat` \ t1 ->
+ getNewRegNCG IntRep `thenNat` \ t2 ->
+ getNewRegNCG IntRep `thenNat` \ res_lo ->
+ getNewRegNCG IntRep `thenNat` \ res_hi ->
+ getRegister a1 `thenNat` \ reg1 ->
+ getRegister a2 `thenNat` \ reg2 ->
+ let code1 = registerCode reg1 t1
+ code2 = registerCode reg2 t2
+ src1 = registerName reg1 t1
+ src2 = registerName reg2 t2
+ code dst = code1 `appOL` code2 `appOL`
+ toOL [
+ SMUL False src1 (RIReg src2) res_lo,
+ RDY res_hi,
+ SRA res_lo (RIImm (ImmInt 31)) res_lo,
+ SUB False False res_lo (RIReg res_hi) dst
+ ]
+ in
+ returnNat (Any IntRep code)
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)
+ code__2 dst = code `snocOL` LD size src dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
getRegister (StInt i)
| fits13Bits i
= let
src = ImmInt (fromInteger i)
- code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+ code dst = unitOL (OR False g0 (RIImm src) dst)
in
- returnUs (Any IntRep code)
+ returnNat (Any IntRep code)
getRegister leaf
| maybeToBool imm
= let
- code dst = mkSeqInstrs [
+ code dst = toOL [
SETHI (HI imm__2) dst,
OR False dst (RIImm (LO imm__2)) dst]
in
- returnUs (Any PtrRep code)
+ returnNat (Any PtrRep code)
+ | otherwise
+ = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
\end{code}
%************************************************************************
@Amode@s: Memory addressing modes passed up the tree.
\begin{code}
-data Amode = Amode Addr InstrBlock
+data Amode = Amode MachRegsAddr InstrBlock
amodeAddr (Amode addr _) = addr
amodeCode (Amode _ code) = code
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 :: StixExpr -> 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 ->
+-- This is all just ridiculous, since it carefully undoes
+-- what mangleIndexTree has just done.
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [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 ->
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, y])
- = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
+ | shift == 0 || shift == 1 || shift == 2 || shift == 3
+ = 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 (Addr (Just reg1) (Just (reg2,4)) (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 (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
-getAmode (StPrim IntSubOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Sub [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])
+getAmode (StMachOp MO_Nat_Add [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 ->
+getAmode (StMachOp MO_Nat_Add [x, y])
+ = 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
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)
+ code = unitOL (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}
%************************************************************************
\begin{code}
data CondCode = CondCode Bool Cond InstrBlock
-condName (CondCode _ cond _) = cond
+condName (CondCode _ cond _) = cond
condFloat (CondCode is_float _ _) = is_float
-condCode (CondCode _ _ code) = code
+condCode (CondCode _ _ code) = code
\end{code}
Set up a condition code for a conditional branch.
\begin{code}
-getCondCode :: StixTree -> UniqSM CondCode
+getCondCode :: StixExpr -> NatM CondCode
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
getCondCode = panic "MachCode.getCondCode: not on Alphas"
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH || sparc_TARGET_ARCH
-- yes, they really do seem to want exactly the same!
-getCondCode (StPrim primop [x, y])
- = case primop of
- CharGtOp -> condIntCode GT x y
- CharGeOp -> condIntCode GE x y
- CharEqOp -> condIntCode EQ x y
- CharNeOp -> condIntCode NE x y
- CharLtOp -> condIntCode LT x y
- CharLeOp -> condIntCode LE x y
+getCondCode (StMachOp mop [x, y])
+ = case mop of
+ MO_32U_Gt -> condIntCode GTT x y
+ MO_32U_Ge -> condIntCode GE x y
+ MO_32U_Eq -> condIntCode EQQ x y
+ MO_32U_Ne -> condIntCode NE x y
+ MO_32U_Lt -> condIntCode LTT x y
+ MO_32U_Le -> condIntCode LE x y
- IntGtOp -> condIntCode GT x y
- IntGeOp -> condIntCode GE x y
- IntEqOp -> condIntCode EQ x y
- IntNeOp -> condIntCode NE x y
- IntLtOp -> condIntCode LT x y
- IntLeOp -> condIntCode LE x y
-
- WordGtOp -> condIntCode GU x y
- WordGeOp -> condIntCode GEU x y
- WordEqOp -> condIntCode EQ x y
- WordNeOp -> condIntCode NE x y
- WordLtOp -> condIntCode LU x y
- WordLeOp -> condIntCode LEU x y
-
- AddrGtOp -> condIntCode GU x y
- AddrGeOp -> condIntCode GEU x y
- AddrEqOp -> condIntCode EQ x y
- AddrNeOp -> condIntCode NE x y
- AddrLtOp -> condIntCode LU x y
- AddrLeOp -> condIntCode LEU x y
-
- FloatGtOp -> condFltCode GT x y
- FloatGeOp -> condFltCode GE x y
- FloatEqOp -> condFltCode EQ x y
- FloatNeOp -> condFltCode NE x y
- FloatLtOp -> condFltCode LT x y
- FloatLeOp -> condFltCode LE x y
-
- DoubleGtOp -> condFltCode GT x y
- DoubleGeOp -> condFltCode GE x y
- DoubleEqOp -> condFltCode EQ x y
- DoubleNeOp -> condFltCode NE x y
- DoubleLtOp -> condFltCode LT x y
- DoubleLeOp -> condFltCode LE x y
+ MO_Nat_Eq -> condIntCode EQQ x y
+ MO_Nat_Ne -> condIntCode NE x y
+
+ MO_NatS_Gt -> condIntCode GTT x y
+ MO_NatS_Ge -> condIntCode GE x y
+ MO_NatS_Lt -> condIntCode LTT x y
+ MO_NatS_Le -> condIntCode LE x y
+
+ MO_NatU_Gt -> condIntCode GU x y
+ MO_NatU_Ge -> condIntCode GEU x y
+ MO_NatU_Lt -> condIntCode LU x y
+ MO_NatU_Le -> condIntCode LEU x y
+
+ MO_Flt_Gt -> condFltCode GTT x y
+ MO_Flt_Ge -> condFltCode GE x y
+ MO_Flt_Eq -> condFltCode EQQ x y
+ MO_Flt_Ne -> condFltCode NE x y
+ MO_Flt_Lt -> condFltCode LTT x y
+ MO_Flt_Le -> condFltCode LE x y
+
+ MO_Dbl_Gt -> condFltCode GTT x y
+ MO_Dbl_Ge -> condFltCode GE x y
+ MO_Dbl_Eq -> condFltCode EQQ x y
+ MO_Dbl_Ne -> condFltCode NE x y
+ MO_Dbl_Lt -> condFltCode LTT x y
+ MO_Dbl_Le -> condFltCode LE x y
+
+ other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
+
+getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
#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 -> StixExpr -> StixExpr -> NatM CondCode
#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-condIntCode cond (StInd _ x) y
- | maybeToBool imm
- = getAmode x `thenUs` \ amode ->
+-- memory vs immediate
+condIntCode cond (StInd pk x) y
+ | Just i <- maybeImm y
+ = 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 i) (OpAddr x__2)
in
- returnUs (CondCode False cond code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
+ returnNat (CondCode False cond code__2)
+-- 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 ->
+ | Just i <- maybeImm y
+ = 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))
- in
- returnUs (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)
-
+ code__2 = code1 `snocOL`
+ CMP L (OpImm i) (OpReg src1)
+ in
+ returnNat (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 (StDouble 0.0)
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
- let
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code__2 = asmParThen [code1 asmVoid] .
- mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (CondCode True (fix_FP_cond cond) code__2)
-
condFltCode cond x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
+ = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
+ getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
+ `thenNat` \ tmp1 ->
getNewRegNCG (registerRep register2)
- `thenUs` \ tmp2 ->
+ `thenNat` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
- pk1 = registerRep register1
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
- mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (CondCode True (fix_FP_cond cond) code__2)
-
-{- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
--}
-
-fix_FP_cond :: Cond -> Cond
-
-fix_FP_cond GE = GEU
-fix_FP_cond GT = GU
-fix_FP_cond LT = LU
-fix_FP_cond LE = LEU
-fix_FP_cond any = any
+ code__2 | isAny register1
+ = code1 `appOL` -- result in tmp1
+ code2 `snocOL`
+ GCMP cond tmp1 src2
+
+ | otherwise
+ = code1 `snocOL`
+ GMOV src1 tmp1 `appOL`
+ code2 `snocOL`
+ GCMP cond tmp1 src2
+ in
+ -- The GCMP insn does the test and sets the zero flag if comparable
+ -- and true. Hence we always supply EQQ as the condition to test.
+ returnNat (CondCode True EQQ code__2)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
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)
+ code__2 = code `snocOL` 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] .
- mkSeqInstr (SUB False True src1 (RIReg src2) g0)
+ code__2 = code1 `appOL` code2 `snocOL`
+ 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)
+ promote x = FxTOy F DF x tmp
pk1 = registerRep register1
code1 = registerCode register1 tmp1
code__2 =
if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
+ code1 `appOL` code2 `snocOL`
+ FCMP True (primRepToSize pk1) src1 src2
else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
- mkSeqInstr (FCMP True DF tmp src2)
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ FCMP True DF tmp src2
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
- mkSeqInstr (FCMP True DF src1 tmp)
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ FCMP True DF src1 tmp
in
- returnUs (CondCode True cond code__2)
+ returnNat (CondCode True cond code__2)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
hand side is forced into a fixed register (e.g. the result of a call).
\begin{code}
-assignIntCode, assignFltCode
- :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
+assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
+
+assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> 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 zero
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
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
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenUs` \ amode ->
- get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
- in
- returnUs code__2
+-- non-FP assignment to memory
+assignMem_IntCode pk addr src
+ = getAmode addr `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, Size) -- code, operator, size
+ :: StixExpr
+ -> NatM (InstrBlock,Operand) -- code, operator
get_op_RI op
- | maybeToBool imm
- = returnUs (asmParThen [], OpImm imm_op, L)
- where
- imm = maybeImm op
- imm_op = case imm of Just x -> x
+ | Just x <- maybeImm op
+ = returnNat (nilOL, OpImm 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
- pk = registerRep register
- sz = primRepToSize pk
in
- returnUs (code, OpReg reg, sz)
-
-assignIntCode pk dst (StInd _ 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
- sz = primRepToSize pk
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (MOV sz (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 ->
- 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
+ returnNat (code, OpReg reg)
+
+-- Assign; dst is a reg, rhs is mem
+assignReg_IntCode pk reg (StInd pks src)
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getAmode src `thenNat` \ amode ->
+ getRegisterReg reg `thenNat` \ reg_dst ->
+ let
+ c_addr = amodeCode amode
+ am_addr = amodeAddr amode
+ r_dst = registerName reg_dst tmp
+ szs = primRepToSize pks
+ opc = case szs of
+ B -> MOVSxL B
+ Bu -> MOVZxL Bu
+ W -> MOVSxL W
+ Wu -> MOVZxL Wu
+ L -> MOV L
+ Lu -> MOV L
+
+ code = c_addr `snocOL`
+ opc (OpAddr am_addr) (OpReg r_dst)
+ in
+ returnNat code
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode pk reg src
+ = getRegisterReg reg `thenNat` \ registerd ->
+ getRegister src `thenNat` \ registers ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ r_dst = registerName registerd tmp
+ r_src = registerName registers r_dst
+ c_src = registerCode registers r_dst
+
+ code = c_src `snocOL`
+ MOV L (OpReg r_src) (OpReg r_dst)
in
- returnUs code__2
+ 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 ->
+assignMem_IntCode pk addr src
+ = getNewRegNCG IntRep `thenNat` \ tmp ->
+ getAmode addr `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 = code1 `appOL` code2 `snocOL` 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 ->
+assignReg_IntCode pk reg src
+ = getRegister src `thenNat` \ register2 ->
+ getRegisterReg reg `thenNat` \ register1 ->
let
dst__2 = registerName register1 g0
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
- then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
+ then code `snocOL` OR False g0 (RIReg src__2) dst__2
else code
in
- returnUs code__2
+ returnNat code__2
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
% --------------------------------
Floating-point assignments:
% --------------------------------
+
\begin{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)
- in
- returnUs code__2
-
-assignFltCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
- getRegister src `thenUs` \ register2 ->
- let
- dst__2 = registerName register1 zero
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (FMOV src__2 dst__2)
- else code
- in
- returnUs 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 ->
- --getRegister src `thenUs` \ register ->
- 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 ->
- let
- sz = primRepToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode asmVoid
- code2 = registerCode register {-tmp-}st0 asmVoid
-
- --src__2= registerName register tmp
- pk__2 = registerRep register
- sz__2 = primRepToSize pk__2
-
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (FSTP sz (OpAddr 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 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp ->
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
let
- sz = primRepToSize pk
- dst__2 = registerName register1 st0 --tmp
-
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
-
- code__2 = code
+ code__2 = if isFixed register2
+ 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
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+ = 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
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src
+ = getRegisterReg reg `thenNat` \ reg_dst ->
+ getRegister src `thenNat` \ reg_src ->
+ getNewRegNCG pk `thenNat` \ tmp ->
+ let
+ r_dst = registerName reg_dst tmp
+ r_src = registerName reg_src r_dst
+ c_src = registerCode reg_src r_dst
+
+ code = if isFixed reg_src
+ then c_src `snocOL` GMOV r_src r_dst
+ else c_src
+ in
+ returnNat code
+
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
-assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+ = getNewRegNCG pk `thenNat` \ tmp1 ->
+ getAmode addr `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
let
sz = primRepToSize pk
dst__2 = amodeAddr amode
- code1 = amodeCode amode asmVoid
- code2 = registerCode register tmp asmVoid
+ code1 = amodeCode amode
+ code2 = registerCode register tmp1
- 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)
- else
- mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
+ code__2 = code1 `appOL` code2 `appOL`
+ if pk == pk__2
+ then unitOL (ST sz src__2 dst__2)
+ else toOL [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 ->
- getNewRegNCG (registerRep register2)
- `thenUs` \ tmp ->
+-- Floating point assignment to a register/temporary
+-- Why is this so bizarrely ugly?
+assignReg_FltCode pk reg src
+ = getRegisterReg reg `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
+ let
+ pk__2 = registerRep register2
+ sz__2 = primRepToSize pk__2
+ in
+ getNewRegNCG pk__2 `thenNat` \ 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 . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+ code__2 =
+ if pk /= pk__2 then
+ code `snocOL` FxTOy sz__2 sz src__2 dst__2
else if isFixed register2 then
- code . mkSeqInstr (FMOV sz src__2 dst__2)
+ code `snocOL` FMOV sz src__2 dst__2
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 :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
+ | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
where
target = ImmCLbl lbl
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
target = registerName register pv
in
if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
+ returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
else
- returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+ 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
--}
+#if i386_TARGET_ARCH
-genJump (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
+genJump dsts (StInd pk mem)
+ = getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
- returnSeq code [JMP (OpAddr target)]
+ returnNat (code `snocOL` JMP dsts (OpAddr target))
-genJump tree
+genJump dsts tree
| maybeToBool imm
- = returnInstr (JMP (OpImm target))
+ = returnNat (unitOL (JMP dsts (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 dsts (OpReg target))
where
imm = maybeImm tree
target = case imm of Just x -> x
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
- | otherwise = returnInstrs [CALL target 0 True, NOP]
+genJump dsts (StCLbl lbl)
+ | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
+ | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
+ | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
where
target = ImmCLbl lbl
-genJump tree
- = getRegister tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
+genJump dsts tree
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (AddrRegReg target g0), NOP]
+ returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
\begin{code}
genCondJump
:: CLabel -- the branch target
- -> StixTree -- the condition on which to branch
- -> UniqSM InstrBlock
+ -> StixExpr -- the condition on which to branch
+ -> 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
in
returnSeq code [BI (cmpOp op) value target]
where
- cmpOp CharGtOp = GT
+ cmpOp CharGtOp = GTT
cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQ
+ cmpOp CharEqOp = EQQ
cmpOp CharNeOp = NE
- cmpOp CharLtOp = LT
+ cmpOp CharLtOp = LTT
cmpOp CharLeOp = LE
- cmpOp IntGtOp = GT
+ cmpOp IntGtOp = GTT
cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQ
+ cmpOp IntEqOp = EQQ
cmpOp IntNeOp = NE
- cmpOp IntLtOp = LT
+ cmpOp IntLtOp = LTT
cmpOp IntLeOp = LE
cmpOp WordGtOp = NE
cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQ
+ cmpOp WordEqOp = EQQ
cmpOp WordNeOp = NE
cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQ
+ cmpOp WordLeOp = EQQ
cmpOp AddrGtOp = NE
cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQ
+ cmpOp AddrEqOp = EQQ
cmpOp AddrNeOp = NE
cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQ
+ cmpOp AddrLeOp = EQQ
genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenUs` \ register ->
+ = 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 = GT
+ cmpOp FloatGtOp = GTT
cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQ
+ cmpOp FloatEqOp = EQQ
cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LT
+ cmpOp FloatLtOp = LTT
cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GT
+ cmpOp DoubleGtOp = GTT
cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQ
+ cmpOp DoubleEqOp = EQQ
cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LT
+ cmpOp DoubleLtOp = LTT
cmpOp DoubleLeOp = LE
genCondJump lbl (StPrim op [x, y])
| 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 -> True
_ -> False
(instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQ)
- FloatGeOp -> (FCMP TF LT, EQ)
- FloatEqOp -> (FCMP TF EQ, NE)
- FloatNeOp -> (FCMP TF EQ, EQ)
- FloatLtOp -> (FCMP TF LT, NE)
+ FloatGtOp -> (FCMP TF LE, EQQ)
+ FloatGeOp -> (FCMP TF LTT, EQQ)
+ FloatEqOp -> (FCMP TF EQQ, NE)
+ FloatNeOp -> (FCMP TF EQQ, EQQ)
+ FloatLtOp -> (FCMP TF LTT, NE)
FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQ)
- DoubleGeOp -> (FCMP TF LT, EQ)
- DoubleEqOp -> (FCMP TF EQ, NE)
- DoubleNeOp -> (FCMP TF EQ, EQ)
- DoubleLtOp -> (FCMP TF LT, NE)
+ DoubleGtOp -> (FCMP TF LE, EQQ)
+ DoubleGeOp -> (FCMP TF LTT, EQQ)
+ DoubleEqOp -> (FCMP TF EQQ, NE)
+ DoubleNeOp -> (FCMP TF EQQ, EQQ)
+ DoubleLtOp -> (FCMP TF LTT, NE)
DoubleLeOp -> (FCMP TF LE, NE)
genCondJump lbl (StPrim op [x, y])
- = 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, EQ)
- CharGeOp -> (CMP LT, EQ)
- CharEqOp -> (CMP EQ, NE)
- CharNeOp -> (CMP EQ, EQ)
- CharLtOp -> (CMP LT, NE)
+ CharGtOp -> (CMP LE, EQQ)
+ CharGeOp -> (CMP LTT, EQQ)
+ CharEqOp -> (CMP EQQ, NE)
+ CharNeOp -> (CMP EQQ, EQQ)
+ CharLtOp -> (CMP LTT, NE)
CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQ)
- IntGeOp -> (CMP LT, EQ)
- IntEqOp -> (CMP EQ, NE)
- IntNeOp -> (CMP EQ, EQ)
- IntLtOp -> (CMP LT, NE)
+ IntGtOp -> (CMP LE, EQQ)
+ IntGeOp -> (CMP LTT, EQQ)
+ IntEqOp -> (CMP EQQ, NE)
+ IntNeOp -> (CMP EQQ, EQQ)
+ IntLtOp -> (CMP LTT, NE)
IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQ)
- WordGeOp -> (CMP ULT, EQ)
- WordEqOp -> (CMP EQ, NE)
- WordNeOp -> (CMP EQ, EQ)
+ WordGtOp -> (CMP ULE, EQQ)
+ WordGeOp -> (CMP ULT, EQQ)
+ WordEqOp -> (CMP EQQ, NE)
+ WordNeOp -> (CMP EQQ, EQQ)
WordLtOp -> (CMP ULT, NE)
WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQ)
- AddrGeOp -> (CMP ULT, EQ)
- AddrEqOp -> (CMP EQ, NE)
- AddrNeOp -> (CMP EQ, EQ)
+ AddrGtOp -> (CMP ULE, EQQ)
+ AddrGeOp -> (CMP ULT, EQQ)
+ AddrEqOp -> (CMP EQQ, NE)
+ AddrNeOp -> (CMP EQQ, EQQ)
AddrLtOp -> (CMP ULT, NE)
AddrLeOp -> (CMP ULE, NE)
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#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
target = ImmCLbl lbl
in
- returnSeq code (
- if condFloat condition then
- [NOP, BF cond False target, NOP]
- else
- [BI cond False target, NOP]
+ returnNat (
+ code `appOL`
+ toOL (
+ if condFloat condition
+ then [NOP, BF cond False target, NOP]
+ else [BI cond False target, NOP]
+ )
)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
\begin{code}
genCCall
- :: FAST_STRING -- function to call
+ :: (Either FastString StixExpr) -- function to call
+ -> CCallConv
-> PrimRep -- type of the result
- -> [StixTree] -- arguments (of mixed type)
- -> UniqSM InstrBlock
+ -> [StixExpr] -- arguments (of mixed type)
+ -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
-genCCall fn kind args
- = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenUs` \ ((unused,_), argCode) ->
+genCCall fn cconv kind args
+ = 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 (uppPStr fn))),
+ LDA pv (AddrImm (ImmLab (ptext fn))),
JSR ra (AddrReg pv) nRegs,
LDGP gp (AddrReg ra)]
where
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 -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
-genCCall fn kind [StInt i]
- | fn == SLIT ("PerformGC_wrapper")
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
- LABEL lbl]
- in
- returnInstrs call
+genCCall fn cconv ret_rep args
+ = mapNat push_arg
+ (reverse args) `thenNat` \ sizes_n_codes ->
+ getDeltaNat `thenNat` \ delta ->
+ let (sizes, push_codes) = unzip sizes_n_codes
+ tot_arg_size = sum sizes
+ in
+ -- deal with static vs dynamic call targets
+ (case fn of
+ Left t_static
+ -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
+ Right dyn
+ -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
+ ASSERT(case dyn_rep of { L -> True; _ -> False})
+ returnNat (dyn_c `snocOL` CALL (Right dyn_r))
+ )
+ `thenNat` \ callinsns ->
+ let push_code = concatOL push_codes
+ call = callinsns `appOL`
+ toOL (
+ -- Deallocate parameters after call for ccall;
+ -- but not for stdcall (callee does it)
+ (if cconv == StdCallConv then [] else
+ [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+ ++
+ [DELTA (delta + tot_arg_size)]
+ )
+ in
+ setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
+ returnNat (push_code `appOL` call)
-genCCall fn kind args
- = mapUs get_call_arg args `thenUs` \ argCode ->
- let
- nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
- code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL fn__2 -- ,
- -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
- in
- returnSeq (code1 . code2) call
where
-- function names that begin with '.' are assumed to be special
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ fn_u = unpackFS (unLeft fn)
+ fn__2 tot_arg_size
+ | head fn_u == '.'
+ = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+ | otherwise -- General case
+ = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
- ------------
- get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
+ stdcallsize tot_arg_size
+ | cconv == StdCallConv = '@':show tot_arg_size
+ | otherwise = ""
- get_call_arg arg
- = get_op arg `thenUs` \ (code, op, sz) ->
- returnUs (code . mkSeqInstr (PUSH sz op))
+ arg_size DF = 8
+ arg_size F = 4
+ arg_size _ = 4
------------
- get_op
- :: StixTree
- -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
-
- get_op (StInt i)
- = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+ push_arg :: StixExpr{-current argument-}
+ -> NatM (Int, InstrBlock) -- argsz, code
+
+ push_arg arg
+ | is64BitRep arg_rep
+ = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
+ getDeltaNat `thenNat` \ delta ->
+ setDeltaNat (delta - 8) `thenNat` \ _ ->
+ let r_lo = VirtualRegI vr_lo
+ r_hi = getHiVRegFromLo r_lo
+ in returnNat (8,
+ code `appOL`
+ toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
+ PUSH L (OpReg r_lo), DELTA (delta - 8)]
+ )
+ | otherwise
+ = 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 size)) (OpReg esp),
+ DELTA (delta-size),
+ GST sz reg (AddrBaseIndex (Just esp)
+ Nothing
+ (ImmInt 0))]
+ )
+ else returnNat (size,
+ code `snocOL`
+ PUSH L (OpReg reg) `snocOL`
+ DELTA (delta-size)
+ )
+ where
+ arg_rep = repOfStixExpr arg
- get_op (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode --asmVoid
- addr = amodeAddr amode
- sz = primRepToSize pk
- in
- returnUs (code, OpAddr addr, sz)
+ ------------
+ get_op
+ :: StixExpr
+ -> 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, OpReg reg, sz)
+ returnNat (code, reg, sz)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
+{-
+ The SPARC calling convention is an absolute
+ nightmare. The first 6x32 bits of arguments are mapped into
+ %o0 through %o5, and the remaining arguments are dumped to the
+ stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
+
+ If we have to put args on the stack, move %o6==%sp down by
+ the number of words to go on the stack, to ensure there's enough space.
+
+ According to Fraser and Hanson's lcc book, page 478, fig 17.2,
+ 16 words above the stack pointer is a word for the address of
+ a structure return value. I use this as a temporary location
+ for moving values from float to int regs. Certainly it isn't
+ safe to put anything in the 16 words starting at %sp, since
+ this area can get trashed at any time due to window overflows
+ caused by signal handlers.
+
+ A final complication (if the above isn't enough) is that
+ we can't blithely calculate the arguments one by one into
+ %o0 .. %o5. Consider the following nested calls:
+
+ fff a (fff b c)
+
+ Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
+ the inner call will itself use %o0, which trashes the value put there
+ in preparation for the outer call. Upshot: we need to calculate the
+ args into temporary regs, and move those to arg regs or onto the
+ stack only immediately prior to the call proper. Sigh.
+-}
-genCCall fn kind args
- = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenUs` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- call = CALL fn__2 nRegs False
- code = asmParThen (map ($ asmVoid) argCode)
- in
- returnSeq code [call, NOP]
+genCCall fn cconv kind args
+ = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
+ let
+ (argcodes, vregss) = unzip argcode_and_vregs
+ n_argRegs = length allArgRegs
+ n_argRegs_used = min (length vregs) n_argRegs
+ vregs = concat vregss
+ in
+ -- deal with static vs dynamic call targets
+ (case fn of
+ Left t_static
+ -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
+ Right dyn
+ -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
+ returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+ )
+ `thenNat` \ callinsns ->
+ let
+ argcode = concatOL argcodes
+ (move_sp_down, move_sp_up)
+ = let nn = length vregs - n_argRegs
+ + 1 -- (for the road)
+ in if nn <= 0
+ then (nilOL, nilOL)
+ else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
+ transfer_code
+ = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
+ in
+ returnNat (argcode `appOL`
+ move_sp_down `appOL`
+ transfer_code `appOL`
+ callinsns `appOL`
+ unitOL NOP `appOL`
+ move_sp_up)
where
- -- function names that begin with '.' are assumed to be special
- -- internally generated names like '.mul,' which don't get an
- -- underscore prefix
- -- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
-
- ------------------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The SPARC calling convention is an absolute
- nightmare. The first 6x32 bits of arguments are mapped into
- %o0 through %o5, and the remaining arguments are dumped to the
- stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
- first argument is a pair of the list of remaining argument
- 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
- @mapAccumL@.
- -}
- get_arg
- :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> UniqSM (([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 ->
- getNewRegNCG (registerRep register)
- `thenUs` \ 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
- DoubleRep ->
- case dsts of
- [] -> (([], offset + 1), code . mkSeqInstrs [
- -- conveniently put the second part in the right stack
- -- location, and load the first part into %o5
- ST DF src (spRel (offset - 1)),
- LD W (spRel (offset - 1)) dst])
- (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
- ST DF src (spRel (-2)),
- LD W (spRel (-2)) dst,
- LD W (spRel (-1)) dst__2])
- FloatRep -> ((dsts, offset), code . mkSeqInstrs [
- ST F src (spRel (-2)),
- LD W (spRel (-2)) dst])
- _ -> ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR False g0 (RIReg src) dst)
- else code))
-
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenUs` \ register ->
- getNewRegNCG (registerRep register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- words = if pk == DoubleRep then 2 else 1
- in
- returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
-
+ -- function names that begin with '.' are assumed to be special
+ -- internally generated names like '.mul,' which don't get an
+ -- underscore prefix
+ -- ToDo:needed (WDP 96/03) ???
+ fn_static = unLeft fn
+ fn__2 = case (headFS fn_static) of
+ '.' -> ImmLit (ftext fn_static)
+ _ -> ImmLab False (ftext fn_static)
+
+ -- move args from the integer vregs into which they have been
+ -- marshalled, into %o0 .. %o5, and the rest onto the stack.
+ move_final :: [Reg] -> [Reg] -> Int -> [Instr]
+
+ move_final [] _ offset -- all args done
+ = []
+
+ move_final (v:vs) [] offset -- out of aregs; move to stack
+ = ST W v (spRel offset)
+ : move_final vs [] (offset+1)
+
+ move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
+ = OR False g0 (RIReg v) a
+ : move_final vs az offset
+
+ -- generate code to calculate an argument, and move it into one
+ -- or two integer vregs.
+ arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
+ arg_to_int_vregs arg
+ | is64BitRep (repOfStixExpr arg)
+ = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
+ let r_lo = VirtualRegI vr_lo
+ r_hi = getHiVRegFromLo r_lo
+ in returnNat (code, [r_hi, r_lo])
+ | otherwise
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNCG (registerRep register) `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ in
+ -- the value is in src. Get it into 1 or 2 int vregs.
+ case pk of
+ DoubleRep ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ getNewRegNCG WordRep `thenNat` \ v2 ->
+ returnNat (
+ code `snocOL`
+ FMOV DF src f0 `snocOL`
+ ST F f0 (spRel 16) `snocOL`
+ LD W (spRel 16) v1 `snocOL`
+ ST F (fPair f0) (spRel 16) `snocOL`
+ LD W (spRel 16) v2
+ ,
+ [v1,v2]
+ )
+ FloatRep ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ returnNat (
+ code `snocOL`
+ ST F src (spRel 16) `snocOL`
+ LD W (spRel 16) v1
+ ,
+ [v1]
+ )
+ other ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ returnNat (
+ code `snocOL` OR False g0 (RIReg src) v1
+ ,
+ [v1]
+ )
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
register allocator.
\begin{code}
-condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
+condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
condIntReg = panic "MachCode.condIntReg (not on Alpha)"
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#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 EQ x (StInt 0)
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
+condIntReg EQQ x (StInt 0)
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
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 EQ x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
+condIntReg EQQ x y
+ = 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 = code1 `appOL` code2 `appOL` toOL [
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
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
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 = code1 `appOL` code2 `appOL` toOL [
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
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
BI cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
BI ALWAYS False (ImmCLbl lbl2), NOP,
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
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
NOP,
BF cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
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}
%************************************************************************
\begin{code}
trivialCode
:: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
- ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
+ ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
+ -> Maybe (Operand -> Operand -> Instr)
,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
- -> UniqSM Register
+ -> StixExpr -> StixExpr -- the two arguments
+ -> NatM Register
trivialFCode
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (
- {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
- (Size -> Operand -> Instr)
- -> (Size -> Operand -> Instr) {-reversed instr-}
- -> Instr {-pop-}
- -> Instr {-reversed instr: pop-}
+ ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
- -> UniqSM Register
+ -> StixExpr -> StixExpr -- the two arguments
+ -> NatM Register
trivialUCode
:: IF_ARCH_alpha((RI -> Reg -> Instr)
,IF_ARCH_i386 ((Operand -> Instr)
,IF_ARCH_sparc((RI -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
- -> UniqSM Register
+ -> StixExpr -- the one argument
+ -> NatM Register
trivialUFCode
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (Instr
+ ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
- -> UniqSM Register
+ -> StixExpr -- the one argument
+ -> 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 -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
+\end{code}
+The Rules of the Game are:
-trivialCode instr x y
- | maybeToBool imm
- = getRegister x `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
- in
- returnUs (Any IntRep code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
+* You cannot assume anything about the destination register dst;
+ it may be anything, including a fixed reg.
-trivialCode instr x y
- | maybeToBool imm
- = getRegister y `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
- in
- returnUs (Any IntRep code__2)
- where
- imm = maybeImm x
- imm__2 = case imm of Just x -> x
+* You may compute an operand into a fixed reg, but you may not
+ subsequently change the contents of that fixed reg. If you
+ want to do so, first copy the value either to a temporary
+ or into dst. You are free to modify dst even if it happens
+ to be a fixed reg -- that's not your problem.
-trivialCode instr x (StInd pk mem)
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-
-trivialCode instr (StInd pk mem) y
- = getRegister y `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let
- code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
+* You cannot assume that a fixed reg will stay live over an
+ arbitrary computation. The same applies to the dst reg.
+
+* Temporary regs obtained from getNewRegNCG are distinct from
+ each other and from all other regs, and stay live over
+ arbitrary computations.
+
+\begin{code}
+
+trivialCode instr maybe_revinstr a b
+
+ | is_imm_b
+ = getRegister a `thenNat` \ rega ->
+ let mkcode dst
+ = if isAny rega
+ then registerCode rega dst `bind` \ code_a ->
+ code_a `snocOL`
+ instr (OpImm imm_b) (OpReg dst)
+ else registerCodeF rega `bind` \ code_a ->
+ registerNameF rega `bind` \ r_a ->
+ code_a `snocOL`
+ MOV L (OpReg r_a) (OpReg dst) `snocOL`
+ instr (OpImm imm_b) (OpReg dst)
+ in
+ returnNat (Any IntRep mkcode)
+
+ | is_imm_a
+ = 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 isAny regb
+ then registerCode regb dst `bind` \ code_b ->
+ code_b `snocOL`
+ revinstr (OpImm imm_a) (OpReg dst)
+ else registerCodeF regb `bind` \ code_b ->
+ registerNameF regb `bind` \ r_b ->
+ code_b `snocOL`
+ MOV L (OpReg r_b) (OpReg dst) `snocOL`
+ revinstr (OpImm imm_a) (OpReg dst)
+
+ | otherwise
+ = if isAny regb
+ then registerCode regb tmp `bind` \ code_b ->
+ 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 `snocOL`
+ MOV L (OpReg r_b) (OpReg tmp) `snocOL`
+ MOV L (OpImm imm_a) (OpReg dst) `snocOL`
+ instr (OpReg tmp) (OpReg dst)
+ in
+ returnNat (Any IntRep mkcode)
+
+ | otherwise
+ = getRegister a `thenNat` \ rega ->
+ getRegister b `thenNat` \ regb ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let mkcode dst
+ = case (isAny rega, isAny regb) of
+ (True, True)
+ -> registerCode regb tmp `bind` \ code_b ->
+ registerCode rega dst `bind` \ code_a ->
+ 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 `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 `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 `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
+ returnNat (Any IntRep mkcode)
+
+ where
+ maybe_imm_a = maybeImm a
+ is_imm_a = maybeToBool maybe_imm_a
+ imm_a = case maybe_imm_a of Just imm -> imm
+
+ maybe_imm_b = maybeImm b
+ is_imm_b = maybeToBool maybe_imm_b
+ imm_b = case maybe_imm_b of Just imm -> imm
-trivialCode instr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- fixedname = registerName register1 eax
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = let
- code1 = registerCode register1 dst asmVoid
- src1 = registerName register1 dst
- in asmParThen [code1, code2] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpReg src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpReg src2) (OpReg src1))
- in
- returnUs (Any IntRep code__2)
-----------
trivialUCode instr x
- = getRegister x `thenUs` \ register ->
--- getNewRegNCG IntRep `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
let
--- fixedname = registerName register eax
- code__2 dst = let
- code = registerCode register dst
+ 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 _ instrr _ _ (StInd pk' mem) y
- = getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk instr _ _ _ x (StInd pk' mem)
- = getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- code__2 dst = let
- code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk _ _ _ instrpr x y
- = getRegister x `thenUs` \ register1 ->
- getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+trivialFCode pk instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
let
- pk1 = registerRep register1
- code1 = registerCode register1 st0 --tmp1
- src1 = registerName register1 st0 --tmp1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
- pk2 = registerRep register2
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr instrpr
- in
- returnUs (Any pk1 code__2)
+ 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
--------------
-trivialUFCode pk instr (StInd pk' mem)
- = getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
- instr]
+ -- be paranoid (and inefficient)
+ | otherwise
+ = code1 `snocOL` GMOV src1 tmp1 `appOL`
+ code2 `snocOL`
+ instr (primRepToSize pk) tmp1 src2 dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
+
+-------------
trivialUFCode pk instr x
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG pk `thenUs` \ tmp ->
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG pk `thenNat` \ tmp ->
let
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code . mkSeqInstrs [instr]
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `snocOL` instr src dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_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)
+ code__2 dst = code `snocOL` 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] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
+ code__2 dst = code1 `appOL` code2 `snocOL`
+ 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)
+ promote x = FxTOy F DF x tmp
pk1 = registerRep register1
code1 = registerCode register1 tmp1
code__2 dst =
if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+ code1 `appOL` code2 `snocOL`
+ instr (primRepToSize pk) src1 src2 dst
else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
- mkSeqInstr (instr DF tmp src2 dst)
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ instr DF tmp src2 dst
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
- mkSeqInstr (instr DF src1 tmp dst)
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ 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)
+ code__2 dst = code `snocOL` 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)
+ code__2 dst = code `snocOL` instr src dst
in
- returnUs (Any pk code__2)
+ returnNat (Any pk code__2)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
%* *
%************************************************************************
-@coerce(Int|Flt)Code@ are simple coercions that don't require any code
-to be generated. Here we just change the type on the Register passed
-on up. The code is machine-independent.
-
@coerce(Int2FP|FP2Int)@ are more complicated integer/float
conversions. We have to store temporaries in memory to move
between the integer and the floating point register sets.
+@coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
+pretend, on sparc at least, that double and float regs are seperate
+kinds, so the value has to be computed into one kind before being
+explicitly "converted" to live in the other kind.
+
\begin{code}
-coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
-coerceFltCode :: StixTree -> UniqSM Register
-
-coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
-coerceFP2Int :: StixTree -> UniqSM Register
-
-coerceIntCode pk x
- = getRegister x `thenUs` \ register ->
- returnUs (
- case register of
- Fixed _ reg code -> Fixed pk reg code
- Any _ code -> Any pk code
- )
+coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
+coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
--------------
-coerceFltCode x
- = getRegister x `thenUs` \ register ->
- returnUs (
- case register of
- Fixed _ reg code -> Fixed DoubleRep reg code
- Any _ code -> Any DoubleRep code
- )
+coerceDbl2Flt :: StixExpr -> NatM Register
+coerceFlt2Dbl :: StixExpr -> NatM Register
\end{code}
\begin{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
-
- code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
+ code__2 dst = code `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 ->
+coerceFP2Int fprep x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
pk = registerRep register
- code__2 dst = let
- in code . mkSeqInstrs [
- FRNDINT,
- FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
+ code__2 dst = code `snocOL` opc src dst
in
- returnUs (Any IntRep code__2)
+ returnNat (Any IntRep code__2)
+
+------------
+coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
+coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
#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
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code `appOL` toOL [
ST W src (spRel (-2)),
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 ->
+coerceFP2Int fprep x
+ = ASSERT(fprep == DoubleRep || fprep == FloatRep)
+ getRegister x `thenNat` \ register ->
+ getNewRegNCG fprep `thenNat` \ reg ->
+ getNewRegNCG FloatRep `thenNat` \ tmp ->
let
code = registerCode register reg
src = registerName register reg
- pk = registerRep register
-
- code__2 dst = code . mkSeqInstrs [
- FxTOy (primRepToSize pk) W src tmp,
+ code__2 dst = code `appOL` toOL [
+ FxTOy (primRepToSize fprep) W src tmp,
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
in
- returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Coercing integer to @Char@...}
-%* *
-%************************************************************************
-
-Integer to character conversion. Where applicable, we try to do this
-in one step if the original object is in memory.
-
-\begin{code}
-chrCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-
-chrCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ 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)
-
-#endif {- alpha_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-chrCode x
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- let
- fixedname = registerName register eax
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- 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
- 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 ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- src_off = addrOffset src 3
- src__2 = case src_off of Just x -> x
- code__2 dst = if maybeToBool src_off then
- code . mkSeqInstr (LD BU src__2 dst)
- else
- code . mkSeqInstrs [
- LD (primRepToSize pk) src dst,
- AND False dst (RIImm (ImmInt 255)) dst]
+------------
+coerceDbl2Flt x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
in
- returnUs (Any pk code__2)
+ returnNat (Any FloatRep
+ (\dst -> code `snocOL` FxTOy DF F src dst))
-chrCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+------------
+coerceFlt2Dbl x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG FloatRep `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
in
- returnUs (Any IntRep code__2)
+ returnNat (Any DoubleRep
+ (\dst -> code `snocOL` FxTOy F DF src dst))
#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Absolute value on integers}
-%* *
-%************************************************************************
-
-Absolute value on integers, mostly for gmp size check macros. Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-If applicable, do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-absIntCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-absIntCode = panic "MachCode.absIntCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
\end{code}
projects / ghc-hetmet.git / blobdiff