[project @ 2000-01-31 18:11:50 by sewardj]

Spilling and x86 shift-code cleanups.

5 files changed, 84 insertions, 98 deletions

diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs
index 4a2e0cdfc7..53495daf8a 100644
--- a/ghc/compiler/main/Constants.lhs
+++ b/ghc/compiler/main/Constants.lhs
@@ -25,6 +25,7 @@ module Constants (
 	tICKY_HDR_SIZE,
 	aRR_WORDS_HDR_SIZE,
 	aRR_PTRS_HDR_SIZE,
+        rESERVED_C_STACK_BYTES,
 
 	sTD_ITBL_SIZE,
 	pROF_ITBL_SIZE,
@@ -229,3 +230,10 @@ using:
 interfaceFileFormatVersion :: Int
 interfaceFileFormatVersion = HscIfaceFileVersion
 \end{code}
+
+This tells the native code generator the size of the spill
+area is has available.
+
+\begin{code}
+rESERVED_C_STACK_BYTES = (RESERVED_C_STACK_BYTES :: Int)
+\end{code}
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index b38b24ba9c..0ae1867d64 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -631,9 +631,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 	    => trivialCode's is not restrictive enough (sigh.)
 	-}
 	   
-      SllOp -> shift_code (SHL L) x y {-False-}
-      SrlOp -> shift_code (SHR L) x y {-False-}
-
+      SllOp  -> shift_code (SHL L) x y {-False-}
+      SrlOp  -> shift_code (SHR L) x y {-False-}
       ISllOp -> shift_code (SHL L) x y {-False-}
       ISraOp -> shift_code (SAR L) x y {-False-}
       ISrlOp -> shift_code (SHR L) x y {-False-}
@@ -649,7 +648,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   where
 
     --------------------
-    shift_code :: (Operand -> Operand -> Instr)
+    shift_code :: (Imm -> Operand -> Instr)
 	       -> StixTree
 	       -> StixTree
 	       -> UniqSM Register
@@ -659,21 +658,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
     shift_code instr x y{-amount-}
       | maybeToBool imm
       = getRegister x		`thenUs` \ register ->
-	let
-	    op_imm = OpImm imm__2
+	let op_imm = OpImm imm__2
 	    code__2 dst = 
-		let
-		 code  = registerCode  register dst
-		 src   = registerName  register dst
+		let code  = registerCode  register dst
+                    src   = registerName  register dst
 	        in
-		mkSeqInstr (COMMENT SLIT("shift_code")) . 
 		code .
 		if isFixed register && src /= dst
-		then
-		   mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-				instr op_imm  (OpReg dst)]
-		else
-		   mkSeqInstr (instr op_imm (OpReg src)) 
+		then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+                                  instr imm__2  (OpReg dst)]
+                else mkSeqInstr (instr imm__2 (OpReg src)) 
 	in
         returnUs (Any IntRep code__2)
       where
@@ -681,6 +675,12 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        imm__2 = case imm of Just x -> x
 
       {- Case2: shift length is complex (non-immediate) -}
+      -- Since ECX is always used as a spill temporary, we can't
+      -- use it here to do non-immediate shifts.  No big deal --
+      -- they are only very rare, and we can use an equivalent
+      -- test-and-jump sequence which doesn't use ECX.
+      -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
+      -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
     shift_code instr x y{-amount-}
      = getRegister x   `thenUs` \ register1 ->
        getRegister y   `thenUs` \ register2 ->
@@ -707,27 +707,27 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 
                        BT L (ImmInt 4) r_tmp,
                        JXX GEU lbl_test3,
-                       instr (OpImm (ImmInt 16)) r_dst,
+                       instr (ImmInt 16) r_dst,
 
                        LABEL lbl_test3,
                        BT L (ImmInt 3) r_tmp,
                        JXX GEU lbl_test2,
-                       instr (OpImm (ImmInt 8)) r_dst,
+                       instr (ImmInt 8) r_dst,
 
                        LABEL lbl_test2,
                        BT L (ImmInt 2) r_tmp,
                        JXX GEU lbl_test1,
-                       instr (OpImm (ImmInt 4)) r_dst,
+                       instr (ImmInt 4) r_dst,
 
                        LABEL lbl_test1,
                        BT L (ImmInt 1) r_tmp,
                        JXX GEU lbl_test0,
-                       instr (OpImm (ImmInt 2)) r_dst,
+                       instr (ImmInt 2) r_dst,
 
                        LABEL lbl_test0,
                        BT L (ImmInt 0) r_tmp,
                        JXX GEU lbl_after,
-                       instr (OpImm (ImmInt 1)) r_dst,
+                       instr (ImmInt 1) r_dst,
                        LABEL lbl_after,
                                            
                        COMMENT (_PK_ "end shift sequence")
@@ -735,39 +735,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        in
        returnUs (Any IntRep code__2)
 
-{-
-     -- since ECX is always used as a spill temporary, we can't
-     -- use it here to do non-immediate shifts.  No big deal --
-     -- they are only very rare, and we can give an equivalent
-     -- insn sequence which doesn't use ECX.
-     -- DO NOT USE THIS CODE, SINCE IT IS INCOMPATIBLE WITH THE SPILLER
-     = getRegister y		`thenUs` \ register1 ->  
-       getRegister x		`thenUs` \ register2 ->
-       let
-	-- Note: we force the shift length to be loaded
-	-- into ECX, so that we can use CL when shifting.
-	-- (only register location we are allowed
-	-- to put shift amounts.)
-	-- 
-	-- The shift instruction is fed ECX as src reg,
-	-- but we coerce this into CL when printing out.
-	src1	= registerName register1 ecx
-    	code1   = if src1 /= ecx then -- if it is not in ecx already, force it!
-    		    registerCode register1 ecx .
-		    mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
-		  else 
-    		    registerCode register1 ecx
-    	code__2 = 
-		      let
-	               code2 = registerCode register2 eax
-	               src2  = registerName register2 eax
-		      in
-		      code1 . code2 .
-		      mkSeqInstr (instr (OpReg ecx) (OpReg eax))
-       in
-       returnUs (Fixed IntRep eax code__2)
--}
-
     --------------------
     add_code :: Size -> StixTree -> StixTree -> UniqSM Register
 
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index 893bf873e4..6f5337339d 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -503,11 +503,11 @@ current translation.
 	      | XOR	      Size Operand Operand
 	      | NOT	      Size Operand
 	      | NEGI	      Size Operand -- NEG instruction (name clash with Cond)
-	      | SHL	      Size Operand Operand -- 1st operand must be an Imm or CL
-	      | SAR	      Size Operand Operand -- 1st operand must be an Imm or CL
-	      | SHR	      Size Operand Operand -- 1st operand must be an Imm or CL
-	      | NOP
+	      | SHL	      Size Imm Operand -- Only immediate shifts allowed
+	      | SAR	      Size Imm Operand -- Only immediate shifts allowed
+	      | SHR	      Size Imm Operand -- Only immediate shifts allowed
               | BT            Size Imm Operand
+	      | NOP
 
 -- Float Arithmetic. -- ToDo for 386
 
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 6232f3751b..393335181f 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -977,9 +977,10 @@ pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
 
-pprInstr (SHL size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("shl")  size imm dst
-pprInstr (SAR size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("sar")  size imm dst
-pprInstr (SHR size imm dst) = {-pprSizeByteOpOp-} pprSizeOpOp SLIT("shr")  size imm dst
+pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
+pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
+pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
+pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt")  size imm src
 
 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp")  size src dst
 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
@@ -989,7 +990,6 @@ pprInstr PUSHA = ptext SLIT("\tpushal")
 pprInstr POPA = ptext SLIT("\tpopal")
 
 pprInstr (NOP) = ptext SLIT("\tnop")
-pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
 pprInstr (CLTD) = ptext SLIT("\tcltd")
 
 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index c1bd50c7eb..620d503bf5 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -65,6 +65,7 @@ import OrdList		( mkUnitList )
 import PrimRep		( PrimRep(..) )
 import UniqSet		-- quite a bit of it
 import Outputable
+import Constants	( rESERVED_C_STACK_BYTES )
 \end{code}
 
 %************************************************************************
@@ -367,9 +368,9 @@ regUsage instr = case instr of
     XOR  sz src dst	-> usage2s src dst
     NOT  sz op		-> usage1 op
     NEGI sz op		-> usage1 op
-    SHL  sz len dst	-> usage2s len dst -- len is either an Imm or ecx.
-    SAR  sz len dst	-> usage2s len dst -- len is either an Imm or ecx.
-    SHR  sz len dst	-> usage2s len dst -- len is either an Imm or ecx.
+    SHL  sz imm dst	-> usage1 dst
+    SAR  sz imm dst	-> usage1 dst
+    SHR  sz imm dst	-> usage1 dst
     BT   sz imm src	-> usage (opToReg src) []
 
     PUSH sz op		-> usage (opToReg op) []
@@ -414,7 +415,7 @@ regUsage instr = case instr of
     LABEL _		-> noUsage
     ASCII _ _		-> noUsage
     DATA _ _		-> noUsage
-    _			-> pprPanic "regUsage(x86) " empty
+    _			-> pprPanic "regUsage(x86)" empty
 
  where
     -- 2 operand form in which the second operand is purely a destination
@@ -558,13 +559,15 @@ a singleton list which we know will satisfy all spill demands.
 findReservedRegs :: [Instr] -> [[RegNo]]
 findReservedRegs instrs
 #if alpha_TARGET_ARCH
-  = [[NCG_Reserved_I1, NCG_Reserved_I2,
-      NCG_Reserved_F1, NCG_Reserved_F2]]
+  = --[[NCG_Reserved_I1, NCG_Reserved_I2,
+    --  NCG_Reserved_F1, NCG_Reserved_F2]]
+    error "findReservedRegs: alpha"
 #endif
 #if sparc_TARGET_ARCH
-  = [[NCG_Reserved_I1, NCG_Reserved_I2,
-      NCG_Reserved_F1, NCG_Reserved_F2,
-      NCG_Reserved_D1, NCG_Reserved_D2]]
+  = --[[NCG_Reserved_I1, NCG_Reserved_I2,
+    --  NCG_Reserved_F1, NCG_Reserved_F2,
+    --  NCG_Reserved_D1, NCG_Reserved_D2]]
+    error "findReservedRegs: sparc"
 #endif
 #if i386_TARGET_ARCH
     -- Sigh.  This is where it gets complicated.
@@ -741,10 +744,10 @@ patchRegs instr env = case instr of
     XOR  sz src dst	-> patch2 (XOR  sz) src dst
     NOT  sz op 		-> patch1 (NOT  sz) op
     NEGI sz op		-> patch1 (NEGI sz) op
-    SHL  sz imm dst 	-> patch2 (SHL  sz) imm dst
-    SAR  sz imm dst 	-> patch2 (SAR  sz) imm dst
-    SHR  sz imm dst 	-> patch2 (SHR  sz) imm dst
-    BT   sz imm src     -> patch1 (BT sz imm) src
+    SHL  sz imm dst 	-> patch1 (SHL sz imm) dst
+    SAR  sz imm dst 	-> patch1 (SAR sz imm) dst
+    SHR  sz imm dst 	-> patch1 (SHR sz imm) dst
+    BT   sz imm src     -> patch1 (BT  sz imm) src
     TEST sz src dst	-> patch2 (TEST sz) src dst
     CMP  sz src dst	-> patch2 (CMP  sz) src dst
     PUSH sz op		-> patch1 (PUSH sz) op
@@ -855,52 +858,60 @@ patchRegs instr env = case instr of
 
 Spill to memory, and load it back...
 
-JRS, 000122: on x86, don't spill directly above the stack pointer, since 
-some insn sequences (int <-> conversions) use this as a temp location.
-Leave 16 bytes of slop.
+JRS, 000122: on x86, don't spill directly above the stack pointer,
+since some insn sequences (int <-> conversions, and eventually
+StixInteger) use this as a temp location.  Leave 8 words (ie, 64 bytes
+for a 64-bit arch) of slop.
 
 \begin{code}
+maxSpillSlots :: Int
+maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 8
+
+-- convert a spill slot number to a *byte* offset, with no sign:
+-- decide on a per arch basis whether you are spilling above or below
+-- the C stack pointer.
+spillSlotToOffset :: Int -> Int
+spillSlotToOffset slot
+   | slot >= 0 && slot < maxSpillSlots
+   = 64 + 8 * slot
+   | otherwise
+   = pprPanic "spillSlotToOffset:" 
+              (text "invalid spill location: " <> int slot)
+
 spillReg, loadReg :: Reg -> Reg -> InstrList
 
 spillReg dyn (MemoryReg i pk)
-  | i >= 0 -- JRS paranoia
-  = let	sz = primRepToSize pk
+  = let	sz  = primRepToSize pk
+        off = spillSlotToOffset i
     in
     mkUnitList (
 	{-Alpha: spill below the stack pointer (?)-}
-	 IF_ARCH_alpha( ST sz dyn (spRel i)
+	 IF_ARCH_alpha( ST sz dyn (spRel (- (off `div` 8)))
 
 	{-I386: spill above stack pointer leaving 2 words/spill-}
-	,IF_ARCH_i386 ( let loc | i < 60    = 4 + 2 * i
-                                | otherwise = -2000 - 2 * i
+	,IF_ARCH_i386 ( let off_w = off `div` 4
                         in
                         if pk == FloatRep || pk == DoubleRep
-                        then GST DF dyn (spRel loc)
-                        else MOV sz (OpReg dyn) (OpAddr (spRel loc))
+                        then GST DF dyn (spRel off_w)
+                        else MOV sz (OpReg dyn) (OpAddr (spRel off_w))
 
 	{-SPARC: spill below frame pointer leaving 2 words/spill-}
-	,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i))
+	,IF_ARCH_sparc( ST sz dyn (fpRel (- (off `div` 4)))
         ,)))
     )
-  | otherwise
-  = pprPanic "spillReg:" (text "invalid spill location: " <> int i)
    
-----------------------------
 loadReg (MemoryReg i pk) dyn
-  | i >= 0 -- JRS paranoia
-  = let	sz = primRepToSize pk
+  = let	sz  = primRepToSize pk
+        off = spillSlotToOffset i
     in
     mkUnitList (
-	 IF_ARCH_alpha( LD  sz dyn (spRel i)
-	,IF_ARCH_i386 ( let loc | i < 60    = 4 + 2 * i
-                                | otherwise = -2000 - 2 * i
+	 IF_ARCH_alpha( LD  sz dyn (spRel (- (off `div` 8)))
+	,IF_ARCH_i386 ( let off_w = off `div` 4
                         in
                         if   pk == FloatRep || pk == DoubleRep
-                        then GLD DF (spRel loc) dyn
-                        else MOV sz (OpAddr (spRel loc)) (OpReg dyn)
-	,IF_ARCH_sparc( LD  sz (fpRel (-2 * i)) dyn
+                        then GLD DF (spRel off_w) dyn
+                        else MOV sz (OpAddr (spRel off_w)) (OpReg dyn)
+	,IF_ARCH_sparc( LD  sz (fpRel (- (off `div` 4))) dyn
 	,)))
     )
-  | otherwise
-  = pprPanic "loadReg:" (text "invalid spill location: " <> int i)
 \end{code}