-- DEBUGGING ONLY
import IOExts ( trace )
+import Outputable ( assertPanic )
infixr 3 `bind`
\end{code}
type InstrBlock = OrdList Instr
x `bind` f = f x
+
+isLeft (Left _) = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
\end{code}
Code extractor for an entire stix tree---stix statement level.
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
= case mop of
MO_NatS_Neg -> trivialUCode (NEGI L) x
MO_Nat_Not -> trivialUCode (NOT L) x
+ MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
MO_8S_to_NatS -> integerExtend True 24 x
MO_16U_to_NatU -> integerExtend False 16 x
MO_16S_to_NatS -> integerExtend True 16 x
+ MO_8U_to_32U -> integerExtend False 24 x
other_op
-> getRegister (
(if is_float_op then demote else id)
- (StCall 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
= getRegister (
StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
- [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
+ [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
)
conversionNop new_rep expr
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 SLIT("pow")) CCallConv DoubleRep
+ [promote x, promote y])
)
- MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
- [x, y])
+ MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
+ [x, y])
other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
where
promote x = StMachOp MO_Flt_to_Dbl [x]
code2 = registerCode reg2 t2
src1 = registerName reg1 t1
src2 = registerName reg2 t2
- code dst = toOL [
+ code dst = code1 `appOL` code2 `appOL`
+ toOL [
MOV L (OpReg src1) (OpReg res_hi),
MOV L (OpReg src2) (OpReg res_lo),
IMUL64 res_hi res_lo, -- result in res_hi:res_lo
= case mop of
MO_NatS_Neg -> trivialUCode (SUB False False g0) x
MO_Nat_Not -> trivialUCode (XNOR False g0) x
+ MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
MO_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
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 (
StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
- [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
+ [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
)
conversionNop new_rep expr
= getRegister expr `thenNat` \ e_code ->
MO_Nat_Add -> trivialCode (ADD False False) x y
MO_Nat_Sub -> trivialCode (SUB False False) x y
- -- ToDo: teach about V8+ SPARC mul/div instructions
- MO_NatS_Quot -> imul_div SLIT(".div") x y
- MO_NatS_Rem -> imul_div SLIT(".rem") x y
- MO_NatU_Quot -> imul_div SLIT(".udiv") x y
- MO_NatU_Rem -> imul_div SLIT(".urem") x y
+ MO_NatS_Mul -> trivialCode (SMUL False) x y
+ MO_NatU_Mul -> trivialCode (UMUL False) x y
+ MO_NatS_MulMayOflo -> imulMayOflo x y
- MO_NatS_Mul -> imul_div SLIT(".umul") x y
- MO_NatU_Mul -> imul_div SLIT(".umul") 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_Flt_Add -> trivialFCode FloatRep FADD x y
MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
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 SLIT("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 SLIT("pow")) CCallConv DoubleRep
+ [x, y])
other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
where
- imul_div 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
+ imulMayOflo a1 a2
+ = getNewRegNCG IntRep `thenNat` \ t1 ->
+ getNewRegNCG IntRep `thenNat` \ t2 ->
+ getNewRegNCG IntRep `thenNat` \ res_lo ->
+ getNewRegNCG IntRep `thenNat` \ res_hi ->
+ getRegister a1 `thenNat` \ reg1 ->
+ getRegister a2 `thenNat` \ reg2 ->
+ let code1 = registerCode reg1 t1
+ code2 = registerCode reg2 t2
+ src1 = registerName reg1 t1
+ src2 = registerName reg2 t2
+ code dst = code1 `appOL` code2 `appOL`
+ toOL [
+ SMUL False src1 (RIReg src2) res_lo,
+ RDY res_hi,
+ SRA res_lo (RIImm (ImmInt 31)) res_lo,
+ SUB False False res_lo (RIReg res_hi) dst
+ ]
+ in
+ returnNat (Any IntRep code)
getRegister (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
\begin{code}
data CondCode = CondCode Bool Cond InstrBlock
-condName (CondCode _ cond _) = cond
+condName (CondCode _ cond _) = cond
condFloat (CondCode is_float _ _) = is_float
-condCode (CondCode _ _ code) = code
+condCode (CondCode _ _ code) = code
\end{code}
Set up a condition code for a conditional branch.
-----------
condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
+ = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
+ getRegister x `thenNat` \ register1 ->
getRegister y `thenNat` \ register2 ->
getNewRegNCG (registerRep register1)
`thenNat` \ tmp1 ->
`thenNat` \ tmp2 ->
getNewRegNCG DoubleRep `thenNat` \ tmp ->
let
- pk1 = registerRep register1
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
code__2 | isAny register1
= code1 `appOL` -- result in tmp1
code2 `snocOL`
- GCMP (primRepToSize pk1) tmp1 src2
+ GCMP cond tmp1 src2
| otherwise
= code1 `snocOL`
GMOV src1 tmp1 `appOL`
code2 `snocOL`
- GCMP (primRepToSize pk1) tmp1 src2
-
- {- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
- -}
- fix_FP_cond :: Cond -> Cond
-
- fix_FP_cond GE = GEU
- fix_FP_cond GTT = GU
- fix_FP_cond LTT = LU
- fix_FP_cond LE = LEU
- fix_FP_cond any = any
+ GCMP cond tmp1 src2
in
- returnNat (CondCode True (fix_FP_cond cond) code__2)
+ -- The GCMP insn does the test and sets the zero flag if comparable
+ -- and true. Hence we always supply EQQ as the condition to test.
+ returnNat (CondCode True EQQ code__2)
#endif {- i386_TARGET_ARCH -}
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
\begin{code}
genCCall
- :: FAST_STRING -- function to call
+ :: (Either FAST_STRING StixExpr) -- function to call
-> CCallConv
-> PrimRep -- type of the result
-> [StixExpr] -- arguments (of mixed type)
#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 = _UNPK_ (unLeft fn)
fn__2 tot_arg_size
| head fn_u == '.'
= ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
| cconv == StdCallConv = '@':show tot_arg_size
| otherwise = ""
+ -- floats are always promoted to doubles when passed to a ccall
+ promote_size F = DF
+ promote_size sz = sz
+
arg_size DF = 8
arg_size F = 4
arg_size _ = 4
| otherwise
= get_op arg `thenNat` \ (code, reg, sz) ->
getDeltaNat `thenNat` \ delta ->
- arg_size sz `bind` \ size ->
+ let
+ real_sz = promote_size sz
+ size = arg_size real_sz
+ in
setDeltaNat (delta-size) `thenNat` \ _ ->
- if (case sz of DF -> True; F -> True; _ -> False)
+ if (case real_sz of DF -> True; _ -> False)
then returnNat (size,
code `appOL`
toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
DELTA (delta-size),
- GST sz reg (AddrBaseIndex (Just esp)
+ GST DF reg (AddrBaseIndex (Just esp)
Nothing
(ImmInt 0))]
)
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)
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
-- 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 (_HEAD_ fn_static) of
+ '.' -> ImmLit (ptext fn_static)
+ _ -> ImmLab False (ptext fn_static)
-- move args from the integer vregs into which they have been
-- marshalled, into %o0 .. %o5, and the rest onto the stack.
projects / ghc-hetmet.git / blobdiff