[project @ 2004-08-13 10:45:16 by simonmar]

[ghc-hetmet.git] / ghc / compiler / nativeGen / AsmRegAlloc.lhs

diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 162befc..90b379a 100644 (file)
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -10,17 +10,18 @@ module AsmRegAlloc ( runRegAllocate ) where
 
 import MachCode                ( InstrBlock )
 import MachMisc                ( Instr(..) )
+import PprMach         ( pprInstr )    -- Just for debugging
 import MachRegs
 import RegAllocInfo
 
-import FiniteMap       ( FiniteMap, emptyFM, addListToFM, delListFromFM, 
-                         lookupFM, keysFM, eltsFM, mapFM, addToFM_C, addToFM,
-                         listToFM, fmToList, lookupWithDefaultFM )
-import Unique          ( mkBuiltinUnique )
-import OrdList         ( unitOL, appOL, fromOL, concatOL )
+import FiniteMap       ( FiniteMap, emptyFM, 
+                         lookupFM, eltsFM, addToFM_C, addToFM,
+                         listToFM, fmToList )
+import OrdList         ( fromOL )
 import Outputable
-import Unique          ( Unique, Uniquable(..), mkPseudoUnique3 )
+import Unique          ( mkPseudoUnique3 )
 import CLabel          ( CLabel, pprCLabel )
+import FastTypes
 
 import List            ( mapAccumL, nub, sort )
 import Array           ( Array, array, (!), bounds )
@@ -65,7 +66,13 @@ runRegAllocate regs find_reserve_regs instrs
     --)
   where
     tryGeneral [] 
-       = error "nativeGen: spilling failed.  Workaround: compile with -fvia-C.\n"
+       = pprPanic "nativeGen: spilling failed.  Workaround: compile with -fvia-C.\n"
+            ( (text "reserves = " <> ppr reserves)
+              $$
+              (text "code = ")
+              $$
+              (vcat (map (docToSDoc.pprInstr) flatInstrs))
+            )
     tryGeneral (resv:resvs)
        = case generalAlloc resv of
             Just success -> success
@@ -199,7 +206,9 @@ doGeneralAlloc
 
 doGeneralAlloc all_regs reserve_regs instrs
    -- succeeded without spilling
-   | prespill_ok        = Just prespill_insns
+   | prespill_ok
+   = Just prespill_insns
+
    -- failed, and no spill regs avail, so pointless to attempt spilling 
    | null reserve_regs  = Nothing
    -- success after spilling
@@ -262,7 +271,7 @@ spill slot numbers for the uniques.
 insertSpillCode :: [Instr] -> [Instr]
 insertSpillCode insns
    = let uniques_in_insns
-            = map getUnique 
+            = map getVRegUnique 
                   (regSetToList 
                      (foldl unionRegSets emptyRegSet 
                             (map vregs_in_insn insns)))
@@ -270,7 +279,7 @@ insertSpillCode insns
             = case regUsage i of
                  RU rds wrs -> filterRegSet isVirtualReg 
                                              (rds `unionRegSets` wrs)
-         vreg_to_slot_map :: FiniteMap Unique Int
+         vreg_to_slot_map :: FiniteMap VRegUnique Int
          vreg_to_slot_map
             = listToFM (zip uniques_in_insns [0..])
 
@@ -288,7 +297,7 @@ insertSpillCode insns
 -- to the stack pointer, as opposed to the frame pointer.  The other is a 
 -- counter, used to manufacture new temporary register names.
 
-patchInstr :: FiniteMap Unique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr])
+patchInstr :: FiniteMap VRegUnique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr])
 patchInstr vreg_to_slot_map (delta,ctr) instr
 
  | null memSrcs && null memDsts 
@@ -321,13 +330,15 @@ patchInstr vreg_to_slot_map (delta,ctr) instr
            | isVirtualReg vreg
            = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of
                 [i] -> case regClass vreg of
-                          RcInteger -> VirtualRegI (mkPseudoUnique3 i)
-                          RcFloat   -> VirtualRegF (mkPseudoUnique3 i)
-                          RcDouble  -> VirtualRegD (mkPseudoUnique3 i)
+                          RcInteger -> VirtualRegI (pseudoVReg i)
+                          RcFloat   -> VirtualRegF (pseudoVReg i)
+                          RcDouble  -> VirtualRegD (pseudoVReg i)
                 _   -> pprPanic "patchInstr: unmapped VReg" (ppr vreg)
            | otherwise
            = vreg
 
+        pseudoVReg i = VRegUniqueLo (mkPseudoUnique3 i)
+
        memSrcs   = filter isVirtualReg (regSetToList srcs)
        memDsts   = filter isVirtualReg (regSetToList dsts)
 
@@ -616,8 +627,8 @@ mk_initial_approx ino (i:is) succ_map ia_so_far
    = let wrs 
             = case regUsage i of RU rrr www -> www
          new_fes 
-            = [case ino of      { I# inoh ->
-               case ino_succ of { I# ino_succh ->
+            = [case iUnbox ino of      { inoh ->
+               case iUnbox ino_succ of { ino_succh ->
                MkFE inoh ino_succh 
                }}
                   | ino_succ <- succ_map ! ino]
@@ -665,8 +676,8 @@ upd_liveness_info pred_map succ_map insn_array prev_approx
            = approx
            | otherwise
            = let fes_to_futures
-                    = [case ino of        { I# inoh ->
-                       case future_ino of { I# future_inoh ->
+                    = [case iUnbox ino of        { inoh ->
+                       case iUnbox future_ino of { future_inoh ->
                        MkFE inoh future_inoh
                        }}
                           | future_ino <- succ_map ! ino]
@@ -676,8 +687,8 @@ upd_liveness_info pred_map succ_map insn_array prev_approx
                     = foldr unionRegSets emptyRegSet future_lives
 
                  fes_from_histories
-                    = [case history_ino of { I# history_inoh ->
-                       case ino of         { I# inoh ->
+                    = [case iUnbox history_ino of { history_inoh ->
+                       case iUnbox ino of         { inoh ->
                        MkFE history_inoh inoh
                        }}
                           | history_ino <- pred_map ! ino]
@@ -771,8 +782,8 @@ find_flow_edges insns
                  Branch lab -- jmps to lab; add fe i_num -> i_target
                     -> let i_target = find_label lab
                        in 
-                       mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map)
-                                           is
+                       mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is
+
                  NextOrBranch lab
                     |  null is   -- jmps to label, or falls through, and this is
                                  -- the last insn (a meaningless scenario); 
@@ -785,6 +796,13 @@ find_flow_edges insns
                        in
                        mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
                                            is
+                 MultiFuture labels
+                    -> -- A jump, whose targets are listed explicitly.  
+                       -- (Generated from table-based switch translations).
+                       -- Add fes  i_num -> x  for each x in labels
+                       let is_target = nub (map find_label labels)
+                       in
+                       mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is
 
          -- Third phase: invert the successor map to get the predecessor
          -- map, using an algorithm which is quadratic in the worst case,
@@ -853,12 +871,12 @@ find_flow_edges insns
 
 -- A data type for flow edges
 data FE 
-   = MkFE Int# Int# deriving (Eq, Ord)
+   = MkFE FastInt FastInt deriving (Eq, Ord)
 
 -- deriving Show on types with unboxed fields doesn't work
 instance Show FE where
     showsPrec _ (MkFE s d) 
-       = showString "MkFE" . shows (I# s) . shows ' ' . shows (I# d)
+       = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d)
 
 -- Blargh.  Use ghc stuff soon!  Or: perhaps that's not such a good
 -- idea.  Most of these sets are either empty or very small, and it