Loop problems in native back ends, update to T3286 fix

The native back ends had difficulties with loops;
in particular the code for branch-chain elimination
could run in infinite loops or drop basic blocks.
The old codeGen didn't expose these problems.

Also, my fix for T3286 in the new codegen was getting
applied to too many (some wrong) cases; a better pattern
match fixed that.

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 002e1b2..0c958b3 100644 (file)
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -292,7 +292,7 @@ cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
   -- The Sequel is a type-correct assignment, albeit bogus.
   -- The (dead) continuation loops; it would be better to invoke some kind
   -- of panic function here.
-cgCase scrut@(StgApp v []) bndr _ _ _ 
+cgCase scrut@(StgApp v []) bndr _ (PrimAlt _) _ 
   | not (isUnLiftedType (idType v)) && reps_incompatible
   =
     do { mb_cc <- maybeSaveCostCentre True

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index a99d60a..615cc0c 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -72,6 +72,7 @@ import Reg
 import RegClass
 import NCGMonad
 
+import BlockId
 import Cmm
 import CmmOpt          ( cmmMiniInline, cmmMachOpFold )
 import PprCmm
@@ -630,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

diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 5d731bd..6dc229b 100644 (file)
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -28,6 +28,8 @@ import Outputable
 import Constants       (rESERVED_C_STACK_BYTES)
 
 import CLabel
+import UniqSet
+import Unique
 
 -- Size of a PPC memory address, in bytes.
 --
@@ -799,12 +801,13 @@ data JumpDest = DestBlockId BlockId | DestImm Imm
 
 
 canShortcut :: Instr -> Maybe JumpDest
-canShortcut (JXX ALWAYS id)    = Just (DestBlockId id)
-canShortcut (JMP (OpImm imm))  = Just (DestImm imm)
-canShortcut _                  = Nothing
+canShortcut (JXX ALWAYS id)    = Just (DestBlockId id)
+canShortcut (JMP (OpImm imm))  = Just (DestImm imm)
+canShortcut _                  = Nothing
 
 
--- The helper ensures that we don't follow cycles.
+-- This helper shortcuts a sequence of branches.
+-- The blockset helps avoid following cycles.
 shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
 shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
   where shortcutJump' fn seen insn@(JXX cc id) =
@@ -820,10 +823,10 @@ shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
   | Just uq <- maybeAsmTemp lab 
-  = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq)))
+  = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq)))
 shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
   | Just uq <- maybeAsmTemp lbl1
-  = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off)
+  = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off)
         -- slightly dodgy, we're ignoring the second label, but this
         -- works with the way we use CmmLabelDiffOff for jump tables now.
 
@@ -832,12 +835,14 @@ shortcutStatic _ other_static
 
 shortBlockId 
        :: (BlockId -> Maybe JumpDest)
+       -> UniqSet Unique
        -> BlockId
        -> CLabel
 
-shortBlockId fn blockid@(BlockId uq) =
-   case fn blockid of
-      Nothing -> mkAsmTempLabel uq
-      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
-      Just (DestImm (ImmCLbl lbl)) -> lbl
-      _other -> panic "shortBlockId"
+shortBlockId fn seen blockid@(BlockId uq) =
+  case (elementOfUniqSet uq seen, fn blockid) of
+    (True, _)    -> mkAsmTempLabel uq
+    (_, Nothing) -> mkAsmTempLabel uq
+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
+    (_, Just (DestImm (ImmCLbl lbl))) -> lbl
+    (_, _other) -> panic "shortBlockId"