+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[MachCode]{Generating machine code}
-
-This is a big module, but, if you pay attention to
-(a) the sectioning, (b) the type signatures, and
-(c) the \tr{#if blah_TARGET_ARCH} things, the
-structure should not be too overwhelming.
-
-\begin{code}
-module MachCode ( stmtsToInstrs, InstrBlock ) where
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-import MachMisc -- may differ per-platform
-import MachRegs
-import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
- snocOL, consOL, concatOL )
-import MachOp ( MachOp(..), pprMachOp )
-import AbsCUtils ( magicIdPrimRep )
-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(..),
-#if powerpc_TARGET_ARCH
- getPrimRepSize,
-#endif
- getPrimRepSizeInBytes )
-import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
- StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
- DestInfo, hasDestInfo,
- pprStixExpr, repOfStixExpr,
- NatM, thenNat, returnNat, mapNat,
- mapAndUnzipNat, mapAccumLNat,
- getDeltaNat, setDeltaNat,
- IF_ARCH_powerpc(addImportNat COMMA,)
- ncgPrimopMoan,
- ncg_target_is_32bit
- )
-import Pretty
-import Outputable ( panic, pprPanic, showSDoc )
-import qualified Outputable
-import CmdLineOpts ( opt_Static )
-import Stix ( pprStixStmt )
-
-import Maybe ( fromMaybe )
-
--- DEBUGGING ONLY
-import Outputable ( assertPanic )
-import FastString
-import TRACE ( trace )
-
-infixr 3 `bind`
-\end{code}
-
-@InstrBlock@s are the insn sequences generated by the insn selectors.
-They are really trees of insns to facilitate fast appending, where a
-left-to-right traversal (pre-order?) yields the insns in the correct
-order.
-
-\begin{code}
-type InstrBlock = OrdList Instr
-
-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 :: [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)))
- ,returnNat nilOL)
-
- StData kind args
- -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
- returnNat (DATA (primRepToSize kind) imms
- `consOL` concatOL codes)
- where
- 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 * getPrimRepSizeInBytes 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}
-
-%************************************************************************
-%* *
-\subsection{General things for putting together code sequences}
-%* *
-%************************************************************************
-
-\begin{code}
-mangleIndexTree :: StixExpr -> StixExpr
-
-mangleIndexTree (StIndex pk base (StInt i))
- = StMachOp MO_Nat_Add [base, off]
- where
- off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
-
-mangleIndexTree (StIndex pk base off)
- = 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 :: PrimRep -> Int
- shift rep = case getPrimRepSizeInBytes 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 :: StixExpr -> Maybe Imm
-
-maybeImm (StCLbl l)
- = Just (ImmCLbl l)
-maybeImm (StIndex rep (StCLbl l) (StInt off))
- = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
-maybeImm (StInt i)
- | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
- = Just (ImmInt (fromInteger i))
- | otherwise
- = Just (ImmInteger i)
-
-maybeImm _ = Nothing
-\end{code}
-
-%************************************************************************
-%* *
-\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 */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if powerpc_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 = MR r_dst_lo r_src_lo
- mov_hi = MR r_dst_hi r_src_hi
- in
- returnNat (
- vcode `snocOL` mov_hi `snocOL` mov_lo
- )
-assignReg_I64Code lvalue valueTree
- = pprPanic "assignReg_I64Code(powerpc): 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 rhi (AddrRegImm reg_addr (ImmInt 0))
- mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
- 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 = MR r_dst_lo r_src_lo
- mov_hi = MR r_dst_hi r_src_hi
- 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 = MR r_dst_lo r4
- mov_hi = MR r_dst_hi r3
- in
- returnNat (
- ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
- (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 expr
- = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @Register@ type}
-%* *
-%************************************************************************
-
-@Register@s passed up the tree. If the stix code forces the register
-to live in a pre-decided machine register, it comes out as @Fixed@;
-otherwise, it comes out as @Any@, and the parent can decide which
-register to put it in.
-
-\begin{code}
-data Register
- = Fixed PrimRep Reg InstrBlock
- | Any PrimRep (Reg -> InstrBlock)
-
-registerCode :: Register -> Reg -> InstrBlock
-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
-
-registerNameF (Fixed _ reg _) = reg
-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 #-}
-{-# 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}
-
-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)
-
--------------
-
--- 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
- reg = if isFloatingRep kind
- then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
- else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
-
-getRegister (StString s)
- = getNatLabelNCG `thenNat` \ lbl ->
- let
- imm_lbl = ImmCLbl lbl
-
- code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- ASCII True (unpackFS 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
-#if powerpc_TARGET_ARCH
- LIS dst (HI imm_lbl),
- OR dst dst (RIImm (LO imm_lbl))
-#endif
- ]
- in
- returnNat (Any PtrRep code)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
--- end of machine-"independent" bit; here we go on the rest...
-
-#if alpha_TARGET_ARCH
-
-getRegister (StDouble d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA TF [ImmLab (rational d)],
- SEGMENT TextSegment,
- LDA tmp (AddrImm (ImmCLbl lbl)),
- LD TF dst (AddrReg tmp)]
- in
- returnNat (Any DoubleRep code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEG Q False) x
-
- NotOp -> trivialUCode NOT x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
-
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP pr x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP pr x
-
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
- other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
- where
- fn = case other_op of
- 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 LTT) y x
- CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQQ) x y
- CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LTT) x y
- CharLeOp -> trivialCode (CMP LE) x y
-
- IntGtOp -> trivialCode (CMP LTT) y x
- IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQQ) x y
- IntNeOp -> int_NE_code 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 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 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) 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) 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
- IntSubOp -> trivialCode (SUB Q False) x y
- IntMulOp -> trivialCode (MUL 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
- FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
-
- DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
- DoubleSubOp -> trivialFCode DoubleRep (FSUB 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
- SrlOp -> trivialCode SRL x y
-
- 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 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
- registers. Integer non-equality is a test for equality
- followed by an XOR with 1. (Integer comparisons always set
- the result register to 0 or 1.) Floating point comparisons of
- any kind leave the result in a floating point register, so we
- need to wrangle an integer register out of things.
- -}
- int_NE_code :: StixTree -> StixTree -> NatM Register
-
- int_NE_code x y
- = 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
- returnNat (Any IntRep code__2)
-
- {- ------------------------------------------------------------
- Comments for int_NE_code also apply to cmpF_code
- -}
- cmpF_code
- :: (Reg -> Reg -> Reg -> Instr)
- -> Cond
- -> StixTree -> StixTree
- -> NatM Register
-
- cmpF_code instr cond x y
- = 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 zeroh (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zeroh (RIReg zeroh) dst,
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
- ------------------------------------------------------------
-
-getRegister (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code . mkSeqInstr (LD size dst src)
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits8Bits i
- = let
- code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
- in
- returnNat (Any IntRep code)
- | otherwise
- = let
- code dst = mkSeqInstr (LDI Q dst src)
- in
- returnNat (Any IntRep code)
- where
- src = ImmInt (fromInteger i)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
- in
- 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 (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
- returnNat (Any FloatRep code)
-
-
-getRegister (StDouble d)
-
- | 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 [ImmDouble d],
- SEGMENT TextSegment,
- GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
- ]
- in
- returnNat (Any DoubleRep code)
-
-
-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
-
- MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
- MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
-
- MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
- MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
-
- MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
- MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
-
- MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
- MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
-
- MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
- MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN 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
-
- -- Conversions which are a nop on x86
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32S_to_NatS -> conversionNop IntRep x
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatU -> conversionNop WordRep 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
-
- MO_Dbl_to_Flt -> conversionNop FloatRep x
- MO_Flt_to_Dbl -> conversionNop DoubleRep x
-
- -- 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
-
- 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]
-
- --------------------
- 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)
- -> 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)
-
- --------------------
- add_code :: Size -> StixExpr -> StixExpr -> NatM Register
-
- add_code sz x (StInt y)
- = 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 `snocOL`
- LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst)
- in
- returnNat (Any IntRep code__2)
-
- add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
-
- --------------------
- sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
-
- sub_code sz x (StInt y)
- = 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 `snocOL`
- LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst)
- in
- returnNat (Any IntRep code__2)
-
- 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
- src = amodeAddr amode
- size = primRepToSize pk
- 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
- | i == 0
- = unitOL (XOR L (OpReg dst) (OpReg dst))
- | otherwise
- = unitOL (MOV L (OpImm src) (OpReg dst))
- in
- returnNat (Any IntRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
- in
- 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)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA DF [ImmDouble d],
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) tmp,
- LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
- in
- returnNat (Any DoubleRep 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)
-
- 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
-
- 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
-
- -- Conversions which are a nop on sparc
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32S_to_NatS -> conversionNop IntRep x
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatU -> conversionNop WordRep 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
-
- -- 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 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)
-
- (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
- 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 ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code `snocOL` LD size src dst
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits13Bits i
- = let
- src = ImmInt (fromInteger i)
- code dst = unitOL (OR False g0 (RIImm src) dst)
- in
- returnNat (Any IntRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = toOL [
- SETHI (HI imm__2) dst,
- OR False dst (RIImm (LO imm__2)) dst]
- in
- 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 */
-
-#if powerpc_TARGET_ARCH
-getRegister (StMachOp mop [x]) -- unary MachOps
- = case mop of
- MO_NatS_Neg -> trivialUCode NEG x
- MO_Nat_Not -> trivialUCode NOT x
- MO_32U_to_8U -> trivialCode AND x (StInt 255)
-
- 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
-
- -- Conversions which are a nop on PPC
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32U_to_NatU -> conversionNop WordRep 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
-
- MO_Dbl_to_Flt -> conversionNop FloatRep x
- MO_Flt_to_Dbl -> conversionNop DoubleRep x
-
- -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
- 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
-
- MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
- MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
-
- other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [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(powerpc) - unary StMachOp"
- (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 x y
- MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
- case y of -- subfi ('substract from' with immediate) doesn't exist
- StInt imm -> if fits16Bits imm && imm /= (-32768)
- then Just $ trivialCode ADD x (StInt (-imm))
- else Nothing
- _ -> Nothing
-
- MO_NatS_Mul -> trivialCode MULLW x y
- MO_NatU_Mul -> trivialCode MULLW x y
- -- MO_NatS_MulMayOflo ->
-
- MO_NatS_Quot -> trivialCode2 DIVW x y
- MO_NatU_Quot -> trivialCode2 DIVWU x y
-
- MO_NatS_Rem -> remainderCode DIVW x y
- MO_NatU_Rem -> remainderCode DIVWU x y
-
- MO_Nat_And -> trivialCode AND x y
- MO_Nat_Or -> trivialCode OR x y
- MO_Nat_Xor -> trivialCode XOR x y
-
- MO_Nat_Shl -> trivialCode SLW x y
- MO_Nat_Shr -> trivialCode SRW x y
- MO_Nat_Sar -> trivialCode SRAW 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_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
- MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
-
- other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
-
-getRegister (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code `snocOL` LD size dst src
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits16Bits i
- = let
- src = ImmInt (fromInteger i)
- code dst = unitOL (LI dst src)
- in
- returnNat (Any IntRep code)
-
-getRegister (StFloat d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA F [ImmFloat d],
- SEGMENT TextSegment,
- LIS tmp (HA (ImmCLbl lbl)),
- LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
- in
- returnNat (Any FloatRep code)
-
-getRegister (StDouble d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA DF [ImmDouble d],
- SEGMENT TextSegment,
- LIS tmp (HA (ImmCLbl lbl)),
- LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
- in
- returnNat (Any DoubleRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = toOL [
- LIS dst (HI imm__2),
- OR dst dst (RIImm (LO imm__2))]
- in
- returnNat (Any PtrRep code)
- | otherwise
- = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @Amode@ type}
-%* *
-%************************************************************************
-
-@Amode@s: Memory addressing modes passed up the tree.
-\begin{code}
-data Amode = Amode MachRegsAddr InstrBlock
-
-amodeAddr (Amode addr _) = addr
-amodeCode (Amode _ code) = code
-\end{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 :: StixExpr -> NatM Amode
-
-getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [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
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [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
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | maybeToBool imm
- = returnNat (Amode (AddrImm imm__2) id)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- returnNat (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
--- 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
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-
-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 (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
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-
-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
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- reg2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2
- base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
- in
- returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
- code__2)
-
-getAmode leaf
- | maybeToBool imm
- = returnNat (Amode (ImmAddr imm__2 0) nilOL)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-getAmode (StMachOp MO_Nat_Sub [x, StInt i])
- | fits13Bits (-i)
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- | fits13Bits i
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-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
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- reg2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2
- in
- returnNat (Amode (AddrRegReg reg1 reg2) code__2)
-
-getAmode leaf
- | maybeToBool imm
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = unitOL (SETHI (HI imm__2) tmp)
- in
- returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt 0
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-#endif /* sparc_TARGET_ARCH */
-
-#ifdef powerpc_TARGET_ARCH
-getAmode (StMachOp MO_Nat_Sub [x, StInt i])
- | fits16Bits (-i)
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- | fits16Bits i
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | maybeToBool imm
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = unitOL (LIS tmp (HA imm__2))
- in
- returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt 0
- in
- returnNat (Amode (AddrRegImm reg off) code)
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @CondCode@ type}
-%* *
-%************************************************************************
-
-Condition codes passed up the tree.
-\begin{code}
-data CondCode = CondCode Bool Cond InstrBlock
-
-condName (CondCode _ cond _) = cond
-condFloat (CondCode is_float _ _) = is_float
-condCode (CondCode _ _ code) = code
-\end{code}
-
-Set up a condition code for a conditional branch.
-
-\begin{code}
-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 || powerpc_TARGET_ARCH
--- yes, they really do seem to want exactly the same!
-
-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
-
- 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,powerpc)" (pprMachOp mop)
-
-getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
-
-#endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
-
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-% -----------------
-
-@cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-passed back up the tree.
-
-\begin{code}
-condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
-
-#if alpha_TARGET_ARCH
-condIntCode = panic "MachCode.condIntCode: not on Alphas"
-condFltCode = panic "MachCode.condFltCode: not on Alphas"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
--- memory vs immediate
-condIntCode cond (StInd pk x) y
- | 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 i) (OpAddr x__2)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs zero
-condIntCode cond x (StInt 0)
- = getRegister x `thenNat` \ register1 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code__2 = code1 `snocOL`
- TEST L (OpReg src1) (OpReg src1)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs immediate
-condIntCode cond x y
- | 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 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 `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `snocOL`
- MOV L (OpReg src1) (OpReg tmp1) `appOL`
- code2 `snocOL`
- CMP L (OpReg src2) (OpReg tmp1)
- in
- returnNat (CondCode False cond code__2)
-
------------
-condFltCode cond x y
- = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
- getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- 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 `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
- in
- returnNat (CondCode False cond code__2)
-
-condIntCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- SUB False True src1 (RIReg src2) g0
- in
- returnNat (CondCode False cond code__2)
-
------------
-condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 =
- if pk1 == pk2 then
- code1 `appOL` code2 `snocOL`
- FCMP True (primRepToSize pk1) src1 src2
- else if pk1 == FloatRep then
- code1 `snocOL` promote src1 `appOL` code2 `snocOL`
- FCMP True DF tmp src2
- else
- code1 `appOL` code2 `snocOL` promote src2 `snocOL`
- FCMP True DF src1 tmp
- in
- returnNat (CondCode True cond code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-condIntCode cond x (StInt y)
- | fits16Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 = code `snocOL`
- (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
- in
- returnNat (CondCode False cond code__2)
-
-condIntCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
- in
- returnNat (CondCode False cond code__2)
-
-condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- FCMP src1 src2
- in
- returnNat (CondCode False cond code__2)
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating assignments}
-%* *
-%************************************************************************
-
-Assignments are really at the heart of the whole code generation
-business. Almost all top-level nodes of any real importance are
-assignments, which correspond to loads, stores, or register transfers.
-If we're really lucky, some of the register transfers will go away,
-because we can use the destination register to complete the code
-generation for the right hand side. This only fails when the right
-hand side is forced into a fixed register (e.g. the result of a call).
-
-\begin{code}
-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 `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnNat code__2
-
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- 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
- returnNat code__2
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
--- 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
- :: StixExpr
- -> NatM (InstrBlock,Operand) -- code, operator
-
- get_op_RI op
- | Just x <- maybeImm op
- = returnNat (nilOL, OpImm x)
-
- get_op_RI op
- = getRegister op `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let code = registerCode register tmp
- reg = registerName register tmp
- in
- 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
- returnNat code
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-assignMem_IntCode pk addr src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
-assignReg_IntCode pk reg src
- = getRegister src `thenNat` \ register2 ->
- getRegisterReg reg `thenNat` \ register1 ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- dst__2 = registerName register1 tmp
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code `snocOL` OR False g0 (RIReg src__2) dst__2
- else code
- in
- returnNat code__2
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-assignMem_IntCode pk addr src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
-assignReg_IntCode pk reg src
- = getRegister src `thenNat` \ register2 ->
- getRegisterReg reg `thenNat` \ register1 ->
- let
- dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code `snocOL` MR dst__2 src__2
- else code
- in
- returnNat code__2
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-% --------------------------------
-Floating-point assignments:
-% --------------------------------
-
-\begin{code}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if alpha_TARGET_ARCH
-
-assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnNat code__2
-
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- 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
- 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
-
--- 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
- code2 = registerCode register tmp1
-
- src__2 = registerName register tmp1
- pk__2 = registerRep register
- sz__2 = primRepToSize pk__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
- returnNat code__2
-
--- 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
- code__2 =
- if pk /= pk__2 then
- code `snocOL` FxTOy sz__2 sz src__2 dst__2
- else if isFixed register2 then
- code `snocOL` FMOV sz src__2 dst__2
- else
- code
- in
- returnNat code__2
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
--- 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
- code2 = registerCode register tmp1
-
- src__2 = registerName register tmp1
- pk__2 = registerRep register
-
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
--- 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` MR r_dst r_src
- else c_src
- in
- returnNat code
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating an unconditional branch}
-%* *
-%************************************************************************
-
-We accept two types of targets: an immediate CLabel or a tree that
-gets evaluated into a register. Any CLabels which are AsmTemporaries
-are assumed to be in the local block of code, close enough for a
-branch instruction. Other CLabels are assumed to be far away.
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-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 zeroh (AddrReg pv) 0]
- where
- target = ImmCLbl lbl
-
-genJump tree
- = 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 zeroh (AddrReg pv) 0]
- else
- returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genJump dsts (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- target = amodeAddr amode
- in
- returnNat (code `snocOL` JMP dsts (OpAddr target))
-
-genJump dsts tree
- | maybeToBool imm
- = returnNat (unitOL (JMP dsts (OpImm target)))
-
- | otherwise
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- 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 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 dsts tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-genJump dsts (StCLbl lbl)
- | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
- | otherwise = returnNat (toOL [BCC ALWAYS lbl])
-
-genJump dsts tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
-#endif /* sparc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Conditional jumps}
-%* *
-%************************************************************************
-
-Conditional jumps are always to local labels, so we can use branch
-instructions. We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
-I386: First, we have to ensure that the condition
-codes are set according to the supplied comparison operation.
-
-SPARC: First, we have to ensure that the condition codes are set
-according to the supplied comparison operation. We generate slightly
-different code for floating point comparisons, because a floating
-point operation cannot directly precede a @BF@. We assume the worst
-and fill that slot with a @NOP@.
-
-SPARC: Do not fill the delay slots here; you will confuse the register
-allocator.
-
-\begin{code}
-genCondJump
- :: CLabel -- the branch target
- -> StixExpr -- the condition on which to branch
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genCondJump lbl (StPrim op [x, StInt 0])
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnSeq code [BI (cmpOp op) value target]
- where
- cmpOp CharGtOp = GTT
- cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQQ
- cmpOp CharNeOp = NE
- cmpOp CharLtOp = LTT
- cmpOp CharLeOp = LE
- cmpOp IntGtOp = GTT
- cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQQ
- cmpOp IntNeOp = NE
- cmpOp IntLtOp = LTT
- cmpOp IntLeOp = LE
- cmpOp WordGtOp = NE
- cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQQ
- cmpOp WordNeOp = NE
- cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQQ
- cmpOp AddrGtOp = NE
- cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQQ
- cmpOp AddrNeOp = NE
- cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
- where
- cmpOp FloatGtOp = GTT
- cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQQ
- cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LTT
- cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GTT
- cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQQ
- cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LTT
- cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
- | fltCmpOp op
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BF cond result target))
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
- fltCmpOp op = case op of
- FloatGtOp -> True
- FloatGeOp -> True
- FloatEqOp -> True
- FloatNeOp -> True
- FloatLtOp -> True
- FloatLeOp -> True
- DoubleGtOp -> True
- DoubleGeOp -> True
- DoubleEqOp -> True
- DoubleNeOp -> True
- DoubleLtOp -> True
- DoubleLeOp -> True
- _ -> False
- (instr, cond) = case op of
- 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, 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 `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BI cond result target))
- where
- (instr, cond) = case op of
- 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, EQQ)
- IntGeOp -> (CMP LTT, EQQ)
- IntEqOp -> (CMP EQQ, NE)
- IntNeOp -> (CMP EQQ, EQQ)
- IntLtOp -> (CMP LTT, NE)
- IntLeOp -> (CMP LE, NE)
- 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, 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 `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- in
- returnNat (code `snocOL` JXX cond lbl)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-genCondJump lbl bool
- = getCondCode bool `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- returnNat (
- code `appOL`
- toOL (
- if condFloat condition
- then [NOP, BF cond False target, NOP]
- else [BI cond False target, NOP]
- )
- )
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-genCondJump lbl bool
- = getCondCode bool `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- returnNat (
- code `snocOL` BCC cond lbl )
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating C calls}
-%* *
-%************************************************************************
-
-Now the biggest nightmare---calls. Most of the nastiness is buried in
-@get_arg@, which moves the arguments to the correct registers/stack
-locations. Apart from that, the code is easy.
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-genCCall
- :: (Either FastString StixExpr) -- function to call
- -> CCallConv
- -> PrimRep -- type of the result
- -> [StixExpr] -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genCCall fn cconv kind args
- = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenNat` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- code = asmSeqThen (map ($ []) argCode)
- in
- returnSeq code [
- LDA pv (AddrImm (ImmLab (ptext fn))),
- JSR ra (AddrReg pv) nRegs,
- LDGP gp (AddrReg ra)]
- where
- ------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The first 6 arguments go into the appropriate
- argument register (separate registers for integer and floating
- point arguments, but used in lock-step), and the remaining
- arguments are dumped to the stack, beginning at 0(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
- @mapAccumLNat@.
- -}
- get_arg
- :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> 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 `thenNat` \ register ->
- let
- reg = if isFloatingRep pk then fDst else iDst
- code = registerCode register reg
- src = registerName register reg
- pk = registerRep register
- in
- returnNat (
- if isFloatingRep pk then
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (FMOV src fDst)
- else code)
- else
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR src (RIReg src) iDst)
- else code))
-
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-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)
-
- 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 = 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))
-
- stdcallsize tot_arg_size
- | cconv == StdCallConv = '@':show tot_arg_size
- | otherwise = ""
-
- arg_size DF = 8
- arg_size F = 4
- arg_size _ = 4
-
- ------------
- 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
- :: StixExpr
- -> NatM (InstrBlock, Reg, Size) -- code, reg, size
-
- get_op op
- = getRegister op `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- 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 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 diff = length vregs - n_argRegs
- nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
- 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_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 */
-
-#if powerpc_TARGET_ARCH
-
-#if darwin_TARGET_OS
-{-
- The PowerPC calling convention for Darwin/Mac OS X
- is described in Apple's document
- "Inside Mac OS X - Mach-O Runtime Architecture".
- Parameters may be passed in general-purpose registers, in
- floating point registers, or on the stack. Stack space is
- always reserved for parameters, even if they are passed in registers.
- The called routine may choose to save parameters from registers
- to the corresponding space on the stack.
- The parameter area should be part of the caller's stack frame,
- allocated in the caller's prologue code (large enough to hold
- the parameter lists for all called routines). The NCG already
- uses the space that we should use as a parameter area for register
- spilling, so we allocate a new stack frame just before ccalling.
- That way we don't need to decide beforehand how much space to
- reserve for parameters.
--}
-
-genCCall fn cconv kind args
- = mapNat prepArg args `thenNat` \ preppedArgs ->
- let
- (argReps,argCodes,vregs) = unzip3 preppedArgs
-
- -- size of linkage area + size of arguments, in bytes
- stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
- roundTo16 x | x `mod` 16 == 0 = x
- | otherwise = x + 16 - (x `mod` 16)
-
- move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
- move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
-
- (moveFinalCode,usedRegs) = move_final
- (zip vregs argReps)
- allArgRegs allFPArgRegs
- eXTRA_STK_ARGS_HERE
- (toOL []) []
-
- passArguments = concatOL argCodes
- `appOL` move_sp_down
- `appOL` moveFinalCode
- in
- case fn of
- Left lbl ->
- addImportNat lbl `thenNat` \ _ ->
- returnNat (passArguments
- `snocOL` BL (ImmLit $ ftext
- (FSLIT("L_")
- `appendFS` lbl
- `appendFS` FSLIT("$stub")))
- usedRegs
- `appOL` move_sp_up)
- Right dyn ->
- getRegister dyn `thenNat` \ dynReg ->
- getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
- returnNat (registerCode dynReg tmp
- `appOL` passArguments
- `snocOL` MTCTR (registerName dynReg tmp)
- `snocOL` BCTRL usedRegs
- `appOL` move_sp_up)
- where
- prepArg arg
- | is64BitRep (repOfStixExpr arg)
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
- | otherwise
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register) `thenNat` \ tmp ->
- returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
- move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
- move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | not (is64BitRep rep) =
- case rep of
- FloatRep ->
- move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
- (accumCode `snocOL`
- (case fprs of
- fpr : fprs -> MR fpr vr
- [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 fprs) ++ accumUsed)
- DoubleRep ->
- move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
- (accumCode `snocOL`
- (case fprs of
- fpr : fprs -> MR fpr vr
- [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 fprs) ++ accumUsed)
- VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
- _ ->
- move_final vregs (drop 1 gprs) fprs (stackOffset+4)
- (accumCode `snocOL`
- (case gprs of
- gpr : gprs -> MR gpr vr
- [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 gprs) ++ accumUsed)
-
- move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | is64BitRep rep =
- let
- storeWord vr (gpr:_) offset = MR gpr vr
- storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
- in
- move_final vregs (drop 2 gprs) fprs (stackOffset+8)
- (accumCode
- `snocOL` storeWord vr_hi gprs stackOffset
- `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
- ((take 2 gprs) ++ accumUsed)
-#else
-
-{-
- PowerPC Linux uses the System V Release 4 Calling Convention
- for PowerPC. It is described in the
- "System V Application Binary Interface PowerPC Processor Supplement".
-
- Like the Darwin/Mac OS X code above, this allocates a new stack frame
- so that the parameter area doesn't conflict with the spill slots.
--}
-
-genCCall fn cconv kind args
- = mapNat prepArg args `thenNat` \ preppedArgs ->
- let
- (argReps,argCodes,vregs) = unzip3 preppedArgs
-
- -- size of linkage area + size of arguments, in bytes
- stackDelta = roundTo16 finalStack
- roundTo16 x | x `mod` 16 == 0 = x
- | otherwise = x + 16 - (x `mod` 16)
-
- move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
- move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
-
- (moveFinalCode,usedRegs,finalStack) =
- move_final (zip vregs argReps)
- allArgRegs allFPArgRegs
- eXTRA_STK_ARGS_HERE
- (toOL []) []
-
- passArguments = concatOL argCodes
- `appOL` move_sp_down
- `appOL` moveFinalCode
- in
- case fn of
- Left lbl ->
- addImportNat lbl `thenNat` \ _ ->
- returnNat (passArguments
- `snocOL` BL (ImmLit $ ftext lbl)
- usedRegs
- `appOL` move_sp_up)
- Right dyn ->
- getRegister dyn `thenNat` \ dynReg ->
- getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
- returnNat (registerCode dynReg tmp
- `appOL` passArguments
- `snocOL` MTCTR (registerName dynReg tmp)
- `snocOL` BCTRL usedRegs
- `appOL` move_sp_up)
- where
- prepArg arg
- | is64BitRep (repOfStixExpr arg)
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
- | otherwise
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register) `thenNat` \ tmp ->
- returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
- move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
- move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | not (is64BitRep rep) =
- case rep of
- FloatRep ->
- case fprs of
- fpr : fprs' -> move_final vregs gprs fprs' stackOffset
- (accumCode `snocOL` MR fpr vr)
- (fpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+4)
- (accumCode `snocOL`
- ST F vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
- DoubleRep ->
- case fprs of
- fpr : fprs' -> move_final vregs gprs fprs' stackOffset
- (accumCode `snocOL` MR fpr vr)
- (fpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+8)
- (accumCode `snocOL`
- ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
- VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
- _ ->
- case gprs of
- gpr : gprs' -> move_final vregs gprs' fprs stackOffset
- (accumCode `snocOL` MR gpr vr)
- (gpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+4)
- (accumCode `snocOL`
- ST W vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
-
- move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | is64BitRep rep =
- case gprs of
- hireg : loreg : regs | even (length gprs) ->
- move_final vregs regs fprs stackOffset
- (regCode hireg loreg) accumUsed
- _skipped : hireg : loreg : regs ->
- move_final vregs regs fprs stackOffset
- (regCode hireg loreg) accumUsed
- _ -> -- only one or no regs left
- move_final vregs [] fprs (stackOffset+8)
- stackCode accumUsed
- where
- stackCode =
- accumCode
- `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
- `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
- regCode hireg loreg =
- accumCode
- `snocOL` MR hireg vr_hi
- `snocOL` MR loreg vr_lo
-
-#endif
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Support bits}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
-%* *
-%************************************************************************
-
-Turn those condition codes into integers now (when they appear on
-the right hand side of an assignment).
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-condIntReg = panic "MachCode.condIntReg (not on Alpha)"
-condFltReg = panic "MachCode.condFltReg (not on Alpha)"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-condIntReg cond x y
- = condIntCode cond x y `thenNat` \ condition ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- SETCC cond (OpReg tmp),
- AND L (OpImm (ImmInt 1)) (OpReg tmp),
- MOV L (OpReg tmp) (OpReg dst)]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- JXX cond lbl1,
- MOV L (OpImm (ImmInt 0)) (OpReg dst),
- JXX ALWAYS lbl2,
- LABEL lbl1,
- MOV L (OpImm (ImmInt 1)) (OpReg dst),
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-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 `appOL` toOL [
- SUB False True g0 (RIReg src) g0,
- SUB True False g0 (RIImm (ImmInt (-1))) dst]
- in
- returnNat (Any IntRep code__2)
-
-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
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- 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
- returnNat (Any IntRep code__2)
-
-condIntReg NE x (StInt 0)
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `appOL` toOL [
- SUB False True g0 (RIReg src) g0,
- ADD True False g0 (RIImm (ImmInt 0)) dst]
- in
- returnNat (Any IntRep code__2)
-
-condIntReg NE x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- 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
- returnNat (Any IntRep code__2)
-
-condIntReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condIntCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- 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,
- LABEL lbl1,
- OR False g0 (RIImm (ImmInt 1)) dst,
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- NOP,
- BF cond False (ImmCLbl lbl1), NOP,
- OR False g0 (RIImm (ImmInt 0)) dst,
- BI ALWAYS False (ImmCLbl lbl2), NOP,
- LABEL lbl1,
- OR False g0 (RIImm (ImmInt 1)) dst,
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-condIntReg cond x y
- = getNatLabelNCG `thenNat` \ lbl ->
- condIntCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
- BCC cond lbl,
- LI dst (ImmInt 0),
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
- BCC cond lbl,
- LI dst (ImmInt 0),
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@trivial*Code@: deal with trivial instructions}
-%* *
-%************************************************************************
-
-Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
-@trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
-for constants on the right hand side, because that's where the generic
-optimizer will have put them.
-
-Similarly, for unary instructions, we don't have to worry about
-matching an StInt as the argument, because genericOpt will already
-have handled the constant-folding.
-
-\begin{code}
-trivialCode
- :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
- ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
- -> Maybe (Operand -> Operand -> Instr)
- ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
- ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
- ,))))
- -> 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 ((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
- ,))))
- -> 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)
- ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
- ,))))
- -> StixExpr -- the one argument
- -> NatM Register
-
-trivialUFCode
- :: PrimRep
- -> IF_ARCH_alpha((Reg -> Reg -> Instr)
- ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
- ,IF_ARCH_sparc((Reg -> Reg -> Instr)
- ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
- ,))))
- -> StixExpr -- the one argument
- -> NatM Register
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-trivialCode instr x (StInt y)
- | fits8Bits y
- = 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
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 []
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
- src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- returnNat (Any IntRep code__2)
-
-------------
-trivialUCode instr x
- = 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
- returnNat (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
- = 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 = asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (instr src1 src2 dst)
- in
- returnNat (Any DoubleRep code__2)
-
-trivialUFCode _ instr x
- = 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
- returnNat (Any DoubleRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-\end{code}
-The Rules of the Game are:
-
-* You cannot assume anything about the destination register dst;
- it may be anything, including a fixed reg.
-
-* You may compute an operand into a fixed reg, but you may not
- subsequently change the contents of that fixed reg. If you
- 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.
-
-* 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
-
-
------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- 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
- returnNat (Any IntRep code__2)
-
------------
-trivialFCode pk instr x y
- = 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
- -- treat the common case specially: both operands in
- -- non-fixed regs.
- | isAny register1 && isAny register2
- = code1 `appOL`
- code2 `snocOL`
- instr (primRepToSize pk) src1 src2 dst
-
- -- be paranoid (and inefficient)
- | otherwise
- = code1 `snocOL` GMOV src1 tmp1 `appOL`
- code2 `snocOL`
- instr (primRepToSize pk) tmp1 src2 dst
- in
- returnNat (Any pk code__2)
-
-
--------------
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr src dst
- in
- returnNat (Any pk code__2)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-trivialCode instr x (StInt y)
- | fits13Bits y
- = 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 `snocOL` instr src1 (RIImm src2) dst
- in
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr src1 (RIReg src2) dst
- in
- returnNat (Any IntRep code__2)
-
-------------
-trivialFCode pk instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst =
- if pk1 == pk2 then
- code1 `appOL` code2 `snocOL`
- instr (primRepToSize pk) src1 src2 dst
- else if pk1 == FloatRep then
- code1 `snocOL` promote src1 `appOL` code2 `snocOL`
- instr DF tmp src2 dst
- else
- code1 `appOL` code2 `snocOL` promote src2 `snocOL`
- instr DF src1 tmp dst
- in
- returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
-
-------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr (RIReg src) dst
- in
- returnNat (Any IntRep code__2)
-
--------------
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr src dst
- in
- returnNat (Any pk code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-trivialCode instr x (StInt y)
- | fits16Bits y
- = 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 `snocOL` instr dst src1 (RIImm src2)
- in
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr dst src1 (RIReg src2)
- in
- returnNat (Any IntRep code__2)
-
-trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
- -> StixExpr -> StixExpr -> NatM Register
-trivialCode2 instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr dst src1 src2
- in
- returnNat (Any IntRep code__2)
-
-trivialFCode pk instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- -- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
-
- code__2 dst =
- code1 `appOL` code2 `snocOL`
- instr (primRepToSize dstRep) dst src1 src2
- in
- returnNat (Any dstRep code__2)
-
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr dst src
- in
- returnNat (Any IntRep code__2)
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr dst src
- in
- returnNat (Any pk code__2)
-
--- There is no "remainder" instruction on the PPC, so we have to do
--- it the hard way.
--- The "div" parameter is the division instruction to use (DIVW or DIVWU)
-
-remainderCode :: (Reg -> Reg -> Reg -> Instr)
- -> StixExpr -> StixExpr -> NatM Register
-remainderCode div x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `appOL` toOL [
- div dst src1 src2,
- MULLW dst dst (RIReg src2),
- SUBF dst dst src1
- ]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Coercing to/from integer/floating-point...}
-%* *
-%************************************************************************
-
-@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}
-coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
-coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
-
-coerceDbl2Flt :: StixExpr -> NatM Register
-coerceFlt2Dbl :: StixExpr -> NatM Register
-\end{code}
-
-\begin{code}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- ST Q src (spRel 0),
- LD TF dst (spRel 0),
- CVTxy Q TF dst dst]
- in
- returnNat (Any DoubleRep code__2)
-
--------------
-coerceFP2Int x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- CVTxy TF Q src tmp,
- ST TF tmp (spRel 0),
- LD Q dst (spRel 0)]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-coerceInt2FP pk x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
- code__2 dst = code `snocOL` opc src dst
- in
- returnNat (Any pk code__2)
-
-------------
-coerceFP2Int fprep x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
-
- opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
- code__2 dst = code `snocOL` opc src dst
- 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
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code `appOL` toOL [
- ST W src (spRel (-2)),
- LD W (spRel (-2)) dst,
- FxTOy W (primRepToSize pk) dst dst]
- in
- returnNat (Any pk code__2)
-
-------------
-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
- code__2 dst = code `appOL` toOL [
- FxTOy (primRepToSize fprep) W src tmp,
- ST W tmp (spRel (-2)),
- LD W (spRel (-2)) dst]
- in
- returnNat (Any IntRep code__2)
-
-------------
-coerceDbl2Flt x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let code = registerCode register tmp
- src = registerName register tmp
- in
- returnNat (Any FloatRep
- (\dst -> code `snocOL` FxTOy DF F src dst))
-
-------------
-coerceFlt2Dbl x
- = getRegister x `thenNat` \ register ->
- 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 */
-
-#if powerpc_TARGET_ARCH
-coerceInt2FP pk x
- = ASSERT(pk == DoubleRep)
- getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ itmp ->
- getNewRegNCG DoubleRep `thenNat` \ ftmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `appOL` toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
- SEGMENT TextSegment,
- XORIS itmp src (ImmInt 0x8000),
- ST W itmp (spRel (-1)),
- LIS itmp (ImmInt 0x4330),
- ST W itmp (spRel (-2)),
- LD DF ftmp (spRel (-2)),
- LIS itmp (HA (ImmCLbl lbl)),
- LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
- FSUB DF dst ftmp dst
- ]
- in
- returnNat (Any DoubleRep code__2)
-
-coerceFP2Int fprep x
- = ASSERT(fprep == DoubleRep || fprep == FloatRep)
- getRegister x `thenNat` \ register ->
- getNewRegNCG fprep `thenNat` \ reg ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `appOL` toOL [
- -- convert to int in FP reg
- FCTIWZ tmp src,
- -- store value (64bit) from FP to stack
- ST DF tmp (spRel (-2)),
- -- read low word of value (high word is undefined)
- LD W dst (spRel (-1))]
- in
- returnNat (Any IntRep code__2)
-coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
-coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
projects / ghc-hetmet.git / blobdiff