% % (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 Unique ( Unique ) import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) import MachOp ( MachOp(..), pprMachOp ) import AbsCUtils ( magicIdPrimRep ) import PprAbsC ( pprMagicId ) import ForeignCall ( CCallConv(..) ) import CLabel ( 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, liftStrings, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat, getUniqueNat, ncgPrimopMoan, ncg_target_is_32bit ) import Pretty import Outputable ( panic, pprPanic, showSDoc ) import qualified Outputable import CmdLineOpts ( opt_Static ) import Stix ( pprStixStmt ) -- 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 r3 mov_hi = MR r_dst_hi r4 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 other -> pprPanic "getRegister(powerpc) - unary StMachOp" (pprMachOp mop) where integerExtend signed nBits x = getRegister ( StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] ) conversionNop new_rep expr = getRegister expr `thenNat` \ e_code -> returnNat (swizzleRegisterRep e_code new_rep) getRegister (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 -> trivialCode SUBF y x MO_NatS_Mul -> trivialCode MULLW x y MO_NatU_Mul -> trivialCode MULLW x y MO_NatS_Quot -> trivialCode2 DIVW x y MO_NatU_Quot -> trivialCode2 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_NatS_Mul -> trivialCode (SMUL False) x y MO_NatU_Mul -> trivialCode (UMUL False) x y MO_NatS_MulMayOflo -> imulMayOflo x y imulMayOflo -- 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_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(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 sz__2 = primRepToSize pk__2 code__2 = if pk__2 == DoubleRep || pk == pk__2 then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2 else panic "###PPC MachCode.assignMem_FltCode: FloatRep" {- 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 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) = 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) #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 {- The PowerPC calling convention (at least 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 -> returnNat ( passArguments `snocOL` BL (ImmLab False (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 [] _ _ _ 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) #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 code__2 dst = if pk1 == pk2 then code1 `appOL` code2 `snocOL` instr (primRepToSize pk) dst src1 src2 else panic "###PPC MachCode.trivialFCode: type mismatch" 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 dst src in returnNat (Any IntRep code__2) trivialUFCode pk instr x = panic "###PPC MachCode.trivialUFCode" #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 = panic "###PPC MachCode.coerceInt2FP" coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int" coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt" coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl" #endif {- powerpc_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code}