X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=81e3bec0b60eebca4aa8921dab07c2f5db7f835b;hp=17ee624557357ada2fb622cb6c6f4db617ce6ab1;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hpb=970cd21327e30e5b9af594884f1ac79334ed0582 diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index 17ee624..81e3bec 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) @@ -29,6 +36,7 @@ import PprCmm ( pprExpr ) import Cmm import MachOp import CLabel +import ClosureInfo ( C_SRT(..) ) -- The rest: import StaticFlags ( opt_PIC ) @@ -37,18 +45,16 @@ import OrdList import Pretty import Outputable import FastString -import FastTypes ( isFastTrue ) +import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) -#ifdef DEBUG -import Outputable ( assertPanic ) import Debug.Trace ( trace ) -#endif import Control.Monad ( mapAndUnzipM ) import Data.Maybe ( fromJust ) import Data.Bits import Data.Word +import Data.Int -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -60,11 +66,11 @@ import Data.Word type InstrBlock = OrdList Instr -cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop] -cmmTopCodeGen (CmmProc info lab params blocks) = do +cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop] +cmmTopCodeGen (CmmProc info lab params (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (concat nat_blocks) + let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) tops = proc : concat statics case picBaseMb of Just picBase -> initializePicBase picBase tops @@ -118,13 +124,15 @@ stmtToInstrs stmt = case stmt of | otherwise -> assignMem_IntCode kind addr src where kind = cmmExprRep src - CmmCall target result_regs args vols - -> genCCall target result_regs args vols + CmmCall target result_regs args _ _ + -> genCCall target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg params -> genJump arg + CmmReturn params -> + panic "stmtToInstrs: return statement should have been cps'd away" -- ----------------------------------------------------------------------------- -- General things for putting together code sequences @@ -187,7 +195,7 @@ assignMem_I64Code addrTree valueTree = do return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst I32 @@ -229,7 +237,7 @@ iselExpr64 (CmmLoad addrTree I64) = do rlo ) -iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) +iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _))) = return (ChildCode64 nilOL (mkVReg vu I32)) -- we handle addition, but rather badly @@ -264,6 +272,17 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do -- in return (ChildCode64 code rlo) +iselExpr64 (CmmMachOp (MO_U_Conv _ I64) [expr]) = do + fn <- getAnyReg expr + r_dst_lo <- getNewRegNat I32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + code = fn r_dst_lo + return ( + ChildCode64 (code `snocOL` + MOV I32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) + r_dst_lo + ) + iselExpr64 expr = pprPanic "iselExpr64(i386)" (ppr expr) @@ -284,7 +303,7 @@ assignMem_I64Code addrTree valueTree = do mov_lo = ST I32 rlo (AddrRegImm src (ImmInt 4)) return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo) -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst pk @@ -314,7 +333,7 @@ iselExpr64 (CmmLoad addrTree I64) = do rlo ) -iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) = do +iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64 _))) = do r_dst_lo <- getNewRegNat I32 let r_dst_hi = getHiVRegFromLo r_dst_lo r_src_lo = mkVReg uq I32 @@ -357,7 +376,7 @@ assignMem_I64Code addrTree valueTree = do -- in return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst I32 @@ -387,7 +406,7 @@ iselExpr64 (CmmLoad addrTree I64) = do return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo -iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) +iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _))) = return (ChildCode64 nilOL (mkVReg vu I32)) iselExpr64 (CmmLit (CmmInt i _)) = do @@ -421,6 +440,13 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do -- in return (ChildCode64 code rlo) +iselExpr64 (CmmMachOp (MO_U_Conv I32 I64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + (rlo, rhi) <- getNewRegPairNat I32 + let mov_hi = LI rhi (ImmInt 0) + mov_lo = MR rlo expr_reg + return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo iselExpr64 expr = pprPanic "iselExpr64(powerpc)" (ppr expr) @@ -464,7 +490,7 @@ getSomeReg expr = do getRegisterReg :: CmmReg -> Reg -getRegisterReg (CmmLocal (LocalReg u pk)) +getRegisterReg (CmmLocal (LocalReg u pk _)) = mkVReg u pk getRegisterReg (CmmGlobal mid) @@ -565,30 +591,30 @@ getRegister (StPrim primop [x]) -- unary PrimOps 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") + 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" @@ -672,8 +698,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps 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]) + 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 @@ -765,7 +791,8 @@ getRegister leaf getRegister (CmmLit (CmmFloat f F32)) = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData @@ -788,7 +815,8 @@ getRegister (CmmLit (CmmFloat d F64)) | otherwise = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData @@ -1016,8 +1044,7 @@ getRegister (CmmMachOp mop [x]) -- unary MachOps getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps - = ASSERT2(cmmExprRep x /= I8, pprExpr e) - case mop of + = 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 @@ -1147,16 +1174,30 @@ getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps -- in return (Any rep code) - {- Case2: shift length is complex (non-immediate) -} + {- Case2: shift length is complex (non-immediate) + * y must go in %ecx. + * we cannot do y first *and* put its result in %ecx, because + %ecx might be clobbered by x. + * if we do y second, then x cannot be + in a clobbered reg. Also, we cannot clobber x's reg + with the instruction itself. + * so we can either: + - do y first, put its result in a fresh tmp, then copy it to %ecx later + - do y second and put its result into %ecx. x gets placed in a fresh + tmp. This is likely to be better, becuase the reg alloc can + eliminate this reg->reg move here (it won't eliminate the other one, + because the move is into the fixed %ecx). + -} shift_code rep instr x y{-amount-} = do - (x_reg, x_code) <- getNonClobberedReg x + x_code <- getAnyReg x + tmp <- getNewRegNat rep y_code <- getAnyReg y let - code = x_code `appOL` + code = x_code tmp `appOL` y_code ecx `snocOL` - instr (OpReg ecx) (OpReg x_reg) + instr (OpReg ecx) (OpReg tmp) -- in - return (Fixed rep x_reg code) + return (Fixed rep tmp code) -------------------- add_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register @@ -1459,10 +1500,10 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps MO_S_MulMayOflo rep -> imulMayOflo rep x y {- -- ToDo: teach about V8+ SPARC div instructions - MO_S_Quot I32 -> idiv FSLIT(".div") x y - MO_S_Rem I32 -> idiv FSLIT(".rem") x y - MO_U_Quot I32 -> idiv FSLIT(".udiv") x y - MO_U_Rem I32 -> idiv FSLIT(".urem") x y + MO_S_Quot I32 -> idiv (fsLit ".div") x y + MO_S_Rem I32 -> idiv (fsLit ".rem") x y + MO_U_Quot I32 -> idiv (fsLit ".udiv") x y + MO_U_Rem I32 -> idiv (fsLit ".urem") x y -} MO_Add F32 -> trivialFCode F32 FADD x y MO_Sub F32 -> trivialFCode F32 FSUB x y @@ -1485,10 +1526,10 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps MO_S_Shr rep -> trivialCode rep SRA x y {- - MO_F32_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64 + 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 + MO_F64_Pwr -> getRegister (StCall (Left (fsLit "pow")) CCallConv F64 [x, y]) -} other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) @@ -1694,7 +1735,8 @@ getRegister (CmmLit (CmmInt i rep)) getRegister (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let code dst = LDATA ReadOnlyData [CmmDataLabel lbl, @@ -1706,8 +1748,8 @@ getRegister (CmmLit lit) = let rep = cmmLitRep lit imm = litToImm lit code dst = toOL [ - LIS dst (HI imm), - OR dst dst (RIImm (LO imm)) + LIS dst (HA imm), + ADD dst dst (RIImm (LO imm)) ] in return (Any rep code) @@ -1828,15 +1870,18 @@ getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), 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 (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt 0)) - code) + = x86_complex_amode x y shift 0 + +getAmode (CmmMachOp (MO_Add rep) + [x, CmmMachOp (MO_Add _) + [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], + CmmLit (CmmInt offset _)]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + && not (is64BitInteger offset) + = x86_complex_amode x y shift offset + +getAmode (CmmMachOp (MO_Add rep) [x,y]) + = x86_complex_amode x y 0 0 getAmode (CmmLit lit) | not (is64BitLit lit) = return (Amode (ImmAddr (litToImm lit) 0) nilOL) @@ -1845,6 +1890,19 @@ getAmode expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) + +x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode +x86_complex_amode base index shift offset + = do (x_reg, x_code) <- getNonClobberedReg base + -- 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 index + let + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8 + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) + code) + #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2037,7 +2095,12 @@ is64BitLit x = False #endif is64BitInteger :: Integer -> Bool -is64BitInteger i = i > 0x7fffffff || i < -0x80000000 +is64BitInteger i = i64 > 0x7fffffff || i64 < -0x80000000 + where i64 = fromIntegral i :: Int64 + -- a CmmInt is intended to be truncated to the appropriate + -- number of bits, so here we truncate it to Int64. This is + -- important because e.g. -1 as a CmmInt might be either + -- -1 or 18446744073709551615. -- ----------------------------------------------------------------------------- -- The 'CondCode' type: Condition codes passed up the tree. @@ -2162,6 +2225,18 @@ condIntCode cond (CmmLoad x pk) (CmmLit lit) | not (is64BitLit lit) = do -- return (CondCode False cond code) +-- anything vs zero, using a mask +-- TODO: Add some sanity checking!!!! +condIntCode cond (CmmMachOp (MO_And rep) [x,o2]) (CmmLit (CmmInt 0 pk)) + | (CmmLit (CmmInt mask pk2)) <- o2 + = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST pk (OpImm (ImmInteger mask)) (OpReg x_reg) + -- + return (CondCode False cond code) + -- anything vs zero condIntCode cond x (CmmLit (CmmInt 0 pk)) = do (x_reg, x_code) <- getSomeReg x @@ -2359,6 +2434,25 @@ assignIntCode pk dst src #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- integer assignment to memory + +-- specific case of adding/subtracting an integer to a particular address. +-- ToDo: catch other cases where we can use an operation directly on a memory +-- address. +assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, + CmmLit (CmmInt i _)]) + | addr == addr2, pk /= I64 || not (is64BitInteger i), + Just instr <- check op + = do Amode amode code_addr <- getAmode addr + let code = code_addr `snocOL` + instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) + return code + where + check (MO_Add _) = Just ADD + check (MO_Sub _) = Just SUB + check _ = Nothing + -- ToDo: more? + +-- general case assignMem_IntCode pk addr src = do Amode addr code_addr <- getAmode addr (code_src, op_src) <- get_op_RI src @@ -2872,9 +2966,8 @@ genCondJump id bool = do genCCall :: CmmCallTarget -- function to call - -> [(CmmReg,MachHint)] -- where to put the result - -> [(CmmExpr,MachHint)] -- arguments (of mixed type) - -> Maybe [GlobalReg] -- volatile regs to save + -> CmmFormals -- where to put the result + -> CmmActuals -- arguments (of mixed type) -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2953,35 +3046,37 @@ genCCall fn cconv result_regs args #if i386_TARGET_ARCH -genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL +genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [(r,_)] args vols = do +genCCall (CmmPrim op) [CmmKinded r _] args = do + l1 <- getNewLabelNat + l2 <- getNewLabelNat 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_Sin -> actuallyInlineFloatOp F32 (GSIN F32 l1 l2) args + MO_F64_Sin -> actuallyInlineFloatOp F64 (GSIN F64 l1 l2) args - MO_F32_Cos -> actuallyInlineFloatOp F32 (GCOS F32) args - MO_F64_Cos -> actuallyInlineFloatOp F64 (GCOS F64) args + MO_F32_Cos -> actuallyInlineFloatOp F32 (GCOS F32 l1 l2) args + MO_F64_Cos -> actuallyInlineFloatOp F64 (GCOS F64 l1 l2) args - MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args - MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args + MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32 l1 l2) args + MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64 l1 l2) args - other_op -> outOfLineFloatOp op r args vols + other_op -> outOfLineFloatOp op r args where - actuallyInlineFloatOp rep instr [(x,_)] + actuallyInlineFloatOp rep instr [CmmKinded x _] = do res <- trivialUFCode rep instr x any <- anyReg res - return (any (getRegisterReg r)) + return (any (getRegisterReg (CmmLocal r))) -genCCall target dest_regs args vols = do +genCCall target dest_regs args = do let - sizes = map (arg_size . cmmExprRep . fst) (reverse args) + sizes = map (arg_size . cmmExprRep . kindlessCmm) (reverse args) #if !darwin_TARGET_OS tot_arg_size = sum sizes #else @@ -3000,11 +3095,11 @@ genCCall target dest_regs args vols = do (callinsns,cconv) <- case target of -- CmmPrim -> ... - CmmForeignCall (CmmLit (CmmLabel lbl)) conv + CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) []), conv) where fn_imm = ImmCLbl lbl - CmmForeignCall expr conv + CmmCallee 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) @@ -3033,7 +3128,7 @@ genCCall target dest_regs args vols = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmKinded dest _hint] = case rep of I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest), MOV I32 (OpReg edx) (OpReg r_dest_hi)] @@ -3042,8 +3137,8 @@ genCCall target dest_regs args vols = do rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest)) where r_dest_hi = getHiVRegFromLo r_dest - rep = cmmRegRep dest - r_dest = getRegisterReg dest + rep = localRegRep dest + r_dest = getRegisterReg (CmmLocal dest) assign_code many = panic "genCCall.assign_code many" return (push_code `appOL` @@ -3060,10 +3155,10 @@ genCCall target dest_regs args vols = do | otherwise = x + a - (x `mod` a) - push_arg :: (CmmExpr,MachHint){-current argument-} + push_arg :: (CmmKinded CmmExpr){-current argument-} -> NatM InstrBlock -- code - push_arg (arg,_hint) -- we don't need the hints on x86 + push_arg (CmmKinded arg _hint) -- we don't need the hints on x86 | arg_rep == I64 = do ChildCode64 code r_lo <- iselExpr64 arg delta <- getDeltaNat @@ -3107,59 +3202,60 @@ genCCall target dest_regs args vols = do #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)] - -> Maybe [GlobalReg] -> NatM InstrBlock -outOfLineFloatOp mop res args vols +outOfLineFloatOp :: CallishMachOp -> CmmFormalWithoutKind -> CmmActuals + -> NatM InstrBlock +outOfLineFloatOp mop res args = do - targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl - let target = CmmForeignCall targetExpr CCallConv + dflags <- getDynFlagsNat + targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl + let target = CmmCallee targetExpr CCallConv - if cmmRegRep res == F64 + if localRegRep res == F64 then - stmtToInstrs (CmmCall target [(res,FloatHint)] args vols) + stmtToInstrs (CmmCall target [CmmKinded res FloatHint] args CmmUnsafe CmmMayReturn) else do uq <- getUniqueNat let - tmp = CmmLocal (LocalReg uq F64) + tmp = LocalReg uq F64 GCKindNonPtr -- in - code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args vols) - code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp)) + code1 <- stmtToInstrs (CmmCall target [CmmKinded tmp FloatHint] args CmmUnsafe CmmMayReturn) + code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where lbl = mkForeignLabel fn Nothing False fn = case mop of - MO_F32_Sqrt -> FSLIT("sqrtf") - MO_F32_Sin -> FSLIT("sinf") - MO_F32_Cos -> FSLIT("cosf") - MO_F32_Tan -> FSLIT("tanf") - MO_F32_Exp -> FSLIT("expf") - MO_F32_Log -> FSLIT("logf") - - MO_F32_Asin -> FSLIT("asinf") - MO_F32_Acos -> FSLIT("acosf") - MO_F32_Atan -> FSLIT("atanf") - - MO_F32_Sinh -> FSLIT("sinhf") - MO_F32_Cosh -> FSLIT("coshf") - MO_F32_Tanh -> FSLIT("tanhf") - MO_F32_Pwr -> FSLIT("powf") - - 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") + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + MO_F32_Pwr -> fsLit "powf" + + 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" #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ @@ -3167,14 +3263,15 @@ outOfLineFloatOp mop res args vols #if x86_64_TARGET_ARCH -genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL +genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall (CmmPrim op) [(r,_)] args vols = - outOfLineFloatOp op r args vols -genCCall target dest_regs args vols = do +genCCall (CmmPrim op) [CmmKinded r _] args = + outOfLineFloatOp op r args + +genCCall target dest_regs args = do -- load up the register arguments (stack_args, aregs, fregs, load_args_code) @@ -3217,11 +3314,11 @@ genCCall target dest_regs args vols = do (callinsns,cconv) <- case target of -- CmmPrim -> ... - CmmForeignCall (CmmLit (CmmLabel lbl)) conv + CmmCallee (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) arg_regs), conv) where fn_imm = ImmCLbl lbl - CmmForeignCall expr conv + CmmCallee expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) @@ -3251,14 +3348,14 @@ genCCall target dest_regs args vols = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmKinded 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 + rep = localRegRep dest + r_dest = getRegisterReg (CmmLocal dest) assign_code many = panic "genCCall.assign_code many" return (load_args_code `appOL` @@ -3271,16 +3368,16 @@ genCCall target dest_regs args vols = do where arg_size = 8 -- always, at the mo - load_args :: [(CmmExpr,MachHint)] + load_args :: [CmmKinded CmmExpr] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> InstrBlock - -> NatM ([(CmmExpr,MachHint)],[Reg],[Reg],InstrBlock) + -> NatM ([CmmKinded CmmExpr],[Reg],[Reg],InstrBlock) load_args args [] [] code = return (args, [], [], code) -- no more regs to use load_args [] aregs fregs code = return ([], aregs, fregs, code) -- no more args to push - load_args ((arg,hint) : rest) aregs fregs code + load_args ((CmmKinded arg hint) : rest) aregs fregs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg @@ -3298,18 +3395,18 @@ genCCall target dest_regs args vols = do push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code - return ((arg,hint):args', ars, frs, code') + return ((CmmKinded arg hint):args', ars, frs, code') push_args [] code = return code - push_args ((arg,hint):rest) code + push_args ((CmmKinded 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)), + let code' = code `appOL` arg_code `appOL` toOL [ SUB wordRep (OpImm (ImmInt arg_size)) (OpReg rsp) , - DELTA (delta-arg_size)] + DELTA (delta-arg_size), + MOV arg_rep (OpReg arg_reg) (OpAddr (spRel 0))] push_args rest code' | otherwise = do @@ -3360,9 +3457,9 @@ genCCall target dest_regs args vols = do stack only immediately prior to the call proper. Sigh. -} -genCCall target dest_regs argsAndHints vols = do +genCCall target dest_regs argsAndHints = do let - args = map fst argsAndHints + args = map kindlessCmm argsAndHints argcode_and_vregs <- mapM arg_to_int_vregs args let (argcodes, vregss) = unzip argcode_and_vregs @@ -3371,9 +3468,9 @@ genCCall target dest_regs argsAndHints vols = do vregs = concat vregss -- deal with static vs dynamic call targets callinsns <- (case target of - CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> do + CmmCallee (CmmLit (CmmLabel lbl)) conv -> do return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - CmmForeignCall expr conv -> do + CmmCallee expr conv -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) CmmPrim mop -> do @@ -3467,7 +3564,8 @@ genCCall target dest_regs argsAndHints vols = do ) outOfLineFloatOp mop = do - mopExpr <- cmmMakeDynamicReference addImportNat CallReference $ + dflags <- getDynFlagsNat + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing True let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -3475,37 +3573,37 @@ outOfLineFloatOp mop = return (mopLabelOrExpr, reduce) where (reduce, functionName) = case mop of - MO_F32_Exp -> (True, FSLIT("exp")) - MO_F32_Log -> (True, FSLIT("log")) - MO_F32_Sqrt -> (True, FSLIT("sqrt")) + 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_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_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_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_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_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_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")) + MO_F64_Sinh -> (False, fsLit "sinh") + MO_F64_Cosh -> (False, fsLit "cosh") + MO_F64_Tanh -> (False, fsLit "tanh") other -> pprPanic "outOfLineFloatOp(sparc) " (pprCallishMachOp mop) @@ -3553,10 +3651,10 @@ outOfLineFloatOp mop = -} -genCCall (CmmPrim MO_WriteBarrier) _ _ _ +genCCall (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC -genCCall target dest_regs argsAndHints vols +genCCall target dest_regs argsAndHints = ASSERT (not $ any (`elem` [I8,I16]) argReps) -- we rely on argument promotion in the codeGen do @@ -3567,8 +3665,8 @@ genCCall target dest_regs argsAndHints vols (toOL []) [] (labelOrExpr, reduceToF32) <- case target of - CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) - CmmForeignCall expr conv -> return (Right expr, False) + CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) + CmmCallee expr conv -> return (Right expr, False) CmmPrim mop -> outOfLineFloatOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode @@ -3596,7 +3694,7 @@ genCCall target dest_regs argsAndHints vols initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif - args = map fst argsAndHints + args = map kindlessCmm argsAndHints argReps = map cmmExprRep args roundTo a x | x `mod` a == 0 = x @@ -3711,18 +3809,19 @@ genCCall target dest_regs argsAndHints vols moveResult reduceToF32 = case dest_regs of [] -> nilOL - [(dest, _hint)] + [CmmKinded 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 + where rep = cmmRegRep (CmmLocal dest) + r_dest = getRegisterReg (CmmLocal dest) outOfLineFloatOp mop = do - mopExpr <- cmmMakeDynamicReference addImportNat CallReference $ + dflags <- getDynFlagsNat + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing True let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -3730,39 +3829,39 @@ genCCall target dest_regs argsAndHints vols 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_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_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_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_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_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_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_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) + 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) @@ -3782,7 +3881,8 @@ genSwitch expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let jumpTable = map jumpTableEntryRel ids @@ -3796,7 +3896,8 @@ genSwitch expr ids op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) -#if x86_64_TARGET_ARCH && darwin_TARGET_OS +#if x86_64_TARGET_ARCH +#if darwin_TARGET_OS -- on Mac OS X/x86_64, put the jump table in the text section -- to work around a limitation of the linker. -- ld64 is unable to handle the relocations for @@ -3809,6 +3910,23 @@ genSwitch expr ids LDATA Text (CmmDataLabel lbl : jumpTable) ] #else + -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 + -- relocations, hence we only get 32-bit offsets in the jump + -- table. As these offsets are always negative we need to properly + -- sign extend them to 64-bit. This hack should be removed in + -- conjunction with the hack in PprMach.hs/pprDataItem once + -- binutils 2.17 is standard. + code = e_code `appOL` t_code `appOL` toOL [ + LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + MOVSxL I32 + (OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg wORD_SIZE) (ImmInt 0))) + (OpReg reg), + ADD wordRep (OpReg reg) (OpReg tableReg), + JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + ] +#endif +#else code = e_code `appOL` t_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), ADD wordRep op (OpReg tableReg), @@ -3836,7 +3954,8 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat I32 lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl + dflags <- getDynFlagsNat + dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let jumpTable = map jumpTableEntryRel ids @@ -3874,7 +3993,7 @@ genSwitch expr ids ] return code #else -genSwitch expr ids = panic "ToDo: genSwitch" +#error "ToDo: genSwitch" #endif jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordRep) @@ -4522,6 +4641,8 @@ remainderCode rep div x y = do -- ----------------------------------------------------------------------------- -- Coercing to/from integer/floating-point... +-- When going to integer, we truncate (round towards 0). + -- @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. @@ -4607,7 +4728,7 @@ coerceFP2Int from to x = do 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 + opc = case from of F32 -> CVTTSS2SIQ; F64 -> CVTTSD2SIQ code dst = x_code `snocOL` opc x_op dst -- in return (Any to code) -- works even if the destination rep is