From: sewardj <unknown>
Date: Fri, 14 Dec 2001 16:57:36 +0000 (+0000)
Subject: [project @ 2001-12-14 16:57:36 by sewardj]
X-Git-Tag: Approximately_9120_patches~384
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5a387d82672b4648c38793a57a69cfda07f1baff;p=ghc-hetmet.git

[project @ 2001-12-14 16:57:36 by sewardj]
Sparc NCG changes to track recent mulIntC# changes.  The Prelude
can now finally be compiled with the sparc NCG.

Also (incidentally) emit sparc integer multiply insns directly
rather than calling a helper routine.  Most sparcs should implement
them by now :)
---

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index ff2800e..58606b9 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -1353,14 +1353,15 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
       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
@@ -1388,7 +1389,29 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
 
       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 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 = 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 ->
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index f7f4b8f..ed5737f 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -636,6 +636,9 @@ is_G_instr instr
 
 	      | ADD	      Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
 	      | SUB	      Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
+	      | UMUL	           Bool Reg RI Reg --     cc?, src1, src2, dst
+	      | SMUL	           Bool Reg RI Reg --     cc?, src1, src2, dst
+              | RDY           Reg	-- move contents of Y register to reg
 
 -- Simple bit-twiddling.
 
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index e643e75..0e3ae29 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -1527,6 +1527,10 @@ pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
 
+pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
+pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
+pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
+
 pprInstr (SETHI imm reg)
   = hcat [
 	ptext SLIT("\tsethi\t"),
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 5d8f73b..f1149ac 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -341,6 +341,9 @@ regUsage instr = case instr of
     ST    sz reg addr  	-> usage (reg : regAddr addr, [])
     ADD   x cc r1 ar r2	-> usage (r1 : regRI ar, [r2])
     SUB   x cc r1 ar r2	-> usage (r1 : regRI ar, [r2])
+    UMUL    cc r1 ar r2	-> usage (r1 : regRI ar, [r2])
+    SMUL    cc r1 ar r2	-> usage (r1 : regRI ar, [r2])
+    RDY   rd            -> usage ([], [rd])
     AND   b r1 ar r2  	-> usage (r1 : regRI ar, [r2])
     ANDN  b r1 ar r2 	-> usage (r1 : regRI ar, [r2])
     OR    b r1 ar r2   	-> usage (r1 : regRI ar, [r2])
@@ -714,6 +717,9 @@ patchRegs instr env = case instr of
     ST    sz reg addr   -> ST sz (env reg) (fixAddr addr)
     ADD   x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
     SUB   x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
+    UMUL    cc r1 ar r2	-> UMUL cc (env r1) (fixRI ar) (env r2)
+    SMUL    cc r1 ar r2	-> SMUL cc (env r1) (fixRI ar) (env r2)
+    RDY   rd            -> RDY (env rd)
     AND   b r1 ar r2    -> AND b (env r1) (fixRI ar) (env r2)
     ANDN  b r1 ar r2    -> ANDN b (env r1) (fixRI ar) (env r2)
     OR    b r1 ar r2    -> OR b (env r1) (fixRI ar) (env r2)