Add transitional rules for the alternative layout rule

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

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 8613a8e..615cc0c 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -25,7 +25,6 @@ import Alpha.CodeGen
 import Alpha.Regs
 import Alpha.RegInfo
 import Alpha.Instr
-import Alpha.Ppr
 
 #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
 import X86.CodeGen
@@ -37,12 +36,13 @@ import X86.Ppr
 #elif sparc_TARGET_ARCH
 import SPARC.CodeGen
 import SPARC.Regs
-import SPARC.RegInfo
 import SPARC.Instr
 import SPARC.Ppr
+import SPARC.ShortcutJump
 
 #elif powerpc_TARGET_ARCH
 import PPC.CodeGen
+import PPC.Cond
 import PPC.Regs
 import PPC.RegInfo
 import PPC.Instr
@@ -62,14 +62,17 @@ import qualified RegAlloc.Graph.Stats               as Color
 import qualified RegAlloc.Graph.Coalesce       as Color
 import qualified RegAlloc.Graph.TrivColorable  as Color
 
-import qualified TargetReg                     as Target
+import qualified SPARC.CodeGen.Expand          as SPARC
 
+import TargetReg
 import Platform
 import Instruction
 import PIC
 import Reg
+import RegClass
 import NCGMonad
 
+import BlockId
 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import PprCmm
@@ -79,7 +82,6 @@ import State
 import UniqFM
 import Unique          ( Unique, getUnique )
 import UniqSupply
-import List            ( groupBy, sortBy )
 import DynFlags
 #if powerpc_TARGET_ARCH
 import StaticFlags     ( opt_Static, opt_PIC )
@@ -195,7 +197,11 @@ nativeCodeGen dflags h us cmms
 
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_conflicts "Register conflict graph"
-                       $ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass)
+                       $ Color.dotGraph 
+                               targetRegDotColor 
+                               (Color.trivColorable 
+                                       targetVirtualRegSqueeze 
+                                       targetRealRegSqueeze)
                        $ graphGlobal)
 
 
@@ -231,19 +237,19 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
        Pretty.bufLeftRender h
                $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
 
-       let lsPprNative =
+           -- carefully evaluate this strictly.  Binding it with 'let'
+           -- and then using 'seq' doesn't work, because the let
+           -- apparently gets inlined first.
+       lsPprNative <- return $!
                if  dopt Opt_D_dump_asm       dflags
                 || dopt Opt_D_dump_asm_stats dflags
                        then native
                        else []
 
-       let count'      = count + 1;
-
+       count' <- return $! count + 1;
 
        -- force evaulation all this stuff to avoid space leaks
        seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
-       lsPprNative     `seq` return ()
-       count'          `seq` return ()
 
        cmmNativeGens dflags h us' cmms
                        (imports : impAcc)
@@ -311,13 +317,14 @@ cmmNativeGen dflags us cmm count
           || dopt Opt_RegsIterative dflags)
          then do
                -- the regs usable for allocation
-               let alloc_regs
+               let (alloc_regs :: UniqFM (UniqSet RealReg))
                        = foldr (\r -> plusUFM_C unionUniqSets
-                                       $ unitUFM (regClass r) (unitUniqSet r))
+                                       $ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
                                emptyUFM
-                       $ map RealReg allocatableRegs
+                       $ allocatableRegs
+
 
-               -- graph coloring register allocation
+               -- do the graph coloring register allocation
                let ((alloced, regAllocStats), usAlloc)
                        = {-# SCC "RegAlloc" #-}
                          initUs usLive
@@ -385,7 +392,7 @@ cmmNativeGen dflags us cmm count
                map sequenceTop shorted
 
        ---- x86fp_kludge
-       let final_mach_code =
+       let kludged =
 #if i386_TARGET_ARCH
                {-# SCC "x86fp_kludge" #-}
                map x86fp_kludge sequenced
@@ -393,15 +400,29 @@ cmmNativeGen dflags us cmm count
                sequenced
 #endif
 
+       ---- expansion of SPARC synthetic instrs
+#if sparc_TARGET_ARCH
+       let expanded = 
+               {-# SCC "sparc_expand" #-}
+               map SPARC.expandTop kludged
+
+       dumpIfSet_dyn dflags
+               Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+               (vcat $ map (docToSDoc . pprNatCmmTop) expanded)
+#else
+       let expanded = 
+               kludged
+#endif
+
        return  ( usAlloc
-               , final_mach_code
+               , expanded
                , lastMinuteImports ++ imports
                , ppr_raStatsColor
                , ppr_raStatsLinear)
 
 
 #if i386_TARGET_ARCH
-x86fp_kludge :: NatCmmTop -> NatCmmTop
+x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
 x86fp_kludge top@(CmmData _ _) = top
 x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
        CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
@@ -476,9 +497,8 @@ makeImportsDoc dflags imports
 -- fallthroughs.
 
 sequenceTop 
-       :: Instruction instr
-       => NatCmmTop instr
-       -> NatCmmTop instr
+       :: NatCmmTop Instr
+       -> NatCmmTop Instr
 
 sequenceTop top@(CmmData _ _) = top
 sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
@@ -552,9 +572,8 @@ reorder id accum (b@(block,id',out) : rest)
 -- big, we have to work around this limitation.
 
 makeFarBranches 
-       :: Instruction instr
-       => [NatBasicBlock instr] 
-       -> [NatBasicBlock instr]
+       :: [NatBasicBlock Instr] 
+       -> [NatBasicBlock Instr]
 
 #if powerpc_TARGET_ARCH
 makeFarBranches blocks
@@ -612,10 +631,17 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
   where
     -- find all the blocks that just consist of a jump that can be
     -- shorted.
-    (shortcut_blocks, others) = partitionWith split blocks
-    split (BasicBlock id [insn]) | Just dest <- canShortcut insn 
-                                 = Left (id,dest)
-    split other = Right other
+    -- Don't completely eliminate loops here -- that can leave a dangling jump!
+    (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
+    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
+        | Just (DestBlockId dest) <- canShortcut insn,
+          (elemBlockSet dest s) || dest == id -- loop checks
+        = (s, shortcut_blocks, b : others)
+    split (s, shortcut_blocks, others) (BasicBlock id [insn])
+        | Just dest <- canShortcut insn
+        = (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
+    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+
 
     -- build a mapping from BlockId to JumpDest for shorting branches
     mapping = foldl add emptyUFM shortcut_blocks