#endif
import Maybes ( maybeToBool )
import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
- getPrimRepArrayElemSize )
+ getPrimRepSizeInBytes )
import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
-- DEBUGGING ONLY
import IOExts ( trace )
import Outputable ( assertPanic )
+import FastString
infixr 3 `bind`
\end{code}
-- the linker can handle simple arithmetic...
getData (StIndex rep (StCLbl lbl) (StInt off)) =
returnNat (nilOL,
- ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
+ ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
-- 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)
mangleIndexTree (StIndex pk base (StInt i))
= StMachOp MO_Nat_Add [base, off]
where
- off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
+ off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
mangleIndexTree (StIndex pk base off)
= StMachOp MO_Nat_Add [
]
where
shift :: PrimRep -> Int
- shift rep = case getPrimRepArrayElemSize rep of
+ shift rep = case getPrimRepSizeInBytes rep of
1 -> 0
2 -> 1
4 -> 2
maybeImm (StCLbl l)
= Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off))
- = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
+ = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
maybeImm (StInt i)
| i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
= Just (ImmInt (fromInteger i))
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)
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"
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
-- Conversions which are a nop on x86
MO_NatS_to_32U -> conversionNop WordRep x
MO_32U_to_NatS -> conversionNop IntRep x
+ MO_32U_to_NatU -> conversionNop WordRep x
MO_NatU_to_NatS -> conversionNop IntRep x
MO_NatS_to_NatU -> conversionNop WordRep x
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)
MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
MO_Flt_Pwr -> getRegister (demote
- (StCall (Left SLIT("pow")) CCallConv DoubleRep
+ (StCall (Left FSLIT("pow")) CCallConv DoubleRep
[promote x, promote y])
)
- MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
+ MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
[x, y])
other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
where
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,
instr (ImmInt 1) r_dst,
LABEL lbl_after,
- COMMENT (_PK_ "end shift sequence")
+ COMMENT (mkFastString "end shift sequence")
]
in
returnNat (Any IntRep code__2)
= 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
-- Conversions which are a nop on sparc
MO_32U_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_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 (
(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)
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
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
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
- :: (Either FAST_STRING StixExpr) -- function to call
+ :: (Either FastString 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]
- | isLeft fn && unLeft fn == SLIT ("PerformGC_wrapper")
- = let call = toOL [
- MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- CALL (Left (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 ->
-> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
Right dyn
-> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
- ASSERT(dyn_rep == L)
+ ASSERT(case dyn_rep of { L -> True; _ -> False})
returnNat (dyn_c `snocOL` CALL (Right dyn_r))
)
`thenNat` \ callinsns ->
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn_u = _UNPK_ (unLeft fn)
+ fn_u = unpackFS (unLeft fn)
fn__2 tot_arg_size
| head fn_u == '.'
= ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
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)
+ = 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)
- 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 (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.
projects / ghc-hetmet.git / blobdiff