----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) -- -- (c) The University of Glasgow 1996-2004 -- ----------------------------------------------------------------------------- -- This is a big module, but, if you pay attention to -- (a) the sectioning, (b) the type signatures, and -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" #include "MachDeps.h" -- NCG stuff: import MachInstrs import MachRegs import NCGMonad import PositionIndependentCode ( cmmMakeDynamicReference, initializePicBase ) -- Our intermediate code: import PprCmm ( pprExpr ) import Cmm import MachOp import CLabel -- The rest: import StaticFlags ( opt_PIC ) import ForeignCall ( CCallConv(..) ) import OrdList import Pretty import Outputable import qualified Outputable import FastString import FastTypes ( isFastTrue ) import Constants ( wORD_SIZE ) #ifdef DEBUG import Outputable ( assertPanic ) import TRACE ( trace ) #endif import Control.Monad ( mapAndUnzipM ) import Maybe ( fromJust ) import DATA_BITS import DATA_WORD -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector -- | '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. type InstrBlock = OrdList Instr cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop] cmmTopCodeGen (CmmProc info lab params blocks) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat let proc = CmmProc info lab params (concat nat_blocks) tops = proc : concat statics case picBaseMb of Just picBase -> initializePicBase picBase tops Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ([NatBasicBlock],[NatCmmTop]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts -- code generation may introduce new basic block boundaries, which -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. let (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs mkBlocks (NEWBLOCK id) (instrs,blocks,statics) = ([], BasicBlock id instrs : blocks, statics) mkBlocks (LDATA sec dat) (instrs,blocks,statics) = (instrs, blocks, CmmData sec dat:statics) mkBlocks instr (instrs,blocks,statics) = (instr:instrs, blocks, statics) -- in return (BasicBlock id top : other_blocks, statics) stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock stmtsToInstrs stmts = do instrss <- mapM stmtToInstrs stmts return (concatOL instrss) stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src | isFloatingRep kind -> assignReg_FltCode kind reg src #if WORD_SIZE_IN_BITS==32 | kind == I64 -> assignReg_I64Code reg src #endif | otherwise -> assignReg_IntCode kind reg src where kind = cmmRegRep reg CmmStore addr src | isFloatingRep kind -> assignMem_FltCode kind addr src #if WORD_SIZE_IN_BITS==32 | kind == I64 -> assignMem_I64Code addr src #endif | otherwise -> assignMem_IntCode kind addr src where kind = cmmExprRep src CmmCall target result_regs args vols -> genCCall target result_regs args vols CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg params -> genJump arg -- ----------------------------------------------------------------------------- -- General things for putting together code sequences -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? mangleIndexTree :: CmmExpr -> CmmExpr mangleIndexTree (CmmRegOff reg off) = CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) rep)] where rep = cmmRegRep reg -- ----------------------------------------------------------------------------- -- Code gen for 64-bit arithmetic on 32-bit platforms {- 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. -} data ChildCode64 -- a.k.a "Register64" = ChildCode64 InstrBlock -- code Reg -- 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 -- Reg may be modified #if WORD_SIZE_IN_BITS==32 assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock #endif #ifndef x86_64_TARGET_ARCH iselExpr64 :: CmmExpr -> NatM ChildCode64 #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH assignMem_I64Code addrTree valueTree = do Amode addr addr_code <- getAmode addrTree ChildCode64 vcode rlo <- iselExpr64 valueTree let rhi = getHiVRegFromLo rlo -- Little-endian store mov_lo = MOV I32 (OpReg rlo) (OpAddr addr) mov_hi = MOV I32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) -- in return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst I32 r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo mov_lo = MOV I32 (OpReg r_src_lo) (OpReg r_dst_lo) mov_hi = MOV I32 (OpReg r_src_hi) (OpReg r_dst_hi) -- in return ( vcode `snocOL` mov_lo `snocOL` mov_hi ) assignReg_I64Code lvalue valueTree = panic "assignReg_I64Code(i386): invalid lvalue" ------------ iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat I32 let r = fromIntegral (fromIntegral i :: Word32) q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) code = toOL [ MOV I32 (OpImm (ImmInteger r)) (OpReg rlo), MOV I32 (OpImm (ImmInteger q)) (OpReg rhi) ] -- in return (ChildCode64 code rlo) iselExpr64 (CmmLoad addrTree I64) = do Amode addr addr_code <- getAmode addrTree (rlo,rhi) <- getNewRegPairNat I32 let mov_lo = MOV I32 (OpAddr addr) (OpReg rlo) mov_hi = MOV I32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) -- in return ( ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo ) iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) = return (ChildCode64 nilOL (mkVReg vu I32)) -- we handle addition, but rather badly iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do ChildCode64 code1 r1lo <- iselExpr64 e1 (rlo,rhi) <- getNewRegPairNat I32 let r = fromIntegral (fromIntegral i :: Word32) q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) r1hi = getHiVRegFromLo r1lo code = code1 `appOL` toOL [ MOV I32 (OpReg r1lo) (OpReg rlo), ADD I32 (OpImm (ImmInteger r)) (OpReg rlo), MOV I32 (OpReg r1hi) (OpReg rhi), ADC I32 (OpImm (ImmInteger q)) (OpReg rhi) ] -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ChildCode64 code1 r1lo <- iselExpr64 e1 ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat I32 let r1hi = getHiVRegFromLo r1lo r2hi = getHiVRegFromLo r2lo code = code1 `appOL` code2 `appOL` toOL [ MOV I32 (OpReg r1lo) (OpReg rlo), ADD I32 (OpReg r2lo) (OpReg rlo), MOV I32 (OpReg r1hi) (OpReg rhi), ADC I32 (OpReg r2hi) (OpReg rhi) ] -- in return (ChildCode64 code rlo) iselExpr64 expr = pprPanic "iselExpr64(i386)" (ppr expr) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignMem_I64Code addrTree valueTree = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> getRegister addrTree `thenNat` \ register_addr -> getNewRegNat 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 return (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 return ( 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 (pprCmmExpr expr)) False -- = panic "iselExpr64(???)" iselExpr64 (CmmLoad I64 addrTree) = getRegister addrTree `thenNat` \ register_addr -> getNewRegNat IntRep `thenNat` \ t_addr -> getNewRegNat 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 return ( ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) (getVRegUnique rlo) ) iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) = getNewRegNat 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 return ( ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo) ) iselExpr64 (StCall fn cconv I64 args) = genCCall fn cconv kind args `thenNat` \ call -> getNewRegNat 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 return ( ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) (getVRegUnique r_dst_lo) ) iselExpr64 expr = pprPanic "iselExpr64(sparc)" (pprCmmExpr expr) #endif /* sparc_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if powerpc_TARGET_ARCH getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) getI64Amodes addrTree = do Amode hi_addr addr_code <- getAmode addrTree case addrOffset hi_addr 4 of Just lo_addr -> return (hi_addr, lo_addr, addr_code) Nothing -> do (hi_ptr, code) <- getSomeReg addrTree return (AddrRegImm hi_ptr (ImmInt 0), AddrRegImm hi_ptr (ImmInt 4), code) assignMem_I64Code addrTree valueTree = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree ChildCode64 vcode rlo <- iselExpr64 valueTree let rhi = getHiVRegFromLo rlo -- Big-endian store mov_hi = ST I32 rhi hi_addr mov_lo = ST I32 rlo lo_addr -- in return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst I32 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 return ( vcode `snocOL` mov_lo `snocOL` mov_hi ) assignReg_I64Code lvalue valueTree = panic "assignReg_I64Code(powerpc): invalid lvalue" -- Don't delete this -- it's very handy for debugging. --iselExpr64 expr -- | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False -- = panic "iselExpr64(???)" iselExpr64 (CmmLoad addrTree I64) = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree (rlo, rhi) <- getNewRegPairNat I32 let mov_hi = LD I32 rhi hi_addr mov_lo = LD I32 rlo lo_addr return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) = return (ChildCode64 nilOL (mkVReg vu I32)) iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat I32 let half0 = fromIntegral (fromIntegral i :: Word16) half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16) half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16) half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16) code = toOL [ LIS rlo (ImmInt half1), OR rlo rlo (RIImm $ ImmInt half0), LIS rhi (ImmInt half3), OR rlo rlo (RIImm $ ImmInt half2) ] -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ChildCode64 code1 r1lo <- iselExpr64 e1 ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat I32 let r1hi = getHiVRegFromLo r1lo r2hi = getHiVRegFromLo r2lo code = code1 `appOL` code2 `appOL` toOL [ ADDC rlo r1lo r2lo, ADDE rhi r1hi r2hi ] -- in return (ChildCode64 code rlo) iselExpr64 expr = pprPanic "iselExpr64(powerpc)" (ppr expr) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- 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. data Register = Fixed MachRep Reg InstrBlock | Any MachRep (Reg -> InstrBlock) swizzleRegisterRep :: Register -> MachRep -> Register swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code swizzleRegisterRep (Any _ codefn) rep = Any rep codefn -- ----------------------------------------------------------------------------- -- Utils based on getRegister, below -- The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do tmp <- getNewRegNat rep return (tmp, code tmp) Fixed _ reg code -> return (reg, code) -- ----------------------------------------------------------------------------- -- Grab the Reg for a CmmReg getRegisterReg :: CmmReg -> Reg getRegisterReg (CmmLocal (LocalReg u pk)) = mkVReg u pk getRegisterReg (CmmGlobal mid) = case get_GlobalReg_reg_or_addr mid of Left (RealReg rrno) -> RealReg rrno _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this -- platform. Hence ... -- ----------------------------------------------------------------------------- -- Generate code to get a subtree into a Register -- Don't delete this -- it's very handy for debugging. --getRegister expr -- | trace ("getRegister: " ++ showSDoc (pprCmmExpr expr)) False -- = panic "getRegister(???)" getRegister :: CmmExpr -> NatM Register getRegister (CmmReg reg) = return (Fixed (cmmRegRep reg) (getRegisterReg reg) nilOL) getRegister tree@(CmmRegOff _ _) = getRegister (mangleIndexTree tree) getRegister CmmPicBaseReg = do reg <- getPicBaseNat wordRep return (Fixed wordRep reg nilOL) -- end of machine-"independent" bit; here we go on the rest... #if alpha_TARGET_ARCH getRegister (StDouble d) = getBlockIdNat `thenNat` \ lbl -> getNewRegNat PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ LDATA RoDataSegment lbl [ DATA TF [ImmLab (rational d)] ], LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] in return (Any F64 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 F64 (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 F64 [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 F64 (FADD TF) x y DoubleSubOp -> trivialFCode F64 (FSUB TF) x y DoubleMulOp -> trivialFCode F64 (FMUL TF) x y DoubleDivOp -> trivialFCode F64 (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 F64 [x,y]) DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv F64 [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 -> getNewRegNat IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) in return (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 -> getNewRegNat F64 `thenNat` \ tmp -> getBlockIdNat `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, NEWBLOCK lbl] in return (Any IntRep code__2) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" ------------------------------------------------------------ getRegister (CmmLoad 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 return (Any pk code__2) getRegister (StInt i) | fits8Bits i = let code dst = mkSeqInstr (OR zeroh (RIImm src) dst) in return (Any IntRep code) | otherwise = let code dst = mkSeqInstr (LDI Q dst src) in return (Any IntRep code) where src = ImmInt (fromInteger i) getRegister leaf | isJust imm = let code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) in return (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH getRegister (CmmLit (CmmFloat f F32)) = do lbl <- getNewLabelNat let code dst = toOL [ LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat f F32)], GLD F32 (ImmAddr (ImmCLbl lbl) 0) dst ] -- in return (Any F32 code) getRegister (CmmLit (CmmFloat d F64)) | d == 0.0 = let code dst = unitOL (GLDZ dst) in return (Any F64 code) | d == 1.0 = let code dst = unitOL (GLD1 dst) in return (Any F64 code) | otherwise = do lbl <- getNewLabelNat let code dst = toOL [ LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat d F64)], GLD F64 (ImmAddr (ImmCLbl lbl) 0) dst ] -- in return (Any F64 code) #endif /* i386_TARGET_ARCH */ #if x86_64_TARGET_ARCH getRegister (CmmLit (CmmFloat 0.0 rep)) = do let code dst = unitOL (XOR rep (OpReg dst) (OpReg dst)) -- I don't know why there are xorpd, xorps, and pxor instructions. -- They all appear to do the same thing --SDM return (Any rep code) getRegister (CmmLit (CmmFloat f rep)) = do lbl <- getNewLabelNat let code dst = toOL [ LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat f rep)], MOV rep (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) -- ToDo: should use %rip-relative ] -- in return (Any rep code) #endif /* x86_64_TARGET_ARCH */ #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- catch simple cases of zero- or sign-extended load getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL I8) addr return (Any I32 code) getRegister (CmmMachOp (MO_S_Conv I8 I32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL I8) addr return (Any I32 code) getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL I16) addr return (Any I32 code) getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL I16) addr return (Any I32 code) #endif #if x86_64_TARGET_ARCH -- catch simple cases of zero- or sign-extended load getRegister (CmmMachOp (MO_U_Conv I8 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL I8) addr return (Any I64 code) getRegister (CmmMachOp (MO_S_Conv I8 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL I8) addr return (Any I64 code) getRegister (CmmMachOp (MO_U_Conv I16 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL I16) addr return (Any I64 code) getRegister (CmmMachOp (MO_S_Conv I16 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL I16) addr return (Any I64 code) getRegister (CmmMachOp (MO_U_Conv I32 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOV I32) addr -- 32-bit loads zero-extend return (Any I64 code) getRegister (CmmMachOp (MO_S_Conv I32 I64) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL I32) addr return (Any I64 code) #endif #if x86_64_TARGET_ARCH getRegister (CmmMachOp (MO_S_Neg F32) [x]) = do x_code <- getAnyReg x lbl <- getNewLabelNat let code dst = x_code dst `appOL` toOL [ -- This is how gcc does it, so it can't be that bad: LDATA ReadOnlyData16 [ CmmAlign 16, CmmDataLabel lbl, CmmStaticLit (CmmInt 0x80000000 I32), CmmStaticLit (CmmInt 0 I32), CmmStaticLit (CmmInt 0 I32), CmmStaticLit (CmmInt 0 I32) ], XOR F32 (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) -- xorps, so we need the 128-bit constant -- ToDo: rip-relative ] -- return (Any F32 code) getRegister (CmmMachOp (MO_S_Neg F64) [x]) = do x_code <- getAnyReg x lbl <- getNewLabelNat let -- This is how gcc does it, so it can't be that bad: code dst = x_code dst `appOL` toOL [ LDATA ReadOnlyData16 [ CmmAlign 16, CmmDataLabel lbl, CmmStaticLit (CmmInt 0x8000000000000000 I64), CmmStaticLit (CmmInt 0 I64) ], -- gcc puts an unpck here. Wonder if we need it. XOR F64 (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) -- xorpd, so we need the 128-bit constant -- ToDo: rip-relative ] -- return (Any F64 code) #endif #if i386_TARGET_ARCH || x86_64_TARGET_ARCH getRegister (CmmMachOp mop [x]) -- unary MachOps = case mop of #if i386_TARGET_ARCH MO_S_Neg F32 -> trivialUFCode F32 (GNEG F32) x MO_S_Neg F64 -> trivialUFCode F64 (GNEG F64) x #endif MO_S_Neg rep -> trivialUCode rep (NEGI rep) x MO_Not rep -> trivialUCode rep (NOT rep) x -- Nop conversions -- TODO: these are only nops if the arg is not a fixed register that -- can't be byte-addressed. MO_U_Conv I32 I8 -> conversionNop I32 x MO_S_Conv I32 I8 -> conversionNop I32 x MO_U_Conv I16 I8 -> conversionNop I16 x MO_S_Conv I16 I8 -> conversionNop I16 x MO_U_Conv I32 I16 -> conversionNop I32 x MO_S_Conv I32 I16 -> conversionNop I32 x #if x86_64_TARGET_ARCH MO_U_Conv I64 I32 -> conversionNop I64 x MO_S_Conv I64 I32 -> conversionNop I64 x MO_U_Conv I64 I16 -> conversionNop I64 x MO_S_Conv I64 I16 -> conversionNop I64 x MO_U_Conv I64 I8 -> conversionNop I64 x MO_S_Conv I64 I8 -> conversionNop I64 x #endif MO_U_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x MO_S_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x -- widenings MO_U_Conv I8 I32 -> integerExtend I8 I32 MOVZxL x MO_U_Conv I16 I32 -> integerExtend I16 I32 MOVZxL x MO_U_Conv I8 I16 -> integerExtend I8 I16 MOVZxL x MO_S_Conv I8 I32 -> integerExtend I8 I32 MOVSxL x MO_S_Conv I16 I32 -> integerExtend I16 I32 MOVSxL x MO_S_Conv I8 I16 -> integerExtend I8 I16 MOVSxL x #if x86_64_TARGET_ARCH MO_U_Conv I8 I64 -> integerExtend I8 I64 MOVZxL x MO_U_Conv I16 I64 -> integerExtend I16 I64 MOVZxL x MO_U_Conv I32 I64 -> integerExtend I32 I64 MOVZxL x MO_S_Conv I8 I64 -> integerExtend I8 I64 MOVSxL x MO_S_Conv I16 I64 -> integerExtend I16 I64 MOVSxL x MO_S_Conv I32 I64 -> integerExtend I32 I64 MOVSxL x -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. -- However, we don't want the register allocator to throw it -- away as an unnecessary reg-to-reg move, so we keep it in -- the form of a movzl and print it as a movl later. #endif #if i386_TARGET_ARCH MO_S_Conv F32 F64 -> conversionNop F64 x MO_S_Conv F64 F32 -> conversionNop F32 x #else MO_S_Conv F32 F64 -> coerceFP2FP F64 x MO_S_Conv F64 F32 -> coerceFP2FP F32 x #endif MO_S_Conv from to | isFloatingRep from -> coerceFP2Int from to x | isFloatingRep to -> coerceInt2FP from to x other -> pprPanic "getRegister" (pprMachOp mop) where -- signed or unsigned extension. integerExtend from to instr expr = do (reg,e_code) <- if from == I8 then getByteReg expr else getSomeReg expr let code dst = e_code `snocOL` instr from (OpReg reg) (OpReg dst) return (Any to code) conversionNop new_rep expr = do e_code <- getRegister expr return (swizzleRegisterRep e_code new_rep) getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps = ASSERT2(cmmExprRep x /= I8, pprExpr e) case mop of MO_Eq F32 -> condFltReg EQQ x y MO_Ne F32 -> condFltReg NE x y MO_S_Gt F32 -> condFltReg GTT x y MO_S_Ge F32 -> condFltReg GE x y MO_S_Lt F32 -> condFltReg LTT x y MO_S_Le F32 -> condFltReg LE x y MO_Eq F64 -> condFltReg EQQ x y MO_Ne F64 -> condFltReg NE x y MO_S_Gt F64 -> condFltReg GTT x y MO_S_Ge F64 -> condFltReg GE x y MO_S_Lt F64 -> condFltReg LTT x y MO_S_Le F64 -> condFltReg LE x y MO_Eq rep -> condIntReg EQQ x y MO_Ne rep -> condIntReg NE x y MO_S_Gt rep -> condIntReg GTT x y MO_S_Ge rep -> condIntReg GE x y MO_S_Lt rep -> condIntReg LTT x y MO_S_Le rep -> condIntReg LE x y MO_U_Gt rep -> condIntReg GU x y MO_U_Ge rep -> condIntReg GEU x y MO_U_Lt rep -> condIntReg LU x y MO_U_Le rep -> condIntReg LEU x y #if i386_TARGET_ARCH MO_Add F32 -> trivialFCode F32 GADD x y MO_Sub F32 -> trivialFCode F32 GSUB x y MO_Add F64 -> trivialFCode F64 GADD x y MO_Sub F64 -> trivialFCode F64 GSUB x y MO_S_Quot F32 -> trivialFCode F32 GDIV x y MO_S_Quot F64 -> trivialFCode F64 GDIV x y #endif #if x86_64_TARGET_ARCH MO_Add F32 -> trivialFCode F32 ADD x y MO_Sub F32 -> trivialFCode F32 SUB x y MO_Add F64 -> trivialFCode F64 ADD x y MO_Sub F64 -> trivialFCode F64 SUB x y MO_S_Quot F32 -> trivialFCode F32 FDIV x y MO_S_Quot F64 -> trivialFCode F64 FDIV x y #endif MO_Add rep -> add_code rep x y MO_Sub rep -> sub_code rep x y MO_S_Quot rep -> div_code rep True True x y MO_S_Rem rep -> div_code rep True False x y MO_U_Quot rep -> div_code rep False True x y MO_U_Rem rep -> div_code rep False False x y #if i386_TARGET_ARCH MO_Mul F32 -> trivialFCode F32 GMUL x y MO_Mul F64 -> trivialFCode F64 GMUL x y #endif #if x86_64_TARGET_ARCH MO_Mul F32 -> trivialFCode F32 MUL x y MO_Mul F64 -> trivialFCode F64 MUL x y #endif MO_Mul rep -> let op = IMUL rep in trivialCode rep op (Just op) x y MO_S_MulMayOflo rep -> imulMayOflo rep x y MO_And rep -> let op = AND rep in trivialCode rep op (Just op) x y MO_Or rep -> let op = OR rep in trivialCode rep op (Just op) x y MO_Xor rep -> let op = XOR rep in trivialCode rep op (Just op) x y {- Shift ops on x86s have constraints on their source, it either has to be Imm, CL or 1 => trivialCode is not restrictive enough (sigh.) -} MO_Shl rep -> shift_code rep (SHL rep) x y {-False-} MO_U_Shr rep -> shift_code rep (SHR rep) x y {-False-} MO_S_Shr rep -> shift_code rep (SAR rep) x y {-False-} other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) where -------------------- imulMayOflo :: MachRep -> CmmExpr -> CmmExpr -> NatM Register imulMayOflo rep a b = do (a_reg, a_code) <- getNonClobberedReg a b_code <- getAnyReg b let shift_amt = case rep of I32 -> 31 I64 -> 63 _ -> panic "shift_amt" code = a_code `appOL` b_code eax `appOL` toOL [ IMUL2 rep (OpReg a_reg), -- result in %edx:%eax SAR rep (OpImm (ImmInt shift_amt)) (OpReg eax), -- sign extend lower part SUB rep (OpReg edx) (OpReg eax) -- compare against upper -- eax==0 if high part == sign extended low part ] -- in return (Fixed rep eax code) -------------------- shift_code :: MachRep -> (Operand -> Operand -> Instr) -> CmmExpr -> CmmExpr -> NatM Register {- Case1: shift length as immediate -} shift_code rep instr x y@(CmmLit lit) = do x_code <- getAnyReg x let code dst = x_code dst `snocOL` instr (OpImm (litToImm lit)) (OpReg dst) -- in return (Any rep code) {- Case2: shift length is complex (non-immediate) -} shift_code rep instr x y{-amount-} = do (x_reg, x_code) <- getNonClobberedReg x y_code <- getAnyReg y let code = x_code `appOL` y_code ecx `snocOL` instr (OpReg ecx) (OpReg x_reg) -- in return (Fixed rep x_reg code) -------------------- add_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register add_code rep x (CmmLit (CmmInt y _)) = add_int rep x y add_code rep x y = trivialCode rep (ADD rep) (Just (ADD rep)) x y -------------------- sub_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register sub_code rep x (CmmLit (CmmInt y _)) = add_int rep x (-y) sub_code rep x y = trivialCode rep (SUB rep) Nothing x y -- our three-operand add instruction: add_int rep x y = do (x_reg, x_code) <- getSomeReg x let imm = ImmInt (fromInteger y) code dst = x_code `snocOL` LEA rep (OpAddr (AddrBaseIndex (Just x_reg) Nothing imm)) (OpReg dst) -- return (Any rep code) ---------------------- div_code rep signed quotient x y = do (y_op, y_code) <- getRegOrMem y -- cannot be clobbered x_code <- getAnyReg x let widen | signed = CLTD rep | otherwise = XOR rep (OpReg edx) (OpReg edx) instr | signed = IDIV | otherwise = DIV code = y_code `appOL` x_code eax `appOL` toOL [widen, instr rep y_op] result | quotient = eax | otherwise = edx -- in return (Fixed rep result code) getRegister (CmmLoad mem pk) | isFloatingRep pk = do Amode src mem_code <- getAmode mem let code dst = mem_code `snocOL` IF_ARCH_i386(GLD pk src dst, MOV pk (OpAddr src) (OpReg dst)) -- return (Any pk code) #if i386_TARGET_ARCH getRegister (CmmLoad mem pk) | pk /= I64 = do code <- intLoadCode (instr pk) mem return (Any pk code) where instr I8 = MOVZxL pk instr I16 = MOV I16 instr I32 = MOV I32 -- we always zero-extend 8-bit loads, if we -- can't think of anything better. This is because -- we can't guarantee access to an 8-bit variant of every register -- (esi and edi don't have 8-bit variants), so to make things -- simpler we do our 8-bit arithmetic with full 32-bit registers. #endif #if x86_64_TARGET_ARCH -- Simpler memory load code on x86_64 getRegister (CmmLoad mem pk) = do code <- intLoadCode (MOV pk) mem return (Any pk code) #endif getRegister (CmmLit (CmmInt 0 rep)) = let -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits adj_rep = case rep of I64 -> I32; _ -> rep rep1 = IF_ARCH_i386( rep, adj_rep ) code dst = unitOL (XOR rep1 (OpReg dst) (OpReg dst)) in return (Any rep code) #if x86_64_TARGET_ARCH -- optimisation for loading small literals on x86_64: take advantage -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit -- instruction forms are shorter. getRegister (CmmLit lit) | I64 <- cmmLitRep lit, not (isBigLit lit) = let imm = litToImm lit code dst = unitOL (MOV I32 (OpImm imm) (OpReg dst)) in return (Any I64 code) where isBigLit (CmmInt i I64) = i < 0 || i > 0xffffffff isBigLit _ = False -- note1: not the same as is64BitLit, because that checks for -- signed literals that fit in 32 bits, but we want unsigned -- literals here. -- note2: all labels are small, because we're assuming the -- small memory model (see gcc docs, -mcmodel=small). #endif getRegister (CmmLit lit) = let rep = cmmLitRep lit imm = litToImm lit code dst = unitOL (MOV rep (OpImm imm) (OpReg dst)) in return (Any rep code) getRegister other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr -> NatM (Reg -> InstrBlock) intLoadCode instr mem = do Amode src mem_code <- getAmode mem return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) -- Compute an expression into *any* register, adding the appropriate -- move instruction if necessary. getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock) getAnyReg expr = do r <- getRegister expr anyReg r anyReg :: Register -> NatM (Reg -> InstrBlock) anyReg (Any _ code) = return code anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst) -- A bit like getSomeReg, but we want a reg that can be byte-addressed. -- Fixed registers might not be byte-addressable, so we make sure we've -- got a temporary, inserting an extra reg copy if necessary. getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) #if x86_64_TARGET_ARCH getByteReg = getSomeReg -- all regs are byte-addressable on x86_64 #else getByteReg expr = do r <- getRegister expr case r of Any rep code -> do tmp <- getNewRegNat rep return (tmp, code tmp) Fixed rep reg code | isVirtualReg reg -> return (reg,code) | otherwise -> do tmp <- getNewRegNat rep return (tmp, code `snocOL` reg2reg rep reg tmp) -- ToDo: could optimise slightly by checking for byte-addressable -- real registers, but that will happen very rarely if at all. #endif -- Another variant: this time we want the result in a register that cannot -- be modified by code to evaluate an arbitrary expression. getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) getNonClobberedReg expr = do r <- getRegister expr case r of Any rep code -> do tmp <- getNewRegNat rep return (tmp, code tmp) Fixed rep reg code -- only free regs can be clobbered | RealReg rr <- reg, isFastTrue (freeReg rr) -> do tmp <- getNewRegNat rep return (tmp, code `snocOL` reg2reg rep reg tmp) | otherwise -> return (reg, code) reg2reg :: MachRep -> Reg -> Reg -> Instr reg2reg rep src dst #if i386_TARGET_ARCH | isFloatingRep rep = GMOV src dst #endif | otherwise = MOV rep (OpReg src) (OpReg dst) #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH getRegister (StFloat d) = getBlockIdNat `thenNat` \ lbl -> getNewRegNat PtrRep `thenNat` \ tmp -> let code dst = toOL [ SEGMENT DataSegment, NEWBLOCK lbl, DATA F [ImmFloat d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in return (Any F32 code) getRegister (StDouble d) = getBlockIdNat `thenNat` \ lbl -> getNewRegNat PtrRep `thenNat` \ tmp -> let code dst = toOL [ SEGMENT DataSegment, NEWBLOCK lbl, DATA DF [ImmDouble d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in return (Any F64 code) getRegister (CmmMachOp 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_F32_Neg -> trivialUFCode F32 (FNEG F) x MO_F64_Neg -> trivialUFCode F64 (FNEG DF) x MO_F64_to_Flt -> coerceDbl2Flt x MO_F32_to_Dbl -> coerceFlt2Dbl x MO_F32_to_NatS -> coerceFP2Int F32 x MO_NatS_to_Flt -> coerceInt2FP F32 x MO_F64_to_NatS -> coerceFP2Int F64 x MO_NatS_to_Dbl -> coerceInt2FP F64 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 CmmMachOp MO_F32_to_Dbl [x] else x in getRegister (StCall (Left fn) CCallConv F64 [fixed_x]) where integerExtend signed nBits x = getRegister ( CmmMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) [CmmMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] ) conversionNop new_rep expr = getRegister expr `thenNat` \ e_code -> return (swizzleRegisterRep e_code new_rep) (is_float_op, fn) = case mop of MO_F32_Exp -> (True, FSLIT("exp")) MO_F32_Log -> (True, FSLIT("log")) MO_F32_Sqrt -> (True, FSLIT("sqrt")) MO_F32_Sin -> (True, FSLIT("sin")) MO_F32_Cos -> (True, FSLIT("cos")) MO_F32_Tan -> (True, FSLIT("tan")) MO_F32_Asin -> (True, FSLIT("asin")) MO_F32_Acos -> (True, FSLIT("acos")) MO_F32_Atan -> (True, FSLIT("atan")) MO_F32_Sinh -> (True, FSLIT("sinh")) MO_F32_Cosh -> (True, FSLIT("cosh")) MO_F32_Tanh -> (True, FSLIT("tanh")) MO_F64_Exp -> (False, FSLIT("exp")) MO_F64_Log -> (False, FSLIT("log")) MO_F64_Sqrt -> (False, FSLIT("sqrt")) MO_F64_Sin -> (False, FSLIT("sin")) MO_F64_Cos -> (False, FSLIT("cos")) MO_F64_Tan -> (False, FSLIT("tan")) MO_F64_Asin -> (False, FSLIT("asin")) MO_F64_Acos -> (False, FSLIT("acos")) MO_F64_Atan -> (False, FSLIT("atan")) MO_F64_Sinh -> (False, FSLIT("sinh")) MO_F64_Cosh -> (False, FSLIT("cosh")) MO_F64_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(sparc) - binary CmmMachOp (2)" (pprMachOp mop) getRegister (CmmMachOp 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_F32_Gt -> condFltReg GTT x y MO_F32_Ge -> condFltReg GE x y MO_F32_Eq -> condFltReg EQQ x y MO_F32_Ne -> condFltReg NE x y MO_F32_Lt -> condFltReg LTT x y MO_F32_Le -> condFltReg LE x y MO_F64_Gt -> condFltReg GTT x y MO_F64_Ge -> condFltReg GE x y MO_F64_Eq -> condFltReg EQQ x y MO_F64_Ne -> condFltReg NE x y MO_F64_Lt -> condFltReg LTT x y MO_F64_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_F32_Add -> trivialFCode F32 FADD x y MO_F32_Sub -> trivialFCode F32 FSUB x y MO_F32_Mul -> trivialFCode F32 FMUL x y MO_F32_Div -> trivialFCode F32 FDIV x y MO_F64_Add -> trivialFCode F64 FADD x y MO_F64_Sub -> trivialFCode F64 FSUB x y MO_F64_Mul -> trivialFCode F64 FMUL x y MO_F64_Div -> trivialFCode F64 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_F32_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64 [promote x, promote y]) where promote x = CmmMachOp MO_F32_to_Dbl [x] MO_F64_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64 [x, y]) other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y]) -------------------- imulMayOflo :: CmmExpr -> CmmExpr -> NatM Register imulMayOflo a1 a2 = getNewRegNat IntRep `thenNat` \ t1 -> getNewRegNat IntRep `thenNat` \ t2 -> getNewRegNat IntRep `thenNat` \ res_lo -> getNewRegNat 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 return (Any IntRep code) getRegister (CmmLoad pk mem) = do Amode src code <- getAmode mem let size = primRepToSize pk code__2 dst = code `snocOL` LD size src dst -- return (Any pk code__2) getRegister (StInt i) | fits13Bits i = let src = ImmInt (fromInteger i) code dst = unitOL (OR False g0 (RIImm src) dst) in return (Any IntRep code) getRegister leaf | isJust imm = let code dst = toOL [ SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in return (Any PtrRep code) | otherwise = ncgPrimopMoan "getRegister(sparc)" (pprCmmExpr leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH getRegister (CmmLoad mem pk) | pk /= I64 = do Amode addr addr_code <- getAmode mem let code dst = ASSERT((regClass dst == RcDouble) == isFloatingRep pk) addr_code `snocOL` LD pk dst addr return (Any pk code) -- catch simple cases of zero- or sign-extended load getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any I32 (\dst -> addr_code `snocOL` LD I8 dst addr)) -- Note: there is no Load Byte Arithmetic instruction, so no signed case here getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any I32 (\dst -> addr_code `snocOL` LD I16 dst addr)) getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any I32 (\dst -> addr_code `snocOL` LA I16 dst addr)) getRegister (CmmMachOp mop [x]) -- unary MachOps = case mop of MO_Not rep -> trivialUCode rep NOT x MO_S_Conv F64 F32 -> trivialUCode F32 FRSP x MO_S_Conv F32 F64 -> conversionNop F64 x MO_S_Conv from to | from == to -> conversionNop to x | isFloatingRep from -> coerceFP2Int from to x | isFloatingRep to -> coerceInt2FP from to x -- narrowing is a nop: we treat the high bits as undefined MO_S_Conv I32 to -> conversionNop to x MO_S_Conv I16 I8 -> conversionNop I8 x MO_S_Conv I8 to -> trivialUCode to (EXTS I8) x MO_S_Conv I16 to -> trivialUCode to (EXTS I16) x MO_U_Conv from to | from == to -> conversionNop to x -- narrowing is a nop: we treat the high bits as undefined MO_U_Conv I32 to -> conversionNop to x MO_U_Conv I16 I8 -> conversionNop I8 x MO_U_Conv I8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 I32)) MO_U_Conv I16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 I32)) MO_S_Neg F32 -> trivialUCode F32 FNEG x MO_S_Neg F64 -> trivialUCode F64 FNEG x MO_S_Neg rep -> trivialUCode rep NEG x where conversionNop new_rep expr = do e_code <- getRegister expr return (swizzleRegisterRep e_code new_rep) getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps = case mop of MO_Eq F32 -> condFltReg EQQ x y MO_Ne F32 -> condFltReg NE x y MO_S_Gt F32 -> condFltReg GTT x y MO_S_Ge F32 -> condFltReg GE x y MO_S_Lt F32 -> condFltReg LTT x y MO_S_Le F32 -> condFltReg LE x y MO_Eq F64 -> condFltReg EQQ x y MO_Ne F64 -> condFltReg NE x y MO_S_Gt F64 -> condFltReg GTT x y MO_S_Ge F64 -> condFltReg GE x y MO_S_Lt F64 -> condFltReg LTT x y MO_S_Le F64 -> condFltReg LE x y MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y) MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y) MO_S_Gt rep -> condIntReg GTT (extendSExpr rep x) (extendSExpr rep y) MO_S_Ge rep -> condIntReg GE (extendSExpr rep x) (extendSExpr rep y) MO_S_Lt rep -> condIntReg LTT (extendSExpr rep x) (extendSExpr rep y) MO_S_Le rep -> condIntReg LE (extendSExpr rep x) (extendSExpr rep y) MO_U_Gt rep -> condIntReg GU (extendUExpr rep x) (extendUExpr rep y) MO_U_Ge rep -> condIntReg GEU (extendUExpr rep x) (extendUExpr rep y) MO_U_Lt rep -> condIntReg LU (extendUExpr rep x) (extendUExpr rep y) MO_U_Le rep -> condIntReg LEU (extendUExpr rep x) (extendUExpr rep y) MO_Add F32 -> trivialCodeNoImm F32 (FADD F32) x y MO_Sub F32 -> trivialCodeNoImm F32 (FSUB F32) x y MO_Mul F32 -> trivialCodeNoImm F32 (FMUL F32) x y MO_S_Quot F32 -> trivialCodeNoImm F32 (FDIV F32) x y MO_Add F64 -> trivialCodeNoImm F64 (FADD F64) x y MO_Sub F64 -> trivialCodeNoImm F64 (FSUB F64) x y MO_Mul F64 -> trivialCodeNoImm F64 (FMUL F64) x y MO_S_Quot F64 -> trivialCodeNoImm F64 (FDIV F64) x y -- optimize addition with 32-bit immediate -- (needed for PIC) MO_Add I32 -> case y of CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate I32 True (-imm) -> trivialCode I32 True ADD x (CmmLit $ CmmInt imm immrep) CmmLit lit -> do (src, srcCode) <- getSomeReg x let imm = litToImm lit code dst = srcCode `appOL` toOL [ ADDIS dst src (HA imm), ADD dst dst (RIImm (LO imm)) ] return (Any I32 code) _ -> trivialCode I32 True ADD x y MO_Add rep -> trivialCode rep True ADD x y MO_Sub rep -> case y of -- subfi ('substract from' with immediate) doesn't exist CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) _ -> trivialCodeNoImm rep SUBF y x MO_Mul rep -> trivialCode rep True MULLW x y MO_S_MulMayOflo I32 -> trivialCodeNoImm I32 MULLW_MayOflo x y MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= I32): not implemented" MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented" MO_S_Quot rep -> trivialCodeNoImm rep DIVW (extendSExpr rep x) (extendSExpr rep y) MO_U_Quot rep -> trivialCodeNoImm rep DIVWU (extendUExpr rep x) (extendUExpr rep y) MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y) MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y) MO_And rep -> trivialCode rep False AND x y MO_Or rep -> trivialCode rep False OR x y MO_Xor rep -> trivialCode rep False XOR x y MO_Shl rep -> trivialCode rep False SLW x y MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y getRegister (CmmLit (CmmInt i rep)) | Just imm <- makeImmediate rep True i = let code dst = unitOL (LI dst imm) in return (Any rep code) getRegister (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat dynRef <- cmmMakeDynamicReference addImportNat False lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat f frep)] `consOL` (addr_code `snocOL` LD frep dst addr) return (Any frep code) getRegister (CmmLit lit) = let rep = cmmLitRep lit imm = litToImm lit code dst = toOL [ LIS dst (HI imm), OR dst dst (RIImm (LO imm)) ] in return (Any rep code) getRegister other = pprPanic "getRegister(ppc)" (pprExpr other) -- extend?Rep: wrap integer expression of type rep -- in a conversion to I32 extendSExpr I32 x = x extendSExpr rep x = CmmMachOp (MO_S_Conv rep I32) [x] extendUExpr I32 x = x extendUExpr rep x = CmmMachOp (MO_U_Conv rep I32) [x] #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. data Amode = Amode AddrMode InstrBlock {- Now, given a tree (the argument to an CmmLoad) 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) ... -} getAmode :: CmmExpr -> NatM Amode getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in return (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in return (Amode (AddrRegImm reg off) code) getAmode leaf | isJust imm = return (Amode (AddrImm imm__2) id) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in return (Amode (AddrReg reg) code) #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- This is all just ridiculous, since it carefully undoes -- what mangleIndexTree has just done. getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)]) | not (is64BitLit lit) -- ASSERT(rep == I32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (-(fromInteger i)) return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code) getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)]) | not (is64BitLit lit) -- ASSERT(rep == I32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (fromInteger i) return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code) -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be -- recognised by the next rule. getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]) = getAmode (CmmMachOp (MO_Add rep) [b,a]) getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 = do (x_reg, x_code) <- getNonClobberedReg x -- x must be in a temp, because it has to stay live over y_code -- we could compre x_reg and y_reg and do something better here... (y_reg, y_code) <- getSomeReg y let code = x_code `appOL` y_code base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8 return (Amode (AddrBaseIndex (Just x_reg) (Just (y_reg,base)) (ImmInt 0)) code) getAmode (CmmLit lit) | not (is64BitLit lit) = return (Amode (ImmAddr (litToImm lit) 0) nilOL) getAmode expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH getAmode (CmmMachOp MO_Nat_Sub [x, StInt i]) | fits13Bits (-i) = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp MO_Nat_Add [x, StInt i]) | fits13Bits i = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp MO_Nat_Add [x, y]) = getNewRegNat PtrRep `thenNat` \ tmp1 -> getNewRegNat 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 return (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | isJust imm = getNewRegNat PtrRep `thenNat` \ tmp -> let code = unitOL (SETHI (HI imm__2) tmp) in return (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other = getNewRegNat PtrRep `thenNat` \ tmp -> getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt 0 in return (Amode (AddrRegImm reg off) code) #endif /* sparc_TARGET_ARCH */ #ifdef powerpc_TARGET_ARCH getAmode (CmmMachOp (MO_Sub I32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate I32 True (-i) = do (reg, code) <- getSomeReg x return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp (MO_Add I32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate I32 True i = do (reg, code) <- getSomeReg x return (Amode (AddrRegImm reg off) code) -- optimize addition with 32-bit immediate -- (needed for PIC) getAmode (CmmMachOp (MO_Add I32) [x, CmmLit lit]) = do tmp <- getNewRegNat I32 (src, srcCode) <- getSomeReg x let imm = litToImm lit code = srcCode `snocOL` ADDIS tmp src (HA imm) return (Amode (AddrRegImm tmp (LO imm)) code) getAmode (CmmLit lit) = do tmp <- getNewRegNat I32 let imm = litToImm lit code = unitOL (LIS tmp (HA imm)) return (Amode (AddrRegImm tmp (LO imm)) code) getAmode (CmmMachOp (MO_Add I32) [x, y]) = do (regX, codeX) <- getSomeReg x (regY, codeY) <- getSomeReg y return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) getAmode other = do (reg, code) <- getSomeReg other let off = ImmInt 0 return (Amode (AddrRegImm reg off) code) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- getOperand: sometimes any operand will do. -- getNonClobberedOperand: the value of the operand will remain valid across -- the computation of an arbitrary expression, unless the expression -- is computed directly into a register which the operand refers to -- (see trivialCode where this function is used for an example). #if i386_TARGET_ARCH || x86_64_TARGET_ARCH getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand (CmmLit lit) | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = return (OpImm (litToImm lit), nilOL) getNonClobberedOperand (CmmLoad mem pk) | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do Amode src mem_code <- getAmode mem (src',save_code) <- if (amodeCouldBeClobbered src) then do tmp <- getNewRegNat wordRep return (AddrBaseIndex (Just tmp) Nothing (ImmInt 0), unitOL (LEA I32 (OpAddr src) (OpReg tmp))) else return (src, nilOL) return (OpAddr src', save_code `appOL` mem_code) getNonClobberedOperand e = do (reg, code) <- getNonClobberedReg e return (OpReg reg, code) amodeCouldBeClobbered :: AddrMode -> Bool amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode) regClobbered (RealReg rr) = isFastTrue (freeReg rr) regClobbered _ = False -- getOperand: the operand is not required to remain valid across the -- computation of an arbitrary expression. getOperand :: CmmExpr -> NatM (Operand, InstrBlock) getOperand (CmmLit lit) | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = return (OpImm (litToImm lit), nilOL) getOperand (CmmLoad mem pk) | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do Amode src mem_code <- getAmode mem return (OpAddr src, mem_code) getOperand e = do (reg, code) <- getNonClobberedReg e return (OpReg reg, code) isOperand :: CmmExpr -> Bool isOperand (CmmLoad _ _) = True isOperand (CmmLit lit) = not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) isOperand _ = False getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) getRegOrMem (CmmLoad mem pk) | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do Amode src mem_code <- getAmode mem return (OpAddr src, mem_code) getRegOrMem e = do (reg, code) <- getNonClobberedReg e return (OpReg reg, code) #if x86_64_TARGET_ARCH is64BitLit (CmmInt i I64) = i > 0x7fffffff || i < -0x80000000 -- assume that labels are in the range 0-2^31-1: this assumes the -- small memory model (see gcc docs, -mcmodel=small). #endif is64BitLit x = False #endif -- ----------------------------------------------------------------------------- -- The 'CondCode' type: Condition codes passed up the tree. data CondCode = CondCode Bool Cond InstrBlock -- Set up a condition code for a conditional branch. getCondCode :: CmmExpr -> NatM CondCode -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH -- yes, they really do seem to want exactly the same! getCondCode (CmmMachOp mop [x, y]) = ASSERT (cmmExprRep x /= I8) -- tmp, not set up to handle 8-bit comparisons case mop of MO_Eq F32 -> condFltCode EQQ x y MO_Ne F32 -> condFltCode NE x y MO_S_Gt F32 -> condFltCode GTT x y MO_S_Ge F32 -> condFltCode GE x y MO_S_Lt F32 -> condFltCode LTT x y MO_S_Le F32 -> condFltCode LE x y MO_Eq F64 -> condFltCode EQQ x y MO_Ne F64 -> condFltCode NE x y MO_S_Gt F64 -> condFltCode GTT x y MO_S_Ge F64 -> condFltCode GE x y MO_S_Lt F64 -> condFltCode LTT x y MO_S_Le F64 -> condFltCode LE x y MO_Eq rep -> condIntCode EQQ x y MO_Ne rep -> condIntCode NE x y MO_S_Gt rep -> condIntCode GTT x y MO_S_Ge rep -> condIntCode GE x y MO_S_Lt rep -> condIntCode LTT x y MO_S_Le rep -> condIntCode LE x y MO_U_Gt rep -> condIntCode GU x y MO_U_Ge rep -> condIntCode GEU x y MO_U_Lt rep -> condIntCode LU x y MO_U_Le rep -> condIntCode LEU x y other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop) getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) #elif powerpc_TARGET_ARCH -- almost the same as everywhere else - but we need to -- extend small integers to 32 bit first getCondCode (CmmMachOp mop [x, y]) = case mop of MO_Eq F32 -> condFltCode EQQ x y MO_Ne F32 -> condFltCode NE x y MO_S_Gt F32 -> condFltCode GTT x y MO_S_Ge F32 -> condFltCode GE x y MO_S_Lt F32 -> condFltCode LTT x y MO_S_Le F32 -> condFltCode LE x y MO_Eq F64 -> condFltCode EQQ x y MO_Ne F64 -> condFltCode NE x y MO_S_Gt F64 -> condFltCode GTT x y MO_S_Ge F64 -> condFltCode GE x y MO_S_Lt F64 -> condFltCode LTT x y MO_S_Le F64 -> condFltCode LE x y MO_Eq rep -> condIntCode EQQ (extendUExpr rep x) (extendUExpr rep y) MO_Ne rep -> condIntCode NE (extendUExpr rep x) (extendUExpr rep y) MO_S_Gt rep -> condIntCode GTT (extendSExpr rep x) (extendSExpr rep y) MO_S_Ge rep -> condIntCode GE (extendSExpr rep x) (extendSExpr rep y) MO_S_Lt rep -> condIntCode LTT (extendSExpr rep x) (extendSExpr rep y) MO_S_Le rep -> condIntCode LE (extendSExpr rep x) (extendSExpr rep y) MO_U_Gt rep -> condIntCode GU (extendUExpr rep x) (extendUExpr rep y) MO_U_Ge rep -> condIntCode GEU (extendUExpr rep x) (extendUExpr rep y) MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y) MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y) other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) getCondCode other = panic "getCondCode(2)(powerpc)" #endif -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be -- passed back up the tree. condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> 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 || x86_64_TARGET_ARCH -- memory vs immediate condIntCode cond (CmmLoad x pk) (CmmLit lit) | not (is64BitLit lit) = do Amode x_addr x_code <- getAmode x let imm = litToImm lit code = x_code `snocOL` CMP pk (OpImm imm) (OpAddr x_addr) -- return (CondCode False cond code) -- anything vs zero condIntCode cond x (CmmLit (CmmInt 0 pk)) = do (x_reg, x_code) <- getSomeReg x let code = x_code `snocOL` TEST pk (OpReg x_reg) (OpReg x_reg) -- return (CondCode False cond code) -- anything vs operand condIntCode cond x y | isOperand y = do (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` CMP (cmmExprRep x) y_op (OpReg x_reg) -- in return (CondCode False cond code) -- anything vs anything condIntCode cond x y = do (y_reg, y_code) <- getNonClobberedReg y (x_op, x_code) <- getRegOrMem x let code = y_code `appOL` x_code `snocOL` CMP (cmmExprRep x) (OpReg y_reg) x_op -- in return (CondCode False cond code) #endif #if i386_TARGET_ARCH condFltCode cond x y = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do (x_reg, x_code) <- getNonClobberedReg x (y_reg, y_code) <- getSomeReg y let code = x_code `appOL` y_code `snocOL` GCMP cond x_reg y_reg -- 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. return (CondCode True EQQ code) #endif /* i386_TARGET_ARCH */ #if x86_64_TARGET_ARCH -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be -- an operand, but the right must be a reg. We can probably do better -- than this general case... condFltCode cond x y = do (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` CMP (cmmExprRep x) y_op (OpReg x_reg) -- in return (CondCode False (condToUnsigned cond) code) -- we need to use the unsigned comparison operators on the -- result of this comparison. #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH condIntCode cond x (StInt y) | fits13Bits y = getRegister x `thenNat` \ register -> getNewRegNat 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 return (CondCode False cond code__2) condIntCode cond x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat IntRep `thenNat` \ tmp1 -> getNewRegNat 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 return (CondCode False cond code__2) ----------- condFltCode cond x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat (registerRep register1) `thenNat` \ tmp1 -> getNewRegNat (registerRep register2) `thenNat` \ tmp2 -> getNewRegNat F64 `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 == F32 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 return (CondCode True cond code__2) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH -- ###FIXME: I16 and I8! condIntCode cond x (CmmLit (CmmInt y rep)) | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y = do (src1, code) <- getSomeReg x let code' = code `snocOL` (if condUnsigned cond then CMPL else CMP) I32 src1 (RIImm src2) return (CondCode False cond code') condIntCode cond x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code' = code1 `appOL` code2 `snocOL` (if condUnsigned cond then CMPL else CMP) I32 src1 (RIReg src2) return (CondCode False cond code') condFltCode cond x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 code'' = case cond of -- twiddle CR to handle unordered case GE -> code' `snocOL` CRNOR ltbit eqbit gtbit LE -> code' `snocOL` CRNOR gtbit eqbit ltbit _ -> code' where ltbit = 0 ; eqbit = 2 ; gtbit = 1 return (CondCode True cond code'') #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- 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). assignMem_IntCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock assignReg_IntCode :: MachRep -> CmmReg -> CmmExpr -> NatM InstrBlock assignMem_FltCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock assignReg_FltCode :: MachRep -> CmmReg -> CmmExpr -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH assignIntCode pk (CmmLoad dst _) src = getNewRegNat 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 return 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 return code__2 #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- integer assignment to memory assignMem_IntCode pk addr src = do Amode addr code_addr <- getAmode addr (code_src, op_src) <- get_op_RI src let code = code_src `appOL` code_addr `snocOL` MOV pk op_src (OpAddr addr) -- NOTE: op_src is stable, so it will still be valid -- after code_addr. This may involve the introduction -- of an extra MOV to a temporary register, but we hope -- the register allocator will get rid of it. -- return code where get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator get_op_RI (CmmLit lit) | not (is64BitLit lit) = return (nilOL, OpImm (litToImm lit)) get_op_RI op = do (reg,code) <- getNonClobberedReg op return (code, OpReg reg) -- Assign; dst is a reg, rhs is mem assignReg_IntCode pk reg (CmmLoad src _) = do load_code <- intLoadCode (MOV pk) src return (load_code (getRegisterReg reg)) -- dst is a reg, but src could be anything assignReg_IntCode pk reg src = do code <- getAnyReg src return (code (getRegisterReg reg)) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignMem_IntCode pk addr src = getNewRegNat 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 return code__2 assignReg_IntCode pk reg src = getRegister src `thenNat` \ register2 -> getRegisterReg reg `thenNat` \ register1 -> getNewRegNat 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 return code__2 #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH assignMem_IntCode pk addr src = do (srcReg, code) <- getSomeReg src Amode dstAddr addr_code <- getAmode addr return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr -- dst is a reg, but src could be anything assignReg_IntCode pk reg src = do r <- getRegister src return $ case r of Any _ code -> code dst Fixed _ freg fcode -> fcode `snocOL` MR dst freg where dst = getRegisterReg reg #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- Floating-point assignments #if alpha_TARGET_ARCH assignFltCode pk (CmmLoad dst _) src = getNewRegNat 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 return 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 return code__2 #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- Floating point assignment to memory assignMem_FltCode pk addr src = do (src_reg, src_code) <- getNonClobberedReg src Amode addr addr_code <- getAmode addr let code = src_code `appOL` addr_code `snocOL` IF_ARCH_i386(GST pk src_reg addr, MOV pk (OpReg src_reg) (OpAddr addr)) return code -- Floating point assignment to a register/temporary assignReg_FltCode pk reg src = do src_code <- getAnyReg src return (src_code (getRegisterReg reg)) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -- Floating point assignment to memory assignMem_FltCode pk addr src = getNewRegNat 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 return 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 getNewRegNat 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 return code__2 #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH -- Easy, isn't it? assignMem_FltCode = assignMem_IntCode assignReg_FltCode = assignReg_IntCode #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- Generating an non-local jump -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH genJump (CmmLabel 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 -> getNewRegNat 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 return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH genJump (CmmLoad mem pk) = do Amode target code <- getAmode mem return (code `snocOL` JMP (OpAddr target)) genJump (CmmLit lit) = do return (unitOL (JMP (OpImm (litToImm lit)))) genJump expr = do (reg,code) <- getSomeReg expr return (code `snocOL` JMP (OpReg reg)) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genJump (CmmLabel lbl) = return (toOL [CALL (Left target) 0 True, NOP]) where target = ImmCLbl lbl genJump tree = getRegister tree `thenNat` \ register -> getNewRegNat PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in return (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH genJump (CmmLit (CmmLabel lbl)) = return (unitOL $ JMP lbl) genJump tree = do (target,code) <- getSomeReg tree return (code `snocOL` MTCTR target `snocOL` BCTR []) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- Unconditional branches genBranch :: BlockId -> NatM InstrBlock #if alpha_TARGET_ARCH genBranch id = return (unitOL (BR id)) #endif #if i386_TARGET_ARCH || x86_64_TARGET_ARCH genBranch id = return (unitOL (JXX ALWAYS id)) #endif #if sparc_TARGET_ARCH genBranch id = return (toOL [BI ALWAYS False id, NOP]) #endif #if powerpc_TARGET_ARCH genBranch id = return (unitOL (BCC ALWAYS id)) #endif -- ----------------------------------------------------------------------------- -- 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. -} genCondJump :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH genCondJump id (StPrim op [x, StInt 0]) = getRegister x `thenNat` \ register -> getNewRegNat (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 -> getNewRegNat (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in return (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 -> getNewRegNat F64 `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in return (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 -> getNewRegNat IntRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in return (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 || x86_64_TARGET_ARCH genCondJump id bool = do CondCode _ cond code <- getCondCode bool return (code `snocOL` JXX cond id) #endif /* i386_TARGET_ARCH */ #if sparc_TARGET_ARCH genCondJump id bool = do CondCode is_float cond code <- getCondCode bool return ( code `appOL` toOL ( if is_float then [NOP, BF cond False id, NOP] else [BI cond False id, NOP] ) ) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH genCondJump id bool = do CondCode is_float cond code <- getCondCode bool return (code `snocOL` BCC cond id) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- 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. genCCall :: CmmCallTarget -- function to call -> [(CmmReg,MachHint)] -- where to put the result -> [(CmmExpr,MachHint)] -- arguments (of mixed type) -> Maybe [GlobalReg] -- volatile regs to save -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH ccallResultRegs = genCCall fn cconv result_regs 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 return ( 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 -> getNewRegNat (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register sz = primRepToSize pk in return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -- we only cope with a single result for foreign calls genCCall (CmmPrim op) [(r,_)] args vols = do case op of MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args MO_F32_Sin -> actuallyInlineFloatOp F32 (GSIN F32) args MO_F64_Sin -> actuallyInlineFloatOp F64 (GSIN F64) args MO_F32_Cos -> actuallyInlineFloatOp F32 (GCOS F32) args MO_F64_Cos -> actuallyInlineFloatOp F64 (GCOS F64) args MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args other_op -> outOfLineFloatOp op r args vols where actuallyInlineFloatOp rep instr [(x,_)] = do res <- trivialUFCode rep instr x any <- anyReg res return (any (getRegisterReg r)) genCCall target dest_regs args vols = do sizes_n_codes <- mapM push_arg (reverse args) delta <- getDeltaNat let (sizes, push_codes) = unzip sizes_n_codes tot_arg_size = sum sizes -- in -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of -- CmmPrim -> ... CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm)), conv) where fn_imm = ImmCLbl lbl CmmForeignCall expr conv -> do (dyn_c, dyn_r, dyn_rep) <- get_op expr ASSERT(dyn_rep == I32) return (dyn_c `snocOL` CALL (Right dyn_r), conv) 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 || tot_arg_size==0 then [] else [ADD I32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) ++ [DELTA (delta + tot_arg_size)] ) -- in setDeltaNat (delta + tot_arg_size) let -- assign the results, if necessary assign_code [] = nilOL assign_code [(dest,_hint)] = case rep of I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest), MOV I32 (OpReg edx) (OpReg r_dest_hi)] F32 -> unitOL (GMOV fake0 r_dest) F64 -> unitOL (GMOV fake0 r_dest) rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest)) where r_dest_hi = getHiVRegFromLo r_dest rep = cmmRegRep dest r_dest = getRegisterReg dest assign_code many = panic "genCCall.assign_code many" return (push_code `appOL` call `appOL` assign_code dest_regs) where arg_size F64 = 8 arg_size F32 = 4 arg_size _ = 4 push_arg :: (CmmExpr,MachHint){-current argument-} -> NatM (Int, InstrBlock) -- argsz, code push_arg (arg,_hint) -- we don't need the hints on x86 | arg_rep == I64 = do ChildCode64 code r_lo <- iselExpr64 arg delta <- getDeltaNat setDeltaNat (delta - 8) let r_hi = getHiVRegFromLo r_lo -- in return (8, code `appOL` toOL [PUSH I32 (OpReg r_hi), DELTA (delta - 4), PUSH I32 (OpReg r_lo), DELTA (delta - 8), DELTA (delta-8)] ) | otherwise = do (code, reg, sz) <- get_op arg delta <- getDeltaNat let size = arg_size sz setDeltaNat (delta-size) if (case sz of F64 -> True; F32 -> True; _ -> False) then return (size, code `appOL` toOL [SUB I32 (OpImm (ImmInt size)) (OpReg esp), DELTA (delta-size), GST sz reg (AddrBaseIndex (Just esp) Nothing (ImmInt 0))] ) else return (size, code `snocOL` PUSH I32 (OpReg reg) `snocOL` DELTA (delta-size) ) where arg_rep = cmmExprRep arg ------------ get_op :: CmmExpr -> NatM (InstrBlock, Reg, MachRep) -- code, reg, size get_op op = do (reg,code) <- getSomeReg op return (code, reg, cmmExprRep op) #endif /* i386_TARGET_ARCH */ #if i386_TARGET_ARCH || x86_64_TARGET_ARCH outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)] -> Maybe [GlobalReg] -> NatM InstrBlock outOfLineFloatOp mop res args vols | cmmRegRep res == F64 = stmtToInstrs (CmmCall target [(res,FloatHint)] args vols) | otherwise = do uq <- getUniqueNat let tmp = CmmLocal (LocalReg uq F64) -- in code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] (map promote args) vols) code2 <- stmtToInstrs (CmmAssign res (demote (CmmReg tmp))) return (code1 `appOL` code2) where promote (x,hint) = (CmmMachOp (MO_S_Conv F32 F64) [x], hint) demote x = CmmMachOp (MO_S_Conv F64 F32) [x] target = CmmForeignCall (CmmLit lbl) CCallConv lbl = CmmLabel (mkForeignLabel fn Nothing False) fn = case mop of MO_F32_Sqrt -> FSLIT("sqrt") MO_F32_Sin -> FSLIT("sin") MO_F32_Cos -> FSLIT("cos") MO_F32_Tan -> FSLIT("tan") MO_F32_Exp -> FSLIT("exp") MO_F32_Log -> FSLIT("log") MO_F32_Asin -> FSLIT("asin") MO_F32_Acos -> FSLIT("acos") MO_F32_Atan -> FSLIT("atan") MO_F32_Sinh -> FSLIT("sinh") MO_F32_Cosh -> FSLIT("cosh") MO_F32_Tanh -> FSLIT("tanh") MO_F32_Pwr -> FSLIT("pow") MO_F64_Sqrt -> FSLIT("sqrt") MO_F64_Sin -> FSLIT("sin") MO_F64_Cos -> FSLIT("cos") MO_F64_Tan -> FSLIT("tan") MO_F64_Exp -> FSLIT("exp") MO_F64_Log -> FSLIT("log") MO_F64_Asin -> FSLIT("asin") MO_F64_Acos -> FSLIT("acos") MO_F64_Atan -> FSLIT("atan") MO_F64_Sinh -> FSLIT("sinh") MO_F64_Cosh -> FSLIT("cosh") MO_F64_Tanh -> FSLIT("tanh") MO_F64_Pwr -> FSLIT("pow") other -> pprPanic "outOfLineFloatOp" (pprCallishMachOp mop) #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if x86_64_TARGET_ARCH genCCall (CmmPrim op) [(r,_)] args vols = outOfLineFloatOp op r args vols genCCall target dest_regs args vols = do -- load up the register arguments (stack_args, sse_regs, load_args_code) <- load_args args allArgRegs allFPArgRegs 0 nilOL let tot_arg_size = arg_size * length stack_args -- On entry to the called function, %rsp should be aligned -- on a 16-byte boundary +8 (i.e. the first stack arg after -- the return address is 16-byte aligned). In STG land -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just -- need to make sure we push a multiple of 16-bytes of args, -- plus the return address, to get the correct alignment. -- Urg, this is hard. We need to feed the delta back into -- the arg pushing code. (real_size, adjust_rsp) <- if tot_arg_size `rem` 16 == 0 then return (tot_arg_size, nilOL) else do -- we need to adjust... delta <- getDeltaNat setDeltaNat (delta-8) return (tot_arg_size+8, toOL [ SUB I64 (OpImm (ImmInt 8)) (OpReg rsp), DELTA (delta-8) ]) -- push the stack args, right to left push_code <- push_args (reverse stack_args) nilOL delta <- getDeltaNat -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of -- CmmPrim -> ... CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm)), conv) where fn_imm = ImmCLbl lbl CmmForeignCall expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r), conv) let -- The x86_64 ABI requires us to set %al to the number of SSE -- registers that contain arguments, if the called routine -- is a varargs function. We don't know whether it's a -- varargs function or not, so we have to assume it is. -- -- It's not safe to omit this assignment, even if the number -- of SSE regs in use is zero. If %al is larger than 8 -- on entry to a varargs function, seg faults ensue. assign_eax n = unitOL (MOV I32 (OpImm (ImmInt n)) (OpReg eax)) let call = callinsns `appOL` toOL ( -- Deallocate parameters after call for ccall; -- but not for stdcall (callee does it) (if cconv == StdCallConv || real_size==0 then [] else [ADD wordRep (OpImm (ImmInt real_size)) (OpReg esp)]) ++ [DELTA (delta + real_size)] ) -- in setDeltaNat (delta + real_size) let -- assign the results, if necessary assign_code [] = nilOL assign_code [(dest,_hint)] = case rep of F32 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) F64 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) rep -> unitOL (MOV rep (OpReg rax) (OpReg r_dest)) where rep = cmmRegRep dest r_dest = getRegisterReg dest assign_code many = panic "genCCall.assign_code many" return (load_args_code `appOL` adjust_rsp `appOL` push_code `appOL` assign_eax sse_regs `appOL` call `appOL` assign_code dest_regs) where arg_size = 8 -- always, at the mo load_args :: [(CmmExpr,MachHint)] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> Int -> InstrBlock -> NatM ([(CmmExpr,MachHint)],Int,InstrBlock) load_args args [] [] sse_regs code = return (args, sse_regs, code) -- no more regs to use load_args [] aregs fregs sse_regs code = return ([],sse_regs,code) -- no more args to push load_args ((arg,hint) : rest) aregs fregs sse_regs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg (r:rs) -> do arg_code <- getAnyReg arg load_args rest aregs rs (sse_regs+1) (code `appOL` arg_code r) | otherwise = case aregs of [] -> push_this_arg (r:rs) -> do arg_code <- getAnyReg arg load_args rest rs fregs sse_regs (code `appOL` arg_code r) where arg_rep = cmmExprRep arg push_this_arg = do (args',sse',code') <- load_args rest aregs fregs sse_regs code return ((arg,hint):args', sse', code') push_args [] code = return code push_args ((arg,hint):rest) code | isFloatingRep arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat setDeltaNat (delta-arg_size) let code' = code `appOL` toOL [ MOV arg_rep (OpReg arg_reg) (OpAddr (spRel 0)), SUB wordRep (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size)] push_args rest code' | otherwise = do -- we only ever generate word-sized function arguments. Promotion -- has already happened: our Int8# type is kept sign-extended -- in an Int#, for example. ASSERT(arg_rep == I64) return () (arg_op, arg_code) <- getOperand arg delta <- getDeltaNat setDeltaNat (delta-arg_size) let code' = code `appOL` toOL [PUSH I64 arg_op, DELTA (delta-arg_size)] push_args rest code' where arg_rep = cmmExprRep arg #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #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 -> return (unitOL (CALL (Left fn__2) n_argRegs_used False)) Right dyn -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) -> return (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 return (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) _ -> ImmCLbl (mkForeignLabel fn_static False) -- 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 :: CmmExpr -> NatM (OrdList Instr, [Reg]) arg_to_int_vregs arg | is64BitRep (repOfCmmExpr arg) = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) -> let r_lo = VirtualRegI vr_lo r_hi = getHiVRegFromLo r_lo in return (code, [r_hi, r_lo]) | otherwise = getRegister arg `thenNat` \ register -> getNewRegNat (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 F64 -> getNewRegNat WordRep `thenNat` \ v1 -> getNewRegNat WordRep `thenNat` \ v2 -> return ( 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] ) F32 -> getNewRegNat WordRep `thenNat` \ v1 -> return ( code `snocOL` ST F src (spRel 16) `snocOL` LD W (spRel 16) v1 , [v1] ) other -> getNewRegNat WordRep `thenNat` \ v1 -> return ( code `snocOL` OR False g0 (RIReg src) v1 , [v1] ) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH #if darwin_TARGET_OS || linux_TARGET_OS {- The PowerPC calling convention for Darwin/Mac OS X is described in Apple's document "Inside Mac OS X - Mach-O Runtime Architecture". PowerPC Linux uses the System V Release 4 Calling Convention for PowerPC. It is described in the "System V Application Binary Interface PowerPC Processor Supplement". Both conventions are similar: Parameters may be passed in general-purpose registers starting at r3, in floating point registers starting at f1, or on the stack. But there are substantial differences: * The number of registers used for parameter passing and the exact set of nonvolatile registers differs (see MachRegs.lhs). * On Darwin, 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. * On Darwin, a corresponding amount of GPRs is skipped when a floating point parameter is passed in an FPR. * SysV insists on either passing I64 arguments on the stack, or in two GPRs, starting with an odd-numbered GPR. It may skip a GPR to achieve this. Darwin just treats an I64 like two separate I32s (high word first). * I64 and F64 arguments are 8-byte aligned on the stack for SysV, but only 4-byte aligned like everything else on Darwin. * The SysV spec claims that F32 is represented as F64 on the stack. GCC on PowerPC Linux does not agree, so neither do we. According to both conventions, 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 stack for register spilling, leaving 64 bytes free at the top. If we need a larger parameter area than that, we just allocate a new stack frame just before ccalling. -} genCCall target dest_regs argsAndHints vols = ASSERT (not $ any (`elem` [I8,I16]) argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments (zip args argReps) allArgRegs allFPArgRegs initialStackOffset (toOL []) [] (labelOrExpr, reduceToF32) <- case target of CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) CmmForeignCall expr conv -> return (Right expr, False) CmmPrim mop -> outOfLineFloatOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToF32 case labelOrExpr of Left lbl -> do return ( codeBefore `snocOL` BL lbl usedRegs `appOL` codeAfter) Right dyn -> do (dynReg, dynCode) <- getSomeReg dyn return ( dynCode `snocOL` MTCTR dynReg `appOL` codeBefore `snocOL` BCTRL usedRegs `appOL` codeAfter) where #if darwin_TARGET_OS initialStackOffset = 24 -- size of linkage area + size of arguments, in bytes stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $ map machRepByteWidth argReps #elif linux_TARGET_OS initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif args = map fst argsAndHints argReps = map cmmExprRep args roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) move_sp_down finalStack | delta > 64 = toOL [STU I32 sp (AddrRegImm sp (ImmInt (-delta))), DELTA (-delta)] | otherwise = nilOL where delta = stackDelta finalStack move_sp_up finalStack | delta > 64 = toOL [ADD sp sp (RIImm (ImmInt delta)), DELTA 0] | otherwise = nilOL where delta = stackDelta finalStack passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) passArguments ((arg,I64):args) gprs fprs stackOffset accumCode accumUsed = do ChildCode64 code vr_lo <- iselExpr64 arg let vr_hi = getHiVRegFromLo vr_lo #if darwin_TARGET_OS passArguments args (drop 2 gprs) fprs (stackOffset+8) (accumCode `appOL` code `snocOL` storeWord vr_hi gprs stackOffset `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) ((take 2 gprs) ++ accumUsed) where storeWord vr (gpr:_) offset = MR gpr vr storeWord vr [] offset = ST I32 vr (AddrRegImm sp (ImmInt offset)) #elif linux_TARGET_OS let stackOffset' = roundTo 8 stackOffset stackCode = accumCode `appOL` code `snocOL` ST I32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) `snocOL` ST I32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) regCode hireg loreg = accumCode `appOL` code `snocOL` MR hireg vr_hi `snocOL` MR loreg vr_lo case gprs of hireg : loreg : regs | even (length gprs) -> passArguments args regs fprs stackOffset (regCode hireg loreg) (hireg : loreg : accumUsed) _skipped : hireg : loreg : regs -> passArguments args regs fprs stackOffset (regCode hireg loreg) (hireg : loreg : accumUsed) _ -> -- only one or no regs left passArguments args [] fprs (stackOffset'+8) stackCode accumUsed #endif passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed | reg : _ <- regs = do register <- getRegister arg let code = case register of Fixed _ freg fcode -> fcode `snocOL` MR reg freg Any _ acode -> acode reg passArguments args (drop nGprs gprs) (drop nFprs fprs) #if darwin_TARGET_OS -- The Darwin ABI requires that we reserve stack slots for register parameters (stackOffset + stackBytes) #elif linux_TARGET_OS -- ... the SysV ABI doesn't. stackOffset #endif (accumCode `appOL` code) (reg : accumUsed) | otherwise = do (vr, code) <- getSomeReg arg passArguments args (drop nGprs gprs) (drop nFprs fprs) (stackOffset' + stackBytes) (accumCode `appOL` code `snocOL` ST rep vr stackSlot) accumUsed where #if darwin_TARGET_OS -- stackOffset is at least 4-byte aligned -- The Darwin ABI is happy with that. stackOffset' = stackOffset #else -- ... the SysV ABI requires 8-byte alignment for doubles. stackOffset' | rep == F64 = roundTo 8 stackOffset | otherwise = stackOffset #endif stackSlot = AddrRegImm sp (ImmInt stackOffset') (nGprs, nFprs, stackBytes, regs) = case rep of I32 -> (1, 0, 4, gprs) #if darwin_TARGET_OS -- The Darwin ABI requires that we skip a corresponding number of GPRs when -- we use the FPRs. F32 -> (1, 1, 4, fprs) F64 -> (2, 1, 8, fprs) #elif linux_TARGET_OS -- ... the SysV ABI doesn't. F32 -> (0, 1, 4, fprs) F64 -> (0, 1, 8, fprs) #endif moveResult reduceToF32 = case dest_regs of [] -> nilOL [(dest, _hint)] | reduceToF32 && rep == F32 -> unitOL (FRSP r_dest f1) | rep == F32 || rep == F64 -> unitOL (MR r_dest f1) | rep == I64 -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegRep dest r_dest = getRegisterReg dest outOfLineFloatOp mop = do mopExpr <- cmmMakeDynamicReference addImportNat True $ mkForeignLabel functionName Nothing True let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl _ -> Right mopExpr return (mopLabelOrExpr, reduce) where (functionName, reduce) = case mop of MO_F32_Exp -> (FSLIT("exp"), True) MO_F32_Log -> (FSLIT("log"), True) MO_F32_Sqrt -> (FSLIT("sqrt"), True) MO_F32_Sin -> (FSLIT("sin"), True) MO_F32_Cos -> (FSLIT("cos"), True) MO_F32_Tan -> (FSLIT("tan"), True) MO_F32_Asin -> (FSLIT("asin"), True) MO_F32_Acos -> (FSLIT("acos"), True) MO_F32_Atan -> (FSLIT("atan"), True) MO_F32_Sinh -> (FSLIT("sinh"), True) MO_F32_Cosh -> (FSLIT("cosh"), True) MO_F32_Tanh -> (FSLIT("tanh"), True) MO_F32_Pwr -> (FSLIT("pow"), True) MO_F64_Exp -> (FSLIT("exp"), False) MO_F64_Log -> (FSLIT("log"), False) MO_F64_Sqrt -> (FSLIT("sqrt"), False) MO_F64_Sin -> (FSLIT("sin"), False) MO_F64_Cos -> (FSLIT("cos"), False) MO_F64_Tan -> (FSLIT("tan"), False) MO_F64_Asin -> (FSLIT("asin"), False) MO_F64_Acos -> (FSLIT("acos"), False) MO_F64_Atan -> (FSLIT("atan"), False) MO_F64_Sinh -> (FSLIT("sinh"), False) MO_F64_Cosh -> (FSLIT("cosh"), False) MO_F64_Tanh -> (FSLIT("tanh"), False) MO_F64_Pwr -> (FSLIT("pow"), False) other -> pprPanic "genCCall(ppc): unknown callish op" (pprCallishMachOp other) #endif /* darwin_TARGET_OS || linux_TARGET_OS */ #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- Generating a table-branch genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock #if i386_TARGET_ARCH || x86_64_TARGET_ARCH genSwitch expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat let jumpTable = map jumpTableEntry ids op = OpAddr (AddrBaseIndex Nothing (Just (reg,wORD_SIZE)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), JMP_TBL op [ id | Just id <- ids ] ] -- in return code #elif powerpc_TARGET_ARCH genSwitch expr ids | opt_PIC = do (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat I32 lbl <- getNewLabelNat dynRef <- cmmMakeDynamicReference addImportNat False lbl (tableReg,t_code) <- getSomeReg $ dynRef let jumpTable = map jumpTableEntryRel ids jumpTableEntryRel Nothing = CmmStaticLit (CmmInt 0 wordRep) jumpTableEntryRel (Just (BlockId id)) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel id code = e_code `appOL` t_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), SLW tmp reg (RIImm (ImmInt 2)), LD I32 tmp (AddrRegReg tableReg tmp), ADD tmp tmp (RIReg tableReg), MTCTR tmp, BCTR [ id | Just id <- ids ] ] return code | otherwise = do (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat I32 lbl <- getNewLabelNat let jumpTable = map jumpTableEntry ids code = e_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), SLW tmp reg (RIImm (ImmInt 2)), ADDIS tmp tmp (HA (ImmCLbl lbl)), LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), MTCTR tmp, BCTR [ id | Just id <- ids ] ] return code #else genSwitch expr ids = panic "ToDo: genSwitch" #endif jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordRep) jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel id -- ----------------------------------------------------------------------------- -- Support bits -- ----------------------------------------------------------------------------- -- ----------------------------------------------------------------------------- -- '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. condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> 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 || x86_64_TARGET_ARCH condIntReg cond x y = do CondCode _ cond cond_code <- condIntCode cond x y tmp <- getNewRegNat I8 let code dst = cond_code `appOL` toOL [ SETCC cond (OpReg tmp), MOV I32 (OpReg tmp) (OpReg dst), AND I32 (OpImm (ImmInt 1)) (OpReg dst) ] -- NB. (1) Tha AND is needed here because the x86 only -- sets the low byte in the SETCC instruction. -- NB. (2) The extra temporary register is a hack to -- work around the fact that the setcc instructions only -- accept byte registers. dst might not be a byte-able reg, -- but currently all free registers are byte-able, so we're -- guaranteed that a new temporary is byte-able. -- in return (Any I32 code) condFltReg cond x y = do lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat CondCode _ cond cond_code <- condFltCode cond x y let code dst = cond_code `appOL` toOL [ JXX cond lbl1, MOV I32 (OpImm (ImmInt 0)) (OpReg dst), JXX ALWAYS lbl2, NEWBLOCK lbl1, MOV I32 (OpImm (ImmInt 1)) (OpReg dst), JXX ALWAYS lbl2, NEWBLOCK lbl2] -- SIGH, have to split up this block somehow... -- in return (Any I32 code) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH condIntReg EQQ x (StInt 0) = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any IntRep code__2) condIntReg EQQ x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat IntRep `thenNat` \ tmp1 -> getNewRegNat 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 return (Any IntRep code__2) condIntReg NE x (StInt 0) = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any IntRep code__2) condIntReg NE x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat IntRep `thenNat` \ tmp1 -> getNewRegNat 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 return (Any IntRep code__2) condIntReg cond x y = getBlockIdNat `thenNat` \ lbl1 -> getBlockIdNat `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, NEWBLOCK lbl1, OR False g0 (RIImm (ImmInt 1)) dst, NEWBLOCK lbl2] in return (Any IntRep code__2) condFltReg cond x y = getBlockIdNat `thenNat` \ lbl1 -> getBlockIdNat `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, NEWBLOCK lbl1, OR False g0 (RIImm (ImmInt 1)) dst, NEWBLOCK lbl2] in return (Any IntRep code__2) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH condReg getCond = do lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat CondCode _ cond cond_code <- getCond let {- code dst = cond_code `appOL` toOL [ BCC cond lbl1, LI dst (ImmInt 0), BCC ALWAYS lbl2, NEWBLOCK lbl1, LI dst (ImmInt 1), BCC ALWAYS lbl2, NEWBLOCK lbl2 ]-} code dst = cond_code `appOL` negate_code `appOL` toOL [ MFCR dst, RLWINM dst dst (bit + 1) 31 31 ] negate_code | do_negate = unitOL (CRNOR bit bit bit) | otherwise = nilOL (bit, do_negate) = case cond of LTT -> (0, False) LE -> (1, True) EQQ -> (2, False) GE -> (0, True) GTT -> (1, False) NE -> (2, True) LU -> (0, False) LEU -> (1, True) GEU -> (0, True) GU -> (1, False) return (Any I32 code) condIntReg cond x y = condReg (condIntCode cond x y) condFltReg cond x y = condReg (condFltCode cond x y) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- '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. trivialCode :: MachRep -> IF_ARCH_alpha((Reg -> RI -> Reg -> Instr) ,IF_ARCH_i386 ((Operand -> Operand -> Instr) -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_x86_64 ((Operand -> Operand -> Instr) -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,IF_ARCH_powerpc(Bool -> (Reg -> Reg -> RI -> Instr) ,))))) -> CmmExpr -> CmmExpr -- the two arguments -> NatM Register #ifndef powerpc_TARGET_ARCH trivialFCode :: MachRep -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_i386 ((MachRep -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_x86_64 ((MachRep -> Operand -> Operand -> Instr) ,)))) -> CmmExpr -> CmmExpr -- the two arguments -> NatM Register #endif trivialUCode :: MachRep -> IF_ARCH_alpha((RI -> Reg -> Instr) ,IF_ARCH_i386 ((Operand -> Instr) ,IF_ARCH_x86_64 ((Operand -> Instr) ,IF_ARCH_sparc((RI -> Reg -> Instr) ,IF_ARCH_powerpc((Reg -> Reg -> Instr) ,))))) -> CmmExpr -- the one argument -> NatM Register #ifndef powerpc_TARGET_ARCH trivialUFCode :: MachRep -> IF_ARCH_alpha((Reg -> Reg -> Instr) ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_x86_64 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,)))) -> CmmExpr -- the one argument -> NatM Register #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH trivialCode instr x (StInt y) | fits8Bits y = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any IntRep code__2) trivialCode instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat IntRep `thenNat` \ tmp1 -> getNewRegNat 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 return (Any IntRep code__2) ------------ trivialUCode instr x = getRegister x `thenNat` \ register -> getNewRegNat IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in return (Any IntRep code__2) ------------ trivialFCode _ instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat F64 `thenNat` \ tmp1 -> getNewRegNat F64 `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 return (Any F64 code__2) trivialUFCode _ instr x = getRegister x `thenNat` \ register -> getNewRegNat F64 `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in return (Any F64 code__2) #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH {- 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 getNewRegNat are distinct from each other and from all other regs, and stay live over arbitrary computations. -------------------- SDM's version of The Rules: * If getRegister returns Any, that means it can generate correct code which places the result in any register, period. Even if that register happens to be read during the computation. Corollary #1: this means that if you are generating code for an operation with two arbitrary operands, you cannot assign the result of the first operand into the destination register before computing the second operand. The second operand might require the old value of the destination register. Corollary #2: A function might be able to generate more efficient code if it knows the destination register is a new temporary (and therefore not read by any of the sub-computations). * If getRegister returns Any, then the code it generates may modify only: (a) fresh temporaries (b) the destination register (c) known registers (eg. %ecx is used by shifts) In particular, it may *not* modify global registers, unless the global register happens to be the destination register. -} trivialCode rep instr (Just revinstr) (CmmLit lit_a) b | not (is64BitLit lit_a) = do b_code <- getAnyReg b let code dst = b_code dst `snocOL` revinstr (OpImm (litToImm lit_a)) (OpReg dst) -- in return (Any rep code) trivialCode rep instr maybe_revinstr a b = do (b_op, b_code) <- getNonClobberedOperand b a_code <- getAnyReg a tmp <- getNewRegNat rep let -- We want the value of b to stay alive across the computation of a. -- But, we want to calculate a straight into the destination register, -- because the instruction only has two operands (dst := dst `op` src). -- The troublesome case is when the result of b is in the same register -- as the destination reg. In this case, we have to save b in a -- new temporary across the computation of a. code dst | dst `clashesWith` b_op = b_code `appOL` unitOL (MOV rep b_op (OpReg tmp)) `appOL` a_code dst `snocOL` instr (OpReg tmp) (OpReg dst) | otherwise = b_code `appOL` a_code dst `snocOL` instr b_op (OpReg dst) -- in return (Any rep code) where reg `clashesWith` OpReg reg2 = reg == reg2 reg `clashesWith` OpAddr amode = any (==reg) (addrModeRegs amode) reg `clashesWith` _ = False ----------- trivialUCode rep instr x = do x_code <- getAnyReg x let code dst = x_code dst `snocOL` instr (OpReg dst) -- in return (Any rep code) ----------- #if i386_TARGET_ARCH trivialFCode pk instr x y = do (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too (y_reg, y_code) <- getSomeReg y let code dst = x_code `appOL` y_code `snocOL` instr pk x_reg y_reg dst -- in return (Any pk code) #endif #if x86_64_TARGET_ARCH -- We use the 2-operand SSE2 floating pt instructions. ToDo: improve on -- this by using some of the special cases in trivialCode above. trivialFCode pk instr x y = do (y_reg, y_code) <- getNonClobberedReg y -- these work for float regs too x_code <- getAnyReg x let code dst = y_code `appOL` x_code dst `snocOL` instr pk (IF_ARCH_x86_64(OpReg,) y_reg) (IF_ARCH_x86_64(OpReg,) dst) -- in return (Any pk code) #endif ------------- trivialUFCode rep instr x = do (x_reg, x_code) <- getSomeReg x let code dst = x_code `snocOL` instr x_reg dst -- in return (Any rep code) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH trivialCode instr x (StInt y) | fits13Bits y = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any IntRep code__2) trivialCode instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat IntRep `thenNat` \ tmp1 -> getNewRegNat 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 return (Any IntRep code__2) ------------ trivialFCode pk instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNat (registerRep register1) `thenNat` \ tmp1 -> getNewRegNat (registerRep register2) `thenNat` \ tmp2 -> getNewRegNat F64 `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 == F32 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 return (Any (if pk1 == pk2 then pk1 else F64) code__2) ------------ trivialUCode instr x = getRegister x `thenNat` \ register -> getNewRegNat IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `snocOL` instr (RIReg src) dst in return (Any IntRep code__2) ------------- trivialUFCode pk instr x = getRegister x `thenNat` \ register -> getNewRegNat pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `snocOL` instr src dst in return (Any pk code__2) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH {- Wolfgang's PowerPC version of The Rules: A slightly modified version of The Rules to take advantage of the fact that PowerPC instructions work on all registers and don't implicitly clobber any fixed registers. * The only expression for which getRegister returns Fixed is (CmmReg reg). * If getRegister returns Any, then the code it generates may modify only: (a) fresh temporaries (b) the destination register It may *not* modify global registers, unless the global register happens to be the destination register. It may not clobber any other registers. In fact, only ccalls clobber any fixed registers. Also, it may not modify the counter register (used by genCCall). Corollary: If a getRegister for a subexpression returns Fixed, you need not move it to a fresh temporary before evaluating the next subexpression. The Fixed register won't be modified. Therefore, we don't need a counterpart for the x86's getStableReg on PPC. * SDM's First Rule is valid for PowerPC, too: subexpressions can depend on the value of the destination register. -} trivialCode rep signed instr x (CmmLit (CmmInt y _)) | Just imm <- makeImmediate rep signed y = do (src1, code1) <- getSomeReg x let code dst = code1 `snocOL` instr dst src1 (RIImm imm) return (Any rep code) trivialCode rep signed instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) return (Any rep code) trivialCodeNoImm :: MachRep -> (Reg -> Reg -> Reg -> Instr) -> CmmExpr -> CmmExpr -> NatM Register trivialCodeNoImm rep instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 return (Any rep code) trivialUCode rep instr x = do (src, code) <- getSomeReg x let code' dst = code `snocOL` instr dst src return (Any rep code') -- There is no "remainder" instruction on the PPC, so we have to do -- it the hard way. -- The "div" parameter is the division instruction to use (DIVW or DIVWU) remainderCode :: MachRep -> (Reg -> Reg -> Reg -> Instr) -> CmmExpr -> CmmExpr -> NatM Register remainderCode rep div x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code dst = code1 `appOL` code2 `appOL` toOL [ div dst src1 src2, MULLW dst dst (RIReg src2), SUBF dst dst src1 ] return (Any rep code) #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- 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. coerceInt2FP :: MachRep -> MachRep -> CmmExpr -> NatM Register coerceFP2Int :: MachRep -> MachRep -> CmmExpr -> NatM Register #if sparc_TARGET_ARCH coerceDbl2Flt :: CmmExpr -> NatM Register coerceFlt2Dbl :: CmmExpr -> NatM Register #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH coerceInt2FP _ x = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any F64 code__2) ------------- coerceFP2Int x = getRegister x `thenNat` \ register -> getNewRegNat F64 `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 return (Any IntRep code__2) #endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH coerceInt2FP from to x = do (x_reg, x_code) <- getSomeReg x let opc = case to of F32 -> GITOF; F64 -> GITOD code dst = x_code `snocOL` opc x_reg dst -- ToDo: works for non-I32 reps? -- in return (Any to code) ------------ coerceFP2Int from to x = do (x_reg, x_code) <- getSomeReg x let opc = case from of F32 -> GFTOI; F64 -> GDTOI code dst = x_code `snocOL` opc x_reg dst -- ToDo: works for non-I32 reps? -- in return (Any to code) #endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if x86_64_TARGET_ARCH coerceFP2Int from to x = do (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand let opc = case from of F32 -> CVTSS2SI; F64 -> CVTSD2SI code dst = x_code `snocOL` opc x_op dst -- in return (Any to code) -- works even if the destination rep is CVTSI2SS; F64 -> CVTSI2SD code dst = x_code `snocOL` opc x_op dst -- in return (Any to code) -- works even if the destination rep is CmmExpr -> NatM Register coerceFP2FP to x = do (x_reg, x_code) <- getSomeReg x let opc = case to of F32 -> CVTSD2SS; F64 -> CVTSS2SD code dst = x_code `snocOL` opc x_reg dst -- in return (Any to code) #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH coerceInt2FP pk x = getRegister x `thenNat` \ register -> getNewRegNat 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 return (Any pk code__2) ------------ coerceFP2Int fprep x = ASSERT(fprep == F64 || fprep == F32) getRegister x `thenNat` \ register -> getNewRegNat fprep `thenNat` \ reg -> getNewRegNat F32 `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 return (Any IntRep code__2) ------------ coerceDbl2Flt x = getRegister x `thenNat` \ register -> getNewRegNat F64 `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp in return (Any F32 (\dst -> code `snocOL` FxTOy DF F src dst)) ------------ coerceFlt2Dbl x = getRegister x `thenNat` \ register -> getNewRegNat F32 `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp in return (Any F64 (\dst -> code `snocOL` FxTOy F DF src dst)) #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH coerceInt2FP fromRep toRep x = do (src, code) <- getSomeReg x lbl <- getNewLabelNat itmp <- getNewRegNat I32 ftmp <- getNewRegNat F64 dynRef <- cmmMakeDynamicReference addImportNat False lbl Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmInt 0x43300000 I32), CmmStaticLit (CmmInt 0x80000000 I32)], XORIS itmp src (ImmInt 0x8000), ST I32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), ST I32 itmp (spRel 2), LD F64 ftmp (spRel 2) ] `appOL` addr_code `appOL` toOL [ LD F64 dst addr, FSUB F64 dst ftmp dst ] `appOL` maybe_frsp dst maybe_exts = case fromRep of I8 -> unitOL $ EXTS I8 src src I16 -> unitOL $ EXTS I16 src src I32 -> nilOL maybe_frsp dst = case toRep of F32 -> unitOL $ FRSP dst dst F64 -> nilOL return (Any toRep code') coerceFP2Int fromRep toRep x = do -- the reps don't really matter: F*->F64 and I32->I* are no-ops (src, code) <- getSomeReg x tmp <- getNewRegNat F64 let code' dst = code `appOL` toOL [ -- convert to int in FP reg FCTIWZ tmp src, -- store value (64bit) from FP to stack ST F64 tmp (spRel 2), -- read low word of value (high word is undefined) LD I32 dst (spRel 3)] return (Any toRep code') #endif /* powerpc_TARGET_ARCH */ -- ----------------------------------------------------------------------------- -- eXTRA_STK_ARGS_HERE -- We (allegedly) put the first six C-call arguments in registers; -- where do we start putting the rest of them? -- Moved from MachInstrs (SDM): #if alpha_TARGET_ARCH || sparc_TARGET_ARCH eXTRA_STK_ARGS_HERE :: Int eXTRA_STK_ARGS_HERE = IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???)) #endif