#include "HsVersions.h"
#include "nativeGen/NCG.h"
+import Unique ( Unique )
import MachMisc -- may differ per-platform
import MachRegs
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
snocOL, consOL, concatOL )
+import MachOp ( MachOp(..), pprMachOp )
import AbsCUtils ( magicIdPrimRep )
+import PprAbsC ( pprMagicId )
import ForeignCall ( CCallConv(..) )
-import CLabel ( isAsmTemp, CLabel, labelDynamic )
-import Maybes ( maybeToBool, expectJust )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
-import Stix ( getNatLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..),
+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,
- pprStixTree,
+ pprStixExpr, repOfStixExpr,
+ liftStrings,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
- getDeltaNat, setDeltaNat
+ getDeltaNat, setDeltaNat, getUniqueNat,
+ ncgPrimopMoan,
+ ncg_target_is_32bit
)
-import Outputable
+import Pretty
+import Outputable ( panic, pprPanic, showSDoc )
+import qualified Outputable
import CmdLineOpts ( opt_Static )
+import Stix ( pprStixStmt )
-infixr 3 `bind`
+-- DEBUGGING ONLY
+import IOExts ( trace )
+import Outputable ( assertPanic )
+import FastString
+infixr 3 `bind`
\end{code}
@InstrBlock@s are the insn sequences generated by the insn selectors.
order.
\begin{code}
-
type InstrBlock = OrdList Instr
x `bind` f = f x
+isLeft (Left _) = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
\end{code}
Code extractor for an entire stix tree---stix statement level.
\begin{code}
-stmtsToInstrs :: [StixTree] -> NatM InstrBlock
+stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
stmtsToInstrs stmts
- = liftStrings stmts [] [] `thenNat` \ lifted ->
- mapNat stmtToInstrs lifted `thenNat` \ instrss ->
+ = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
returnNat (concatOL instrss)
--- Lift StStrings out of top-level StDatas, putting them at the end of
--- the block, and replacing them with StCLbls which refer to the lifted-out strings.
-{- Motivation for this hackery provided by the following bug:
- Stix:
- (DataSegment)
- Bogon.ping_closure :
- (Data P_ Addr.A#_static_info)
- (Data StgAddr (Str `alalal'))
- (Data P_ (0))
- results in:
- .data
- .align 8
- .global Bogon_ping_closure
- Bogon_ping_closure:
- .long Addr_Azh_static_info
- .long .Ln1a8
- .Ln1a8:
- .byte 0x61
- .byte 0x6C
- .byte 0x61
- .byte 0x6C
- .byte 0x61
- .byte 0x6C
- .byte 0x00
- .long 0
- ie, the Str is planted in-line, when what we really meant was to place
- a _reference_ to the string there. liftStrings will lift out all such
- strings in top-level data and place them at the end of the block.
-
- This is still a rather half-baked solution -- to do the job entirely right
- would mean a complete traversal of all the Stixes, but there's currently no
- real need for it, and it would be slow. Also, potentially there could be
- literal types other than strings which need lifting out?
--}
-
-liftStrings :: [StixTree] -- originals
- -> [StixTree] -- (reverse) originals with strings lifted out
- -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
- -> NatM [StixTree]
-
--- First, examine the original trees and lift out strings in top-level StDatas.
-liftStrings (st:sts) acc_stix acc_strs
- = case st of
- StData sz datas
- -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
- liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
- other
- -> liftStrings sts (other:acc_stix) acc_strs
- where
- -- Handle a top-level StData
- lift [] acc_strs = returnNat ([], acc_strs)
- lift (d:ds) acc_strs
- = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
- case d of
- StString s
- -> getNatLabelNCG `thenNat` \ lbl ->
- returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
- other
- -> returnNat (other:ds_done, acc_strs1)
-
--- When we've run out of original trees, emit the lifted strings.
-liftStrings [] acc_stix acc_strs
- = returnNat (reverse acc_stix ++ concatMap f acc_strs)
- where
- f (lbl,str) = [StSegment RoDataSegment,
- StLabel lbl,
- StString str,
- StSegment TextSegment]
-
-
-stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
+stmtToInstrs :: StixStmt -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
StComment s -> returnNat (unitOL (COMMENT s))
StSegment seg -> returnNat (unitOL (SEGMENT seg))
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
- StCall fn cconv VoidRep args -> genCCall fn
- cconv VoidRep (map derefDLL args)
-
- StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
- | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
+ -- 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
returnNat (DATA (primRepToSize kind) imms
`consOL` concatOL codes)
where
- getData :: StixTree -> NatM (InstrBlock, Imm)
+ 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)
-- the linker can handle simple arithmetic...
getData (StIndex rep (StCLbl lbl) (StInt off)) =
returnNat (nilOL,
- ImmIndex lbl (fromInteger off * sizeOf rep))
+ ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
-- Top-level lifted-out string. The segment will already have been set
- -- (see liftStrings above).
- StString str
- -> returnNat (unitOL (ASCII True (_UNPK_ str)))
+ -- (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 :: StixTree -> StixTree
+derefDLL :: StixExpr -> StixExpr
derefDLL tree
| opt_Static -- short out the entire deal if not doing DLLs
= tree
else t
-- all the rest are boring
StIndex pk base offset -> StIndex pk (qq base) (qq offset)
- StPrim pk args -> StPrim pk (map qq args)
+ StMachOp mop args -> StMachOp mop (map qq args)
StInd pk addr -> StInd pk (qq addr)
- StCall who cc pk args -> StCall who cc pk (map qq args)
+ 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
- StScratchWord _ -> t
_ -> pprPanic "derefDLL: unhandled case"
- (pprStixTree t)
+ (pprStixExpr t)
\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 * toInteger (sizeOf pk))
+ off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
mangleIndexTree (StIndex pk base off)
- = StPrim IntAddOp [
+ = StMachOp MO_Nat_Add [
base,
let s = shift pk
- in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
- ]
+ in if s == 0 then off
+ else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
+ ]
where
shift :: PrimRep -> Int
- shift rep = case sizeOf rep of
+ shift rep = case getPrimRepArrayElemSize rep of
1 -> 0
2 -> 1
4 -> 2
8 -> 3
other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
- (int other)
+ (Outputable.int other)
\end{code}
\begin{code}
-maybeImm :: StixTree -> Maybe Imm
+maybeImm :: StixExpr -> Maybe Imm
maybeImm (StCLbl l)
= Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off))
- = Just (ImmIndex l (fromInteger off * sizeOf rep))
+ = 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 (Any _ code) reg = code reg
registerCodeF (Fixed _ _ code) = code
-registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
+registerCodeF (Any _ _) = panic "registerCodeF"
registerCodeA (Any _ code) = code
-registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
+registerCodeA (Fixed _ _ _) = panic "registerCodeA"
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
registerName (Any _ _) reg = reg
registerNameF (Fixed _ reg _) = reg
-registerNameF (Any _ _) = pprPanic "registerNameF" empty
+registerNameF (Any _ _) = panic "registerNameF"
registerRep :: Register -> PrimRep
registerRep (Fixed pk _ _) = pk
registerRep (Any pk _) = pk
+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 #-}
Generate code to get a subtree into a @Register@:
\begin{code}
-getRegister :: StixTree -> NatM Register
-getRegister (StReg (StixMagicId stgreg))
- = case (magicIdRegMaybe stgreg) of
- Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
- -- 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)
-getRegister (StReg (StixTemp u pk))
+getRegisterReg (StixTemp (StixVReg u pk))
= returnNat (Fixed pk (mkVReg u pk) nilOL)
-getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+-------------
+
+-- Don't delete this -- it's very handy for debugging.
+--getRegister expr
+-- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
+-- = panic "getRegister(???)"
+
+getRegister (StReg reg)
+ = getRegisterReg reg
+
+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
code dst = toOL [
SEGMENT RoDataSegment,
LABEL lbl,
- ASCII True (_UNPK_ s),
+ ASCII True (unpackFS s),
SEGMENT TextSegment,
#if alpha_TARGET_ARCH
LDA dst (AddrImm imm_lbl)
in
returnNat (Any PtrRep code)
-
-
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- end of machine-"independent" bit; here we go on the rest...
#if alpha_TARGET_ARCH
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"
AddrNeOp -> int_NE_code x y
AddrLtOp -> trivialCode (CMP ULT) x y
AddrLeOp -> trivialCode (CMP ULE) 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
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
ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv 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
imm__2 = case imm of Just x -> x
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
getRegister (StFloat f)
in
returnNat (Any DoubleRep code)
--- Calculate the offset for (i+1) words above the _initial_
--- %esp value by first determining the current offset of it.
-getRegister (StScratchWord i)
- | i >= 0 && i < 6
- = getDeltaNat `thenNat` \ current_stack_offset ->
- let j = i+1 - (current_stack_offset `div` 4)
- code dst
- = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
- in
- returnNat (Any PtrRep code)
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEGI L) 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 (GNEG F) x
- DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
+ MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
+ MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
- FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
- DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
+ MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
+ MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
- FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
- DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
+ MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
+ MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
- FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
- DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
+ MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
+ MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
- FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
- DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
+ MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
+ MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
- Double2FloatOp -> trivialUFCode FloatRep GDTOF x
- Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
+ 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
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
-
- other_op ->
- getRegister (StCall fn CCallConv DoubleRep [x])
- where
- (is_float_op, fn)
- = case primop of
- FloatExpOp -> (True, SLIT("exp"))
- FloatLogOp -> (True, SLIT("log"))
+ -- 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
- DoubleAsinOp -> (False, SLIT("asin"))
- DoubleAcosOp -> (False, SLIT("acos"))
- DoubleAtanOp -> (False, SLIT("atan"))
-
- DoubleSinhOp -> (False, SLIT("sinh"))
- DoubleCoshOp -> (False, SLIT("cosh"))
- DoubleTanhOp -> (False, SLIT("tanh"))
-
- other
- -> pprPanic "getRegister(x86,unary primop)"
- (pprStixTree (StPrim primop [x]))
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> condIntReg GTT x y
- CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQQ x y
- CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LTT x y
- CharLeOp -> condIntReg LE x y
-
- IntGtOp -> condIntReg GTT x y
- IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQQ x y
- IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LTT x y
- IntLeOp -> condIntReg LE x y
-
- WordGtOp -> condIntReg GU x y
- WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQQ x y
- WordNeOp -> condIntReg NE x y
- WordLtOp -> condIntReg LU x y
- WordLeOp -> condIntReg LEU x y
-
- AddrGtOp -> condIntReg GU x y
- AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQQ x y
- AddrNeOp -> condIntReg NE x y
- AddrLtOp -> condIntReg LU x y
- AddrLeOp -> condIntReg LEU x y
-
- FloatGtOp -> condFltReg GTT x y
- FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQQ x y
- FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LTT x y
- FloatLeOp -> condFltReg LE x y
-
- DoubleGtOp -> condFltReg GTT x y
- DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQQ x y
- DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LTT x y
- DoubleLeOp -> condFltReg LE x y
-
- IntAddOp -> add_code L x y
- IntSubOp -> sub_code L x y
- IntQuotOp -> trivialCode (IQUOT L) Nothing x y
- IntRemOp -> trivialCode (IREM L) Nothing x y
- IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
-
- WordAddOp -> add_code L x y
- WordSubOp -> sub_code L x y
- WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
-
- FloatAddOp -> trivialFCode FloatRep GADD x y
- FloatSubOp -> trivialFCode FloatRep GSUB x y
- FloatMulOp -> trivialFCode FloatRep GMUL x y
- FloatDivOp -> trivialFCode FloatRep GDIV x y
-
- DoubleAddOp -> trivialFCode DoubleRep GADD x y
- DoubleSubOp -> trivialFCode DoubleRep GSUB x y
- DoubleMulOp -> trivialFCode DoubleRep GMUL x y
- DoubleDivOp -> trivialFCode DoubleRep GDIV x y
-
- AndOp -> let op = AND L in trivialCode op (Just op) x y
- OrOp -> let op = OR L in trivialCode op (Just op) x y
- XorOp -> let op = XOR L in trivialCode op (Just op) x y
+ 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.)
- -}
-
- SllOp -> shift_code (SHL L) x y {-False-}
- SrlOp -> shift_code (SHR L) x y {-False-}
- ISllOp -> shift_code (SHL L) x y {-False-}
- ISraOp -> shift_code (SAR L) x y {-False-}
- ISrlOp -> shift_code (SHR L) x y {-False-}
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [promote x, promote y])
- where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [x, y])
- other
- -> pprPanic "getRegister(x86,dyadic primop)"
- (pprStixTree (StPrim primop [x, y]))
+ -}
+ 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]
+
+ --------------------
+ 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)
--------------------
shift_code :: (Imm -> Operand -> Instr)
- -> StixTree
- -> StixTree
+ -> StixExpr
+ -> StixExpr
-> NatM Register
{- Case1: shift length as immediate -}
code_val `snocOL`
MOV L (OpReg src_val) r_dst `appOL`
toOL [
- COMMENT (_PK_ "begin shift sequence"),
+ COMMENT (mkFastString "begin shift sequence"),
MOV L (OpReg src_val) r_dst,
MOV L (OpReg src_amt) r_tmp,
instr (ImmInt 1) r_dst,
LABEL lbl_after,
- COMMENT (_PK_ "end shift sequence")
+ COMMENT (mkFastString "end shift sequence")
]
in
returnNat (Any IntRep code__2)
--------------------
- add_code :: Size -> StixTree -> StixTree -> NatM Register
+ add_code :: Size -> StixExpr -> StixExpr -> NatM Register
add_code sz x (StInt y)
= getRegister x `thenNat` \ register ->
add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
--------------------
- sub_code :: Size -> StixTree -> StixTree -> NatM Register
+ sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
sub_code sz x (StInt y)
= getRegister x `thenNat` \ register ->
sub_code sz x y = trivialCode (SUB sz) Nothing x y
-
getRegister (StInd pk mem)
+ | not (is64BitRep pk)
= getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
in
returnNat (Any PtrRep code)
| otherwise
- = pprPanic "getRegister(x86)" (pprStixTree leaf)
+ = 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)
in
returnNat (Any DoubleRep code)
--- The 6-word scratch area is immediately below the frame pointer.
--- Below that is the spill area.
-getRegister (StScratchWord i)
- | i >= 0 && i < 6
- = let
- code dst = unitOL (fpRelEA (i-6) dst)
- in
- returnNat (Any PtrRep code)
+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)
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (SUB False False g0) x
- NotOp -> trivialUCode (XNOR False g0) x
+ MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
+ MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
+
+ MO_Dbl_to_Flt -> coerceDbl2Flt x
+ MO_Flt_to_Dbl -> coerceFlt2Dbl x
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
+ 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
- Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
- Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
+ -- Conversions which are a nop on sparc
+ MO_32U_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_32U -> conversionNop WordRep x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
+ 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
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
+ -- 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
other_op ->
- let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
+ let fixed_x = if is_float_op -- promote to double
+ then StMachOp MO_Flt_to_Dbl [x]
+ else x
in
- getRegister (StCall fn CCallConv DoubleRep [fixed_x])
- where
- (is_float_op, fn)
- = case primop of
- FloatExpOp -> (True, SLIT("exp"))
- FloatLogOp -> (True, SLIT("log"))
- FloatSqrtOp -> (True, SLIT("sqrt"))
-
- FloatSinOp -> (True, SLIT("sin"))
- FloatCosOp -> (True, SLIT("cos"))
- FloatTanOp -> (True, SLIT("tan"))
-
- FloatAsinOp -> (True, SLIT("asin"))
- FloatAcosOp -> (True, SLIT("acos"))
- FloatAtanOp -> (True, SLIT("atan"))
-
- FloatSinhOp -> (True, SLIT("sinh"))
- FloatCoshOp -> (True, SLIT("cosh"))
- FloatTanhOp -> (True, SLIT("tanh"))
-
- DoubleExpOp -> (False, SLIT("exp"))
- DoubleLogOp -> (False, SLIT("log"))
- DoubleSqrtOp -> (False, SLIT("sqrt"))
-
- DoubleSinOp -> (False, SLIT("sin"))
- DoubleCosOp -> (False, SLIT("cos"))
- DoubleTanOp -> (False, SLIT("tan"))
-
- DoubleAsinOp -> (False, SLIT("asin"))
- DoubleAcosOp -> (False, SLIT("acos"))
- DoubleAtanOp -> (False, SLIT("atan"))
-
- DoubleSinhOp -> (False, SLIT("sinh"))
- DoubleCoshOp -> (False, SLIT("cosh"))
- DoubleTanhOp -> (False, SLIT("tanh"))
-
- other
- -> pprPanic "getRegister(sparc,monadicprimop)"
- (pprStixTree (StPrim primop [x]))
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> condIntReg GTT x y
- CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQQ x y
- CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LTT x y
- CharLeOp -> condIntReg LE x y
-
- IntGtOp -> condIntReg GTT x y
- IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQQ x y
- IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LTT x y
- IntLeOp -> condIntReg LE x y
-
- WordGtOp -> condIntReg GU x y
- WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQQ x y
- WordNeOp -> condIntReg NE x y
- WordLtOp -> condIntReg LU x y
- WordLeOp -> condIntReg LEU x y
-
- AddrGtOp -> condIntReg GU x y
- AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQQ x y
- AddrNeOp -> condIntReg NE x y
- AddrLtOp -> condIntReg LU x y
- AddrLeOp -> condIntReg LEU x y
-
- FloatGtOp -> condFltReg GTT x y
- FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQQ x y
- FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LTT x y
- FloatLeOp -> condFltReg LE x y
-
- DoubleGtOp -> condFltReg GTT x y
- DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQQ x y
- DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LTT 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
-
- WordAddOp -> trivialCode (ADD False False) x y
- WordSubOp -> trivialCode (SUB False False) x y
- WordMulOp -> imul_div SLIT(".umul") 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
- XorOp -> trivialCode (XOR False) x y
- SllOp -> trivialCode SLL x y
- SrlOp -> trivialCode SRL x y
-
- ISllOp -> trivialCode SLL x y
- ISraOp -> trivialCode SRA x y
- ISrlOp -> trivialCode SRL x y
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [promote x, promote y])
- where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [x, y])
-
- other
- -> pprPanic "getRegister(sparc,dyadic primop)"
- (pprStixTree (StPrim primop [x, y]))
+ 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)
+ (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 CCallConv 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 `thenNat` \ amode ->
in
returnNat (Any PtrRep code)
| otherwise
- = pprPanic "getRegister(sparc)" (pprStixTree leaf)
+ = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
\end{code}
%************************************************************************
... (tmp) ...
\begin{code}
-getAmode :: StixTree -> NatM Amode
+getAmode :: StixExpr -> NatM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if alpha_TARGET_ARCH
getAmode (StPrim IntSubOp [x, StInt i])
returnNat (Amode (AddrReg reg) code)
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
-getAmode (StPrim IntSubOp [x, StInt i])
+-- 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
in
returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
| maybeToBool imm
= 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])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getRegister x `thenNat` \ register ->
let
in
returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
+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 ->
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 `thenNat` \ tmp ->
getRegister x `thenNat` \ register ->
returnNat (Amode (AddrRegImm reg off) code)
-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
| fits13Bits i
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getRegister x `thenNat` \ register ->
in
returnNat (Amode (AddrRegImm reg off) code)
-getAmode (StPrim IntAddOp [x, y])
+getAmode (StMachOp MO_Nat_Add [x, y])
= getNewRegNCG PtrRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
getRegister x `thenNat` \ register1 ->
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 -> NatM 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 GTT x y
- CharGeOp -> condIntCode GE x y
- CharEqOp -> condIntCode EQQ x y
- CharNeOp -> condIntCode NE x y
- CharLtOp -> condIntCode LTT 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 GTT x y
- IntGeOp -> condIntCode GE x y
- IntEqOp -> condIntCode EQQ x y
- IntNeOp -> condIntCode NE x y
- IntLtOp -> condIntCode LTT x y
- IntLeOp -> condIntCode LE x y
-
- WordGtOp -> condIntCode GU x y
- WordGeOp -> condIntCode GEU x y
- WordEqOp -> condIntCode EQQ x y
- WordNeOp -> condIntCode NE x y
- WordLtOp -> condIntCode LU x y
- WordLeOp -> condIntCode LEU x y
-
- AddrGtOp -> condIntCode GU x y
- AddrGeOp -> condIntCode GEU x y
- AddrEqOp -> condIntCode EQQ x y
- AddrNeOp -> condIntCode NE x y
- AddrLtOp -> condIntCode LU x y
- AddrLeOp -> condIntCode LEU x y
-
- FloatGtOp -> condFltCode GTT x y
- FloatGeOp -> condFltCode GE x y
- FloatEqOp -> condFltCode EQQ x y
- FloatNeOp -> condFltCode NE x y
- FloatLtOp -> condFltCode LTT x y
- FloatLeOp -> condFltCode LE x y
-
- DoubleGtOp -> condFltCode GTT x y
- DoubleGeOp -> condFltCode GE x y
- DoubleEqOp -> condFltCode EQQ x y
- DoubleNeOp -> condFltCode NE x y
- DoubleLtOp -> condFltCode LTT 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 -> NatM CondCode
+condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
-- memory vs immediate
condIntCode cond (StInd pk x) y
- | maybeToBool imm
+ | Just i <- maybeImm y
= getAmode x `thenNat` \ amode ->
let
code1 = amodeCode amode
x__2 = amodeAddr amode
sz = primRepToSize pk
code__2 = code1 `snocOL`
- CMP sz (OpImm imm__2) (OpAddr x__2)
+ CMP sz (OpImm i) (OpAddr x__2)
in
returnNat (CondCode False cond code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-- anything vs zero
condIntCode cond x (StInt 0)
-- anything vs immediate
condIntCode cond x y
- | maybeToBool imm
+ | Just i <- maybeImm y
= getRegister x `thenNat` \ register1 ->
getNewRegNCG IntRep `thenNat` \ tmp1 ->
let
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
code__2 = code1 `snocOL`
- CMP L (OpImm imm__2) (OpReg src1)
+ CMP L (OpImm i) (OpReg src1)
in
returnNat (CondCode False cond code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-- memory vs anything
condIntCode cond (StInd pk x) y
-----------
condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
+ = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
+ getRegister x `thenNat` \ register1 ->
getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
`thenNat` \ tmp1 ->
`thenNat` \ tmp2 ->
getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
- pk1 = registerRep register1
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
code__2 | isAny register1
= code1 `appOL` -- result in tmp1
code2 `snocOL`
- GCMP (primRepToSize pk1) tmp1 src2
+ GCMP cond tmp1 src2
| otherwise
= code1 `snocOL`
GMOV src1 tmp1 `appOL`
code2 `snocOL`
- GCMP (primRepToSize pk1) tmp1 src2
-
- {- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
- -}
- fix_FP_cond :: Cond -> Cond
-
- fix_FP_cond GE = GEU
- fix_FP_cond GTT = GU
- fix_FP_cond LTT = LU
- fix_FP_cond LE = LEU
- fix_FP_cond any = any
+ GCMP cond tmp1 src2
in
- returnNat (CondCode True (fix_FP_cond cond) code__2)
-
-
+ -- 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)
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 -> NatM 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
returnNat code__2
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
--- Destination of an assignment can only be reg or mem.
--- This is the mem case.
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenNat` \ amode ->
+-- 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
= codesrc `snocOL`
MOV (primRepToSize pk) opsrc (OpAddr dst__a)
| otherwise
-
= codea `snocOL`
LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
codesrc `snocOL`
returnNat code
where
get_op_RI
- :: StixTree
+ :: StixExpr
-> NatM (InstrBlock,Operand) -- code, operator
get_op_RI op
- | maybeToBool imm
- = returnNat (nilOL, OpImm imm_op)
- 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 `thenNat` \ register ->
returnNat (code, OpReg reg)
-- Assign; dst is a reg, rhs is mem
-assignIntCode pk dst (StInd pks src)
+assignReg_IntCode pk reg (StInd pks src)
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getAmode src `thenNat` \ amode ->
- getRegister dst `thenNat` \ reg_dst ->
+ getRegisterReg reg `thenNat` \ reg_dst ->
let
c_addr = amodeCode amode
am_addr = amodeAddr amode
-
- c_dst = registerCode reg_dst tmp -- should be empty
r_dst = registerName reg_dst tmp
szs = primRepToSize pks
opc = case szs of
L -> MOV L
Lu -> MOV L
- code | isNilOL c_dst
- = c_addr `snocOL`
+ code = c_addr `snocOL`
opc (OpAddr am_addr) (OpReg r_dst)
- | otherwise
- = pprPanic "assignIntCode(x86): bad dst(2)" empty
in
returnNat code
-- dst is a reg, but src could be anything
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ registerd ->
+assignReg_IntCode pk reg src
+ = getRegisterReg reg `thenNat` \ registerd ->
getRegister src `thenNat` \ registers ->
getNewRegNCG IntRep `thenNat` \ tmp ->
let
r_dst = registerName registerd tmp
- c_dst = registerCode registerd tmp -- should be empty
r_src = registerName registers r_dst
c_src = registerCode registers r_dst
- code | isNilOL c_dst
- = c_src `snocOL`
+ code = c_src `snocOL`
MOV L (OpReg r_src) (OpReg r_dst)
- | otherwise
- = pprPanic "assignIntCode(x86): bad dst(3)" empty
in
returnNat code
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
-assignIntCode pk (StInd _ dst) src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
+assignMem_IntCode pk addr src
+ = getNewRegNCG IntRep `thenNat` \ tmp ->
+ getAmode addr `thenNat` \ amode ->
getRegister src `thenNat` \ register ->
let
code1 = amodeCode amode
in
returnNat code__2
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ 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
returnNat code__2
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
% --------------------------------
Floating-point assignments:
% --------------------------------
+
\begin{code}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
assignFltCode pk (StInd _ dst) src
returnNat code__2
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
--- dst is memory
-assignFltCode pk (StInd pk_dst addr) src
- | pk /= pk_dst
- = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
- | otherwise
+-- 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 ->
in
returnNat code
--- dst must be a (FP) register
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ reg_dst ->
+-- 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
- c_dst = registerCode reg_dst tmp -- should be empty
-
r_src = registerName reg_src r_dst
c_src = registerCode reg_src r_dst
- code | isNilOL c_dst
- = if isFixed reg_src
+ code = if isFixed reg_src
then c_src `snocOL` GMOV r_src r_dst
else c_src
- | otherwise
- = pprPanic "assignFltCode(x86): lhs is not mem or reg"
- empty
in
returnNat code
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
-assignFltCode pk (StInd _ dst) src
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
= getNewRegNCG pk `thenNat` \ tmp1 ->
- getAmode dst `thenNat` \ amode ->
+ getAmode addr `thenNat` \ amode ->
getRegister src `thenNat` \ register ->
let
sz = primRepToSize pk
in
returnNat code__2
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
+-- 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
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
-
code__2 =
if pk /= pk__2 then
code `snocOL` FxTOy sz__2 sz src__2 dst__2
returnNat code__2
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
register allocator.
\begin{code}
-genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
genJump dsts (StInd pk mem)
target = case imm of Just x -> x
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
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 target 0 True, NOP])
+ | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
where
target = ImmCLbl lbl
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
+ -> StixExpr -- the condition on which to branch
-> NatM InstrBlock
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if alpha_TARGET_ARCH
genCondJump lbl (StPrim op [x, StInt 0])
AddrLeOp -> (CMP ULE, NE)
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
genCondJump lbl bool
returnNat (code `snocOL` JXX cond lbl)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
genCondJump lbl bool
)
#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)
+ -> [StixExpr] -- arguments (of mixed type)
-> NatM InstrBlock
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if alpha_TARGET_ARCH
genCCall fn cconv kind args
returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
#endif {- alpha_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-genCCall fn cconv kind [StInt i]
- | fn == SLIT ("PerformGC_wrapper")
- = let call = toOL [
- MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- CALL (ImmLit (ptext (if underscorePrefix
- then (SLIT ("_PerformGC_wrapper"))
- else (SLIT ("PerformGC_wrapper")))))
- ]
- in
- returnNat call
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
-genCCall fn cconv kind args
- = mapNat get_call_arg
- (reverse args) `thenNat` \ sizes_n_codes ->
- getDeltaNat `thenNat` \ delta ->
- let (sizes, codes) = unzip sizes_n_codes
- tot_arg_size = sum sizes
- code2 = concatOL codes
- call = toOL (
- [CALL (fn__2 tot_arg_size)]
- ++
+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 (code2 `appOL` call)
+ returnNat (push_code `appOL` 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_u = _UNPK_ fn
+ fn_u = unpackFS (unLeft fn)
fn__2 tot_arg_size
| head fn_u == '.'
= ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
arg_size _ = 4
------------
- get_call_arg :: StixTree{-current argument-}
+ push_arg :: StixExpr{-current argument-}
-> NatM (Int, InstrBlock) -- argsz, code
- get_call_arg arg
- = get_op arg `thenNat` \ (code, reg, sz) ->
- getDeltaNat `thenNat` \ delta ->
- arg_size sz `bind` \ size ->
- setDeltaNat (delta-size) `thenNat` \ _ ->
+ 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`
PUSH L (OpReg reg) `snocOL`
DELTA (delta-size)
)
+ where
+ arg_rep = repOfStixExpr arg
+
------------
get_op
- :: StixTree
+ :: StixExpr
-> NatM (InstrBlock, Reg, Size) -- code, reg, size
get_op op
returnNat (code, reg, sz)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
{-
The SPARC calling convention is an absolute
genCCall fn cconv kind args
= mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
- let (argcodes, vregss) = unzip argcode_and_vregs
- argcode = concatOL argcodes
- vregs = concat vregss
+ 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)
else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
transfer_code
= toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
- call
- = unitOL (CALL fn__2 n_argRegs_used False)
in
returnNat (argcode `appOL`
move_sp_down `appOL`
transfer_code `appOL`
- call `appOL`
+ callinsns `appOL`
unitOL NOP `appOL`
move_sp_up)
where
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (ptext fn)
- _ -> ImmLab False (ptext fn)
+ 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.
-- generate code to calculate an argument, and move it into one
-- or two integer vregs.
- arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
+ 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
[v1]
)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
register allocator.
\begin{code}
-condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM 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
returnNat (Any IntRep code__2)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
condIntReg EQQ x (StInt 0)
returnNat (Any IntRep code__2)
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
%************************************************************************
-> Maybe (Operand -> Operand -> Instr)
,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
+ -> StixExpr -> StixExpr -- the two arguments
-> NatM Register
trivialFCode
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
+ -> StixExpr -> StixExpr -- the two arguments
-> NatM Register
trivialUCode
,IF_ARCH_i386 ((Operand -> Instr)
,IF_ARCH_sparc((RI -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
+ -> StixExpr -- the one argument
-> NatM Register
trivialUFCode
,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
+ -> StixExpr -- the one argument
-> NatM Register
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if alpha_TARGET_ARCH
trivialCode instr x (StInt y)
returnNat (Any DoubleRep code__2)
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
\end{code}
The Rules of the Game are:
returnNat (Any pk code__2)
#endif {- i386_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if sparc_TARGET_ARCH
trivialCode instr x (StInt y)
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.
-\begin{code}
-coerceIntCode :: PrimRep -> StixTree -> NatM Register
-coerceFltCode :: StixTree -> NatM Register
-
-coerceInt2FP :: PrimRep -> StixTree -> NatM Register
-coerceFP2Int :: StixTree -> NatM Register
+@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.
-coerceIntCode pk x
- = getRegister x `thenNat` \ register ->
- returnNat (
- case register of
- Fixed _ reg code -> Fixed pk reg code
- Any _ code -> Any pk code
- )
+\begin{code}
+coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
+coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
--------------
-coerceFltCode x
- = getRegister x `thenNat` \ register ->
- returnNat (
- 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
returnNat (Any IntRep code__2)
#endif {- alpha_TARGET_ARCH -}
+
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
#if i386_TARGET_ARCH
coerceInt2FP pk x
returnNat (Any pk code__2)
------------
-coerceFP2Int x
+coerceFP2Int fprep x
= getRegister x `thenNat` \ register ->
getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
in
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
returnNat (Any pk code__2)
------------
-coerceFP2Int x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
+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 `appOL` toOL [
- FxTOy (primRepToSize pk) W src tmp,
+ FxTOy (primRepToSize fprep) W src tmp,
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
in
returnNat (Any IntRep code__2)
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Coercing integer to @Char@...}
-%* *
-%************************************************************************
-
-Integer to character conversion.
-
-\begin{code}
-chrCode :: StixTree -> NatM Register
-
-#if alpha_TARGET_ARCH
-
--- TODO: This is probably wrong, but I don't know Alpha assembler.
--- It should coerce a 64-bit value to a 32-bit value.
-
-chrCode x
+------------
+coerceDbl2Flt x
= getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
in
- returnNat (Any IntRep code__2)
+ returnNat (Any FloatRep
+ (\dst -> code `snocOL` FxTOy DF F src dst))
-#endif {- alpha_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-chrCode x
- = getRegister x `thenNat` \ register ->
- returnNat (
- case register of
- Fixed _ reg code -> Fixed IntRep reg code
- Any _ code -> Any IntRep code
- )
-
-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
-chrCode x
+------------
+coerceFlt2Dbl x
= getRegister x `thenNat` \ register ->
- returnNat (
- case register of
- Fixed _ reg code -> Fixed IntRep reg code
- Any _ code -> Any IntRep code
- )
+ getNewRegNCG FloatRep `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ in
+ returnNat (Any DoubleRep
+ (\dst -> code `snocOL` FxTOy F DF src dst))
#endif {- sparc_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
projects / ghc-hetmet.git / blobdiff