[project @ 2005-07-26 13:13:20 by simonmar]

some small optimisations

diff --git a/ghc/compiler/nativeGen/RegAllocInfo.hs b/ghc/compiler/nativeGen/RegAllocInfo.hs
index 1a5de43..2380370 100644 (file)
--- a/ghc/compiler/nativeGen/RegAllocInfo.hs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.hs
@@ -161,16 +161,16 @@ regUsage instr = case instr of
     SHL    sz imm dst  -> usageRM imm dst
     SAR    sz imm dst  -> usageRM imm dst
     SHR    sz imm dst  -> usageRM imm dst
-    BT     sz imm src  -> mkRU (use_R src) []
+    BT     sz imm src  -> mkRUR (use_R src)
 
-    PUSH   sz op       -> mkRU (use_R op) []
+    PUSH   sz op       -> mkRUR (use_R op)
     POP    sz op       -> mkRU [] (def_W op)
-    TEST   sz src dst  -> mkRU (use_R src ++ use_R dst) []
-    CMP    sz src dst  -> mkRU (use_R src ++ use_R dst) []
+    TEST   sz src dst  -> mkRUR (use_R src ++ use_R dst)
+    CMP    sz src dst  -> mkRUR (use_R src ++ use_R dst)
     SETCC  cond op     -> mkRU [] (def_W op)
     JXX    cond lbl    -> mkRU [] []
-    JMP    op          -> mkRU (use_R op) []
-    JMP_TBL op ids      -> mkRU (use_R op) []
+    JMP    op          -> mkRUR (use_R op)
+    JMP_TBL op ids      -> mkRUR (use_R op)
     CALL (Left imm)  params -> mkRU params callClobberedRegs
     CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
     CLTD   sz          -> mkRU [eax] [edx]
@@ -179,7 +179,7 @@ regUsage instr = case instr of
 #if i386_TARGET_ARCH
     GMOV   src dst     -> mkRU [src] [dst]
     GLD    sz src dst  -> mkRU (use_EA src) [dst]
-    GST    sz src dst  -> mkRU (src : use_EA dst) []
+    GST    sz src dst  -> mkRUR (src : use_EA dst)
 
     GLDZ   dst         -> mkRU [] [dst]
     GLD1   dst         -> mkRU [] [dst]
@@ -195,7 +195,7 @@ regUsage instr = case instr of
     GMUL   sz s1 s2 dst        -> mkRU [s1,s2] [dst]
     GDIV   sz s1 s2 dst        -> mkRU [s1,s2] [dst]
 
-    GCMP   sz src1 src2        -> mkRU [src1,src2] []
+    GCMP   sz src1 src2        -> mkRUR [src1,src2]
     GABS   sz src dst  -> mkRU [src] [dst]
     GNEG   sz src dst  -> mkRU [src] [dst]
     GSQRT  sz src dst  -> mkRU [src] [dst]
@@ -232,17 +232,17 @@ regUsage instr = case instr of
     -- 2 operand form; first operand Read; second Written
     usageRW :: Operand -> Operand -> RegUsage
     usageRW op (OpReg reg) = mkRU (use_R op) [reg]
-    usageRW op (OpAddr ea) = mkRU (use_R op ++ use_EA ea) []
+    usageRW op (OpAddr ea) = mkRUR (use_R op ++ use_EA ea)
 
     -- 2 operand form; first operand Read; second Modified
     usageRM :: Operand -> Operand -> RegUsage
     usageRM op (OpReg reg) = mkRU (use_R op ++ [reg]) [reg]
-    usageRM op (OpAddr ea) = mkRU (use_R op ++ use_EA ea) []
+    usageRM op (OpAddr ea) = mkRUR (use_R op ++ use_EA ea)
 
     -- 1 operand form; operand Modified
     usageM :: Operand -> RegUsage
     usageM (OpReg reg)    = mkRU [reg] [reg]
-    usageM (OpAddr ea)    = mkRU (use_EA ea) []
+    usageM (OpAddr ea)    = mkRUR (use_EA ea)
 
     -- Registers defd when an operand is written.
     def_W (OpReg reg)  = [reg]
@@ -262,8 +262,12 @@ regUsage instr = case instr of
              use_index EAIndexNone   = []
              use_index (EAIndex i _) = [i]
 
-    mkRU src dst = RU (filter interesting src)
-                     (filter interesting dst)
+    mkRUR src = src' `seq` RU src' []
+       where src' = filter interesting src
+
+    mkRU src dst = src' `seq` dst' `seq` RU src' dst'
+       where src' = filter interesting src
+             dst' = filter interesting dst
 
 #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

diff --git a/ghc/compiler/nativeGen/RegisterAlloc.hs b/ghc/compiler/nativeGen/RegisterAlloc.hs
index 1295f9c..46bfbd2 100644 (file)
--- a/ghc/compiler/nativeGen/RegisterAlloc.hs
+++ b/ghc/compiler/nativeGen/RegisterAlloc.hs
@@ -208,8 +208,9 @@ getFreeRegs cls f = go f 0
        -- ToDo: there's no point looking through all the integer registers
        -- in order to find a floating-point one.
 
-allocateReg :: FreeRegs -> RegNo -> FreeRegs
-allocateReg f r = f .&. complement (1 `shiftL` fromIntegral r)
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
+
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -425,12 +426,11 @@ raInsn block_live new_instrs (instr, r_dying, w_dying) = do
        other -> genRaInsn block_live new_instrs instr r_dying w_dying
 
 
-genRaInsn block_live new_instrs instr r_dying w_dying = do
+genRaInsn block_live new_instrs instr r_dying w_dying =
+    case regUsage instr              of { RU read written ->
+    case partition isRealReg written of { (real_written1,virt_written) ->
+    do
     let 
-       RU read written = regUsage instr
-
-       (real_written1,virt_written) = partition isRealReg written
-
        real_written = [ r | RealReg r <- real_written1 ]
 
        -- we don't need to do anything with real registers that are
@@ -494,6 +494,7 @@ genRaInsn block_live new_instrs instr r_dying w_dying = do
     return (patched_instr : w_spills ++ reverse r_spills
                 ++ clobber_saves ++ new_instrs,
            fixup_blocks)
+  }}
 
 -- -----------------------------------------------------------------------------
 -- releaseRegs
@@ -503,6 +504,7 @@ releaseRegs regs = do
   free <- getFreeRegsR
   loop assig free regs 
  where
+  loop assig free _ | free `seq` False = undefined
   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
   loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
   loop assig free (r:rs) = 
@@ -556,7 +558,7 @@ clobberRegs :: [RegNo] -> RegM ()
 clobberRegs [] = return () -- common case
 clobberRegs clobbered = do
   freeregs <- getFreeRegsR
-  setFreeRegsR (foldl allocateReg freeregs clobbered)
+  setFreeRegsR $! foldr allocateReg freeregs clobbered
   assig <- getAssigR
   setAssigR $! clobber assig (ufmToList assig)
  where
@@ -622,7 +624,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
                 | Just (InMem slot) <- loc, reading = InBoth my_reg slot
                 | otherwise                         = InReg my_reg
            setAssigR (addToUFM assig r $! new_loc)
-           setFreeRegsR (allocateReg freeregs my_reg)
+           setFreeRegsR (allocateReg my_reg freeregs)
            allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 
         -- case (3): we need to push something out to free up a register
@@ -752,7 +754,7 @@ data RA_State
        ra_blockassig :: BlockAssignment,
                -- The current mapping from basic blocks to 
                -- the register assignments at the beginning of that block.
-       ra_freeregs   :: FreeRegs,      -- free machine registers
+       ra_freeregs   :: {-#UNPACK#-}!FreeRegs, -- free machine registers
        ra_assig      :: RegMap Loc,    -- assignment of temps to locations
        ra_delta      :: Int,           -- current stack delta
        ra_stack      :: FreeStack      -- free stack slots for spilling