[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.

diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 2ddb991..2412173 100644 (file)
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/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

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 0ae1867..41f8410 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/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)
 

diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 3933351..23f81a9 100644 (file)
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/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

diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 530146d..cf2cc8a 100644 (file)
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/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}