summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/nativeGen/MachCode.lhs43
-rw-r--r--ghc/compiler/nativeGen/MachMisc.lhs2
-rw-r--r--ghc/compiler/nativeGen/PprMach.lhs4
-rw-r--r--ghc/compiler/nativeGen/RegAllocInfo.lhs8
4 files changed, 37 insertions, 20 deletions
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index ac2944cdc2..023225cc54 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -1275,7 +1275,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 (
@@ -1391,15 +1391,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 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
- 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
@@ -2375,7 +2375,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
@@ -2858,11 +2858,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)
@@ -2871,13 +2883,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
@@ -2885,9 +2895,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 (_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.
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index c29aee43a9..012b319dea 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -677,7 +677,7 @@ is_G_instr instr
| BF Cond Bool Imm -- cond, annul?, target
| JMP DestInfo MachRegsAddr -- target
- | CALL Imm Int Bool -- target, args, terminal
+ | CALL (Either Imm Reg) Int Bool -- target, args, terminal
data RI = RIReg Reg
| RIImm Imm
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index ae2aa96df6..60870cf047 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -1687,8 +1687,10 @@ pprInstr (BF cond b lab)
pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
-pprInstr (CALL imm n _)
+pprInstr (CALL (Left imm) n _)
= hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
+pprInstr (CALL (Right reg) n _)
+ = hcat [ ptext SLIT("\tcall *\t"), pprReg reg, comma, int n ]
\end{code}
Continue with SPARC-only printing bits and bobs:
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 0791d5d092..880a50e8d2 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -369,8 +369,10 @@ regUsage instr = case instr of
-- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
JMP dst addr -> usage (regAddr addr, [])
- CALL _ n True -> noUsage
- CALL _ n False -> usage (argRegs n, callClobberedRegs)
+ CALL (Left imm) n True -> noUsage
+ CALL (Left imm) n False -> usage (argRegs n, callClobberedRegs)
+ CALL (Right reg) n True -> usage ([reg], [])
+ CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs)
_ -> noUsage
where
@@ -744,6 +746,8 @@ patchRegs instr env = case instr of
FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
JMP dsts addr -> JMP dsts (fixAddr addr)
+ CALL (Left i) n t -> CALL (Left i) n t
+ CALL (Right r) n t -> CALL (Right (env r)) n t
_ -> instr
where
fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
View Lorry Controller Status