[project @ 2000-02-01 14:02:02 by sewardj]

-- Cosmetic changes in register allocator.

-- Implement macro HP_GEN_SEQ_NP.

-- MachCode(trivialCode, x86): because one of the operands is also
   the destination (on this 2-address arch), it's invalid to sequence
   the code to compute the operands using asmParThen [code1, code2].
   since the order of assignments matters.  Fixed.

ghc/compiler/nativeGen/AsmRegAlloc.lhs

@@ -10,6 +10,7 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
 
 import MachCode		( InstrList )
 import MachMisc		( Instr )
+import PprMach		( pprUserReg ) -- debugging
 import MachRegs
 import RegAllocInfo
 
@@ -41,16 +42,11 @@ runRegAllocate regs find_reserve_regs instrs
 	Nothing     -> tryHairy reserves
   where
     tryHairy [] 
-       = error "nativeGen: register allocator: too difficult!  Try -fvia-C.\n"
+       = error "nativeGen: spilling failed.  Try -fvia-C.\n"
     tryHairy (resv:resvs)
        = case hairyAlloc resv of
             Just success -> success
-            Nothing      -> fooble resvs (tryHairy resvs)
-
-    fooble [] x = x
-    fooble (resvs:_) x = trace ("nativeGen: spilling with " 
-                                ++ show (length resvs - 2) ++ 
-                                " int temporaries") x
+            Nothing      -> tryHairy resvs
 
     reserves         = find_reserve_regs flatInstrs
     flatInstrs       = flattenOrdList instrs
@@ -168,17 +164,25 @@ hairyRegAlloc regs reserve_regs instrs =
                     noFuture instrs_patched of
                   ((RH _ mloc2 _),_,instrs'') 
                      -- successfully allocated the patched code
-        	     | mloc2 == mloc1 -> Just instrs''
+        	     | mloc2 == mloc1 -> trace (spillMsg True) (Just instrs'')
                      -- no; we have to give up
-                     | otherwise      -> Nothing 
+                     | otherwise      -> trace (spillMsg False) Nothing 
                        -- instrs''
-	               -- pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1)
   where
     regs'  = regs `useMRegs` reserve_regs
     regs'' = mkMRegsState reserve_regs
 
     noFuture :: RegFuture
     noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
+
+    spillMsg success
+       = "nativeGen: spilling " 
+         ++ (if success then "succeeded" else "failed   ")
+         ++ " using " 
+         ++ showSDoc (hsep (map (pprUserReg.toMappedReg) 
+                                (reverse reserve_regs)))
+         where
+            toMappedReg (I# i) = MappedReg i
 \end{code}
 
 Here we patch instructions that reference ``registers'' which are really in

ghc/compiler/nativeGen/MachCode.lhs

@@ -483,8 +483,10 @@ getRegister (StDouble d)
     in
     returnUs (Any DoubleRep code)
 
+-- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix
 getRegister (StScratchWord i)
-   = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (-1000+i))) (OpReg dst))
+   | i >= 0 && i < 6
+   = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst))
      in returnUs (Any PtrRep code)
 
 getRegister (StPrim primop [x]) -- unary PrimOps
@@ -2476,10 +2478,10 @@ condIntReg cond x y
 	code = condCode condition
 	cond = condName condition
 	-- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
-	code__2 dst = code . mkSeqInstrs [COMMENT (_PK_ "aaaaa"),
+	code__2 dst = code . mkSeqInstrs [
 	    SETCC cond (OpReg tmp),
 	    AND L (OpImm (ImmInt 1)) (OpReg tmp),
-	    MOV L (OpReg tmp) (OpReg dst) ,COMMENT (_PK_ "bbbbb")]
+	    MOV L (OpReg tmp) (OpReg dst)]
     in
     returnUs (Any IntRep code__2)
 
@@ -2729,11 +2731,10 @@ trivialCode instr x y
     	code__2 dst = let code1 = registerCode register1 dst
     	                  src1  = registerName register1 dst
 		      in code1 .
-			 if isFixed register1 && src1 /= dst
+			 if   isFixed register1 && src1 /= dst
 			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
 					   instr (OpImm imm__2) (OpReg dst)]
-			 else
-				mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+			 else mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
     in
     returnUs (Any IntRep code__2)
   where
@@ -2745,17 +2746,15 @@ trivialCode instr x y
     getRegister y		`thenUs` \ register2 ->
     getNewRegNCG IntRep		`thenUs` \ tmp2 ->
     let
-    	code2 = registerCode register2 tmp2 asmVoid
+    	code2 = registerCode register2 tmp2 --asmVoid
     	src2  = registerName register2 tmp2
-    	code__2 dst = let
-    	                  code1 = registerCode register1 dst asmVoid
+    	code__2 dst = let code1 = registerCode register1 dst --asmVoid
     	                  src1  = registerName register1 dst
-		      in asmParThen [code1, code2] .
-			 if isFixed register1 && src1 /= dst
+		      in code2 . code1 .  --asmParThen [code1, code2] .
+			 if   isFixed register1 && src1 /= dst
 			 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
 					   instr (OpReg src2)  (OpReg dst)]
-			 else
-				mkSeqInstr (instr (OpReg src2) (OpReg src1))
+			 else mkSeqInstr (instr (OpReg src2) (OpReg src1))
     in
     returnUs (Any IntRep code__2)
 
@@ -2763,13 +2762,13 @@ trivialCode instr x y
 trivialUCode instr x
   = getRegister x		`thenUs` \ register ->
     let
-    	code__2 dst = let
-    	                  code = registerCode register dst
+    	code__2 dst = let code = registerCode register dst
 		      	  src  = registerName register dst
-		      in code . if isFixed register && dst /= src
-				then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
-						  instr (OpReg dst)]
-				else mkSeqInstr (instr (OpReg src))
+		      in code . 
+                         if isFixed register && dst /= src
+			 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+				           instr (OpReg dst)]
+			 else mkSeqInstr (instr (OpReg src))
     in
     returnUs (Any IntRep code__2)
 

ghc/compiler/nativeGen/PprMach.lhs

@@ -10,7 +10,7 @@ We start with the @pprXXX@s with some cross-platform commonality
 \begin{code}
 #include "nativeGen/NCG.h"
 
-module PprMach ( pprInstr, pprSize ) where
+module PprMach ( pprInstr, pprSize, pprUserReg ) where
 
 #include "HsVersions.h"
 
@@ -38,6 +38,10 @@ import Char		( ord )
 For x86, the way we print a register name depends
 on which bit of it we care about.  Yurgh.
 \begin{code}
+pprUserReg:: Reg -> SDoc
+pprUserReg = pprReg IF_ARCH_i386(L,)
+
+
 pprReg :: IF_ARCH_i386(Size ->,) Reg -> SDoc
 
 pprReg IF_ARCH_i386(s,) r
@@ -94,49 +98,16 @@ pprReg IF_ARCH_i386(s,) r
 	_ -> SLIT("very naughty I386 byte register")
       })
 
-{- UNUSED:
-    ppr_reg_no HB i = ptext
-      (case i of {
-	ILIT( 0) -> SLIT("%ah");  ILIT( 1) -> SLIT("%bh");
-	ILIT( 2) -> SLIT("%ch");  ILIT( 3) -> SLIT("%dh");
-	_ -> SLIT("very naughty I386 high byte register")
-      })
--}
-
-{- UNUSED:
-    ppr_reg_no S i = ptext
-      (case i of {
-	ILIT( 0) -> SLIT("%ax");  ILIT( 1) -> SLIT("%bx");
-	ILIT( 2) -> SLIT("%cx");  ILIT( 3) -> SLIT("%dx");
-	ILIT( 4) -> SLIT("%si");  ILIT( 5) -> SLIT("%di");
-	ILIT( 6) -> SLIT("%bp");  ILIT( 7) -> SLIT("%sp");
-	_ -> SLIT("very naughty I386 word register")
-      })
--}
-
-    ppr_reg_no L i = ptext
+    ppr_reg_no _ i = ptext
       (case i of {
 	ILIT( 0) -> SLIT("%eax");  ILIT( 1) -> SLIT("%ebx");
 	ILIT( 2) -> SLIT("%ecx");  ILIT( 3) -> SLIT("%edx");
 	ILIT( 4) -> SLIT("%esi");  ILIT( 5) -> SLIT("%edi");
 	ILIT( 6) -> SLIT("%ebp");  ILIT( 7) -> SLIT("%esp");
-	_ -> SLIT("very naughty I386 double word register")
-      })
-
-    ppr_reg_no F i = ptext
-      (case i of {
-	ILIT( 8) -> SLIT("%fake0");  ILIT( 9) -> SLIT("%fake1");
-	ILIT(10) -> SLIT("%fake2");  ILIT(11) -> SLIT("%fake3");
-	ILIT(12) -> SLIT("%fake4");  ILIT(13) -> SLIT("%fake5");
-	_ -> SLIT("very naughty I386 float register")
-      })
-
-    ppr_reg_no DF i = ptext
-      (case i of {
 	ILIT( 8) -> SLIT("%fake0");  ILIT( 9) -> SLIT("%fake1");
 	ILIT(10) -> SLIT("%fake2");  ILIT(11) -> SLIT("%fake3");
 	ILIT(12) -> SLIT("%fake4");  ILIT(13) -> SLIT("%fake5");
-	_ -> SLIT("very naughty I386 float register")
+	_ -> SLIT("very naughty I386 register")
       })
 #endif
 #if sparc_TARGET_ARCH

ghc/compiler/nativeGen/StixMacro.lhs

@@ -252,6 +252,11 @@ checkCode macro args assts
 		in  (\xs -> assign_hp words : cjmp_hp : 
 			    assts (gc_enter ptrs : join : xs))
 
+	HP_CHK_SEQ_NP  -> 
+		let [words,ptrs] = args_stix
+		in  (\xs -> assign_hp words : cjmp_hp : 
+			    assts (gc_seq ptrs : join : xs))
+
 	STK_CHK_NP     -> 
 		let [words,ptrs] = args_stix
 		in  (\xs -> cjmp_sp_pass words :
@@ -309,7 +314,8 @@ checkCode macro args assts
 	HP_CHK_UT_ALT  -> 
                 let [words,ptrs,nonptrs,r,ret] = args_stix
                 in (\xs -> assign_hp words : cjmp_hp :
-                           assts (assign_ret r ret : gc_ut ptrs nonptrs : join : xs))
+                           assts (assign_ret r ret : gc_ut ptrs nonptrs 
+                                  : join : xs))
 
 	HP_CHK_GEN     -> 
                 let [words,liveness,reentry] = args_stix
@@ -321,8 +327,12 @@ checkCode macro args assts
 	
 -- Various canned heap-check routines
 
-gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
-gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
+gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") 
+                                       <> int (fromInteger n)))
+gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") 
+                                       <> int (fromInteger n)))
+gc_seq (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_gc_seq_") 
+                                       <> int (fromInteger n)))
 gc_noregs          = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
 gc_unpt_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
 gc_unbx_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
@@ -331,6 +341,7 @@ gc_d1              = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
 gc_gen             = StJump (StLitLbl (ptext SLIT("stg_gen_chk")))
 
 gc_ut (StInt p) (StInt np)
-                   = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p) 
+                   = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") 
+                                       <> int (fromInteger p) 
                                        <> char '_' <> int (fromInteger np)))
 \end{code}