X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=1c00641da7820e547f20146749bf75b1a4f146c5;hb=5248496621bd23d3d42f8e0929278e110797d1c1;hp=a31c91dc3c8165088ba50f1424d8a6af7b232a08;hpb=0cc54eac4ab05b44ddab78d1531ccb9edc5d7e6c;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index a31c91d..1c00641 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -49,6 +49,8 @@ import Stix ( pprStixStmt ) -- DEBUGGING ONLY import IOExts ( trace ) +import Outputable ( assertPanic ) +import FastString infixr 3 `bind` \end{code} @@ -62,6 +64,11 @@ order. type InstrBlock = OrdList Instr x `bind` f = f x + +isLeft (Left _) = True +isLeft (Right _) = False + +unLeft (Left x) = x \end{code} Code extractor for an entire stix tree---stix statement level. @@ -129,7 +136,7 @@ stmtToInstrs stmt = case stmt of -- Top-level lifted-out string. The segment will already have been set -- (see Stix.liftStrings). StDataString str - -> returnNat (unitOL (ASCII True (_UNPK_ str))) + -> returnNat (unitOL (ASCII True (unpackFS str))) #ifdef DEBUG other -> pprPanic "stmtToInstrs" (pprStixStmt other) @@ -155,7 +162,8 @@ derefDLL tree StIndex pk base offset -> StIndex pk (qq base) (qq offset) StMachOp mop args -> StMachOp mop (map qq args) StInd pk addr -> StInd pk (qq addr) - StCall who cc pk args -> StCall who cc pk (map qq args) + StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args) + StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args) StInt _ -> t StFloat _ -> t StDouble _ -> t @@ -536,7 +544,7 @@ getRegister (StString s) code dst = toOL [ SEGMENT RoDataSegment, LABEL lbl, - ASCII True (_UNPK_ s), + ASCII True (unpackFS s), SEGMENT TextSegment, #if alpha_TARGET_ARCH LDA dst (AddrImm imm_lbl) @@ -593,30 +601,30 @@ getRegister (StPrim primop [x]) -- unary PrimOps other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of - FloatExpOp -> SLIT("exp") - FloatLogOp -> SLIT("log") - FloatSqrtOp -> SLIT("sqrt") - FloatSinOp -> SLIT("sin") - FloatCosOp -> SLIT("cos") - FloatTanOp -> SLIT("tan") - FloatAsinOp -> SLIT("asin") - FloatAcosOp -> SLIT("acos") - FloatAtanOp -> SLIT("atan") - FloatSinhOp -> SLIT("sinh") - FloatCoshOp -> SLIT("cosh") - FloatTanhOp -> SLIT("tanh") - DoubleExpOp -> SLIT("exp") - DoubleLogOp -> SLIT("log") - DoubleSqrtOp -> SLIT("sqrt") - DoubleSinOp -> SLIT("sin") - DoubleCosOp -> SLIT("cos") - DoubleTanOp -> SLIT("tan") - DoubleAsinOp -> SLIT("asin") - DoubleAcosOp -> SLIT("acos") - DoubleAtanOp -> SLIT("atan") - DoubleSinhOp -> SLIT("sinh") - DoubleCoshOp -> SLIT("cosh") - DoubleTanhOp -> SLIT("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 +708,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 SLIT("pow") CCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -877,8 +885,8 @@ getRegister (StMachOp mop [x]) -- unary MachOps other_op -> getRegister ( (if is_float_op then demote else id) - (StCall fn CCallConv DoubleRep - [(if is_float_op then promote else id) x]) + (StCall (Left fn) CCallConv DoubleRep + [(if is_float_op then promote else id) x]) ) where integerExtend signed nBits x @@ -895,27 +903,27 @@ getRegister (StMachOp mop [x]) -- unary MachOps demote x = StMachOp MO_Dbl_to_Flt [x] (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(x86) - binary StMachOp (2)" (pprMachOp mop) @@ -990,11 +998,11 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps MO_Nat_Sar -> shift_code (SAR L) x y {-False-} MO_Flt_Pwr -> getRegister (demote - (StCall SLIT("pow") CCallConv DoubleRep - [promote x, promote y]) + (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [promote x, promote y]) ) - MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep - [x, y]) + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where promote x = StMachOp MO_Flt_to_Dbl [x] @@ -1082,7 +1090,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps code_val `snocOL` MOV L (OpReg src_val) r_dst `appOL` toOL [ - COMMENT (_PK_ "begin shift sequence"), + COMMENT (mkFastString "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -1111,7 +1119,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps instr (ImmInt 1) r_dst, LABEL lbl_after, - COMMENT (_PK_ "end shift sequence") + COMMENT (mkFastString "end shift sequence") ] in returnNat (Any IntRep code__2) @@ -1234,6 +1242,7 @@ getRegister (StMachOp mop [x]) -- unary PrimOps = case mop of MO_NatS_Neg -> trivialUCode (SUB False False g0) x MO_Nat_Not -> trivialUCode (XNOR False g0) x + MO_32U_to_8U -> trivialCode (AND False) x (StInt 255) MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x @@ -1258,6 +1267,7 @@ getRegister (StMachOp mop [x]) -- unary PrimOps 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 @@ -1268,7 +1278,7 @@ getRegister (StMachOp mop [x]) -- unary PrimOps then StMachOp MO_Flt_to_Dbl [x] else x in - getRegister (StCall fn CCallConv DoubleRep [fixed_x]) + getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x]) where integerExtend signed nBits x = getRegister ( @@ -1281,37 +1291,37 @@ getRegister (StMachOp mop [x]) -- unary PrimOps (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) - MO_Flt_Sqrt -> (True, SLIT("sqrt")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) + MO_Flt_Sqrt -> (True, FSLIT("sqrt")) - MO_Flt_Sin -> (True, SLIT("sin")) - MO_Flt_Cos -> (True, SLIT("cos")) - MO_Flt_Tan -> (True, SLIT("tan")) + MO_Flt_Sin -> (True, FSLIT("sin")) + MO_Flt_Cos -> (True, FSLIT("cos")) + MO_Flt_Tan -> (True, FSLIT("tan")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) - MO_Dbl_Sqrt -> (False, SLIT("sqrt")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) + MO_Dbl_Sqrt -> (False, FSLIT("sqrt")) - MO_Dbl_Sin -> (False, SLIT("sin")) - MO_Dbl_Cos -> (False, SLIT("cos")) - MO_Dbl_Tan -> (False, SLIT("tan")) + MO_Dbl_Sin -> (False, FSLIT("sin")) + MO_Dbl_Cos -> (False, FSLIT("cos")) + MO_Dbl_Tan -> (False, FSLIT("tan")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" (pprMachOp mop) @@ -1361,10 +1371,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_NatS_MulMayOflo -> imulMayOflo x y -- ToDo: teach about V8+ SPARC div instructions - MO_NatS_Quot -> idiv SLIT(".div") x y - MO_NatS_Rem -> idiv SLIT(".rem") x y - MO_NatU_Quot -> idiv SLIT(".udiv") x y - MO_NatU_Rem -> idiv SLIT(".urem") x y + MO_NatS_Quot -> idiv FSLIT(".div") x y + MO_NatS_Rem -> idiv FSLIT(".rem") x y + MO_NatU_Quot -> idiv FSLIT(".udiv") x y + MO_NatU_Rem -> idiv FSLIT(".urem") x y MO_Flt_Add -> trivialFCode FloatRep FADD x y MO_Flt_Sub -> trivialFCode FloatRep FSUB x y @@ -1384,15 +1394,15 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_Nat_Shr -> trivialCode SRL x y MO_Nat_Sar -> trivialCode SRA x y - MO_Flt_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep - [promote x, promote y]) + MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [promote x, promote y]) where promote x = StMachOp MO_Flt_to_Dbl [x] - MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep - [x, y]) + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop) where - idiv fn x y = getRegister (StCall fn CCallConv IntRep [x, y]) + idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y]) -------------------- imulMayOflo :: StixExpr -> StixExpr -> NatM Register @@ -2368,7 +2378,7 @@ genJump dsts tree genJump dsts (StCLbl lbl) | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts" | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) - | otherwise = returnNat (toOL [CALL target 0 True, NOP]) + | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP]) where target = ImmCLbl lbl @@ -2616,7 +2626,7 @@ register allocator. \begin{code} genCCall - :: FAST_STRING -- function to call + :: (Either FastString StixExpr) -- function to call -> CCallConv -> PrimRep -- type of the result -> [StixExpr] -- arguments (of mixed type) @@ -2696,46 +2706,43 @@ genCCall fn cconv kind args #if i386_TARGET_ARCH -genCCall fn cconv ret_rep [StInt i] - | fn == SLIT ("PerformGC_wrapper") - = let call = toOL [ - MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - CALL (ImmLit (ptext (if underscorePrefix - then (SLIT ("_PerformGC_wrapper")) - else (SLIT ("PerformGC_wrapper"))))) - ] - in - returnNat call - - genCCall fn cconv ret_rep args = mapNat push_arg - (reverse args) `thenNat` \ sizes_n_codes -> - getDeltaNat `thenNat` \ delta -> - let (sizes, codes) = unzip sizes_n_codes - tot_arg_size = sum sizes - code2 = concatOL codes - call = toOL ( - [CALL (fn__2 tot_arg_size)] - ++ + (reverse args) `thenNat` \ sizes_n_codes -> + getDeltaNat `thenNat` \ delta -> + let (sizes, push_codes) = unzip sizes_n_codes + tot_arg_size = sum sizes + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size)))) + Right dyn + -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) -> + ASSERT(case dyn_rep of { L -> True; _ -> False}) + returnNat (dyn_c `snocOL` CALL (Right dyn_r)) + ) + `thenNat` \ callinsns -> + let push_code = concatOL push_codes + call = callinsns `appOL` + toOL ( -- Deallocate parameters after call for ccall; -- but not for stdcall (callee does it) (if cconv == StdCallConv then [] else [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) ++ - [DELTA (delta + tot_arg_size)] ) in setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> - returnNat (code2 `appOL` call) + returnNat (push_code `appOL` call) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn_u = _UNPK_ fn + fn_u = unpackFS (unLeft fn) fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) @@ -2842,11 +2849,23 @@ genCCall fn cconv ret_rep args genCCall fn cconv kind args = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs -> - let (argcodes, vregss) = unzip argcode_and_vregs - argcode = concatOL argcodes - vregs = concat vregss + let + (argcodes, vregss) = unzip argcode_and_vregs n_argRegs = length allArgRegs n_argRegs_used = min (length vregs) n_argRegs + vregs = concat vregss + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False)) + Right dyn + -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) -> + returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + ) + `thenNat` \ callinsns -> + let + argcode = concatOL argcodes (move_sp_down, move_sp_up) = let nn = length vregs - n_argRegs + 1 -- (for the road) @@ -2855,13 +2874,11 @@ genCCall fn cconv kind args else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) transfer_code = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE) - call - = unitOL (CALL fn__2 n_argRegs_used False) in returnNat (argcode `appOL` move_sp_down `appOL` transfer_code `appOL` - call `appOL` + callinsns `appOL` unitOL NOP `appOL` move_sp_up) where @@ -2869,9 +2886,10 @@ genCCall fn cconv kind args -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (ptext fn) - _ -> ImmLab False (ptext fn) + fn_static = unLeft fn + fn__2 = case (headFS fn_static) of + '.' -> ImmLit (ftext fn_static) + _ -> ImmLab False (ftext fn_static) -- move args from the integer vregs into which they have been -- marshalled, into %o0 .. %o5, and the rest onto the stack.