From 383f737fe5ade5c6049ef0e1824fe5ec196254ba Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 29 Jan 2002 16:52:32 +0000 Subject: [PATCH] [project @ 2002-01-29 16:52:25 by sewardj] sparc NCG fixes for f-i-dynamic. --- ghc/compiler/nativeGen/MachCode.lhs | 43 +++++++++++++++++++------------ ghc/compiler/nativeGen/MachMisc.lhs | 2 +- ghc/compiler/nativeGen/PprMach.lhs | 4 ++- ghc/compiler/nativeGen/RegAllocInfo.lhs | 8 ++++-- 4 files changed, 37 insertions(+), 20 deletions(-) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index ac2944c..023225c 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 c29aee4..012b319 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 ae2aa96..60870cf 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 0791d5d..880a50e 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) -- 1.7.10.4