[project @ 2002-01-29 16:52:25 by sewardj]

sparc NCG fixes for f-i-dynamic.

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index ac2944c..023225c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)