X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=81e3bec0b60eebca4aa8921dab07c2f5db7f835b;hp=d8dfd670c7e0d81181c58ab25358c369b9efe8ce;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hpb=1529e92a2b4942dd0fdd95e56adaf97c316d2e39 diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index d8dfd67..81e3bec 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -48,10 +48,6 @@ import FastString import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) -#ifdef DEBUG -import Outputable ( assertPanic ) -import Debug.Trace ( trace ) -#endif import Debug.Trace ( trace ) import Control.Monad ( mapAndUnzipM ) @@ -135,6 +131,8 @@ stmtToInstrs stmt = case stmt of 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 @@ -593,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" @@ -700,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 @@ -1502,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 @@ -1528,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) @@ -3053,30 +3051,32 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- we keep it this long in order to prevent earlier optimisations. -- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [CmmHinted r _] args = 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 where - actuallyInlineFloatOp rep instr [CmmHinted x _] + actuallyInlineFloatOp rep instr [CmmKinded x _] = do res <- trivialUFCode rep instr x any <- anyReg res return (any (getRegisterReg (CmmLocal r))) genCCall target dest_regs args = do let - sizes = map (arg_size . cmmExprRep . hintlessCmm) (reverse args) + sizes = map (arg_size . cmmExprRep . kindlessCmm) (reverse args) #if !darwin_TARGET_OS tot_arg_size = sum sizes #else @@ -3128,7 +3128,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [CmmHinted 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)] @@ -3155,10 +3155,10 @@ genCCall target dest_regs args = do | otherwise = x + a - (x `mod` a) - push_arg :: (CmmHinted CmmExpr){-current argument-} + push_arg :: (CmmKinded CmmExpr){-current argument-} -> NatM InstrBlock -- code - push_arg (CmmHinted 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 @@ -3212,50 +3212,50 @@ outOfLineFloatOp mop res args if localRegRep res == F64 then - stmtToInstrs (CmmCall target [CmmHinted res FloatHint] args CmmUnsafe CmmMayReturn) + stmtToInstrs (CmmCall target [CmmKinded res FloatHint] args CmmUnsafe CmmMayReturn) else do uq <- getUniqueNat let tmp = LocalReg uq F64 GCKindNonPtr -- in - code1 <- stmtToInstrs (CmmCall target [CmmHinted tmp FloatHint] args CmmUnsafe CmmMayReturn) + 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 */ @@ -3268,7 +3268,7 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- we keep it this long in order to prevent earlier optimisations. -genCCall (CmmPrim op) [CmmHinted r _] args = +genCCall (CmmPrim op) [CmmKinded r _] args = outOfLineFloatOp op r args genCCall target dest_regs args = do @@ -3348,7 +3348,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [CmmHinted 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)) @@ -3368,16 +3368,16 @@ genCCall target dest_regs args = do where arg_size = 8 -- always, at the mo - load_args :: [CmmHinted CmmExpr] + load_args :: [CmmKinded CmmExpr] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[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 ((CmmHinted arg hint) : rest) aregs fregs code + load_args ((CmmKinded arg hint) : rest) aregs fregs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg @@ -3395,10 +3395,10 @@ genCCall target dest_regs args = do push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') + return ((CmmKinded arg hint):args', ars, frs, code') push_args [] code = return code - push_args ((CmmHinted arg hint):rest) code + push_args ((CmmKinded arg hint):rest) code | isFloatingRep arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat @@ -3459,7 +3459,7 @@ genCCall target dest_regs args = do genCCall target dest_regs argsAndHints = do let - args = map hintlessCmm argsAndHints + args = map kindlessCmm argsAndHints argcode_and_vregs <- mapM arg_to_int_vregs args let (argcodes, vregss) = unzip argcode_and_vregs @@ -3573,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) @@ -3694,7 +3694,7 @@ genCCall target dest_regs argsAndHints initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif - args = map hintlessCmm argsAndHints + args = map kindlessCmm argsAndHints argReps = map cmmExprRep args roundTo a x | x `mod` a == 0 = x @@ -3809,7 +3809,7 @@ genCCall target dest_regs argsAndHints moveResult reduceToF32 = case dest_regs of [] -> nilOL - [CmmHinted 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, @@ -3829,39 +3829,39 @@ genCCall target dest_regs argsAndHints 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)