LlvmCodeGen: Fix generation of malformed LLVM blocks
authorErik de Castro Lopo <erikd@mega-nerd.com>
Sat, 12 Mar 2016 11:03:56 +0000 (12:03 +0100)
committerBen Gamari <ben@smart-cactus.org>
Sat, 12 Mar 2016 11:03:56 +0000 (12:03 +0100)
Commit 673efccb3b uncovered a bug in LLVM code generation that produced
LLVM code that the LLVM compiler refused to compile:

    {
    clpH:
      br label %clpH
    }

This may well be a bug in LLVM itself. The solution is to keep the
existing entry label and rewrite the function as:

    {
    clpH:
      br label %nPV
    nPV:
      br label %nPV
    }

Thanks to Ben Gamari for pointing me in the right direction on this
one.

Test Plan: Build GHC with BuildFlavour=quick-llvm

Reviewers: hvr, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1996

GHC Trac Issues: #11649

compiler/llvmGen/LlvmCodeGen.hs
testsuite/tests/llvm/should_compile/T11649.hs [new file with mode: 0644]
testsuite/tests/llvm/should_compile/all.T

index 3c63aa0..872ad8c 100644 (file)
@@ -15,8 +15,10 @@ import LlvmCodeGen.Ppr
 import LlvmCodeGen.Regs
 import LlvmMangler
 
+import BlockId
 import CgUtils ( fixStgRegisters )
 import Cmm
+import CmmUtils
 import Hoopl
 import PprCmm
 
@@ -120,13 +122,43 @@ cmmDataLlvmGens statics
 
        renderLlvm $ pprLlvmData (concat gss', concat tss)
 
+-- | LLVM can't handle entry blocks which loop back to themselves (could be
+-- seen as an LLVM bug) so we rearrange the code to keep the original entry
+-- label which branches to a newly generated second label that branches back
+-- to itself. See: Trac #11649
+fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
+fixBottom cp@(CmmProc hdr entry_lbl live g) =
+    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
+  where
+    blk_map = toBlockMap g
+
+    fix_block :: CmmBlock -> LlvmM RawCmmDecl
+    fix_block blk
+        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
+        , isEmptyBlock middle
+        , e_lbl == b_lbl = do
+            new_lbl <- mkBlockId <$> getUniqueM
+
+            let fst_blk =
+                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
+                snd_blk =
+                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
+
+            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
+                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
+
+    fix_block _ = pure cp
+
+fixBottom rcd = pure rcd
+
 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
 cmmLlvmGen cmm@CmmProc{} = do
 
     -- rewrite assignments to global regs
     dflags <- getDynFlag id
-    let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
+    fixed_cmm <- fixBottom $
+                    {-# SCC "llvm_fix_regs" #-}
                     fixStgRegisters dflags cmm
 
     dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
diff --git a/testsuite/tests/llvm/should_compile/T11649.hs b/testsuite/tests/llvm/should_compile/T11649.hs
new file mode 100644 (file)
index 0000000..9d09c3a
--- /dev/null
@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Test where
+import GHC.Base
+
+data U1 p = U1
+
+instance Functor U1 where
+    fmap f U1 = U1
+
+instance Applicative U1 where
+    pure _ = U1
+    U1 <*> U1 = U1
+
+instance Alternative U1 where
+    empty = U1
+    U1 <|> U1 = U1
index 9da136d..6806c25 100644 (file)
@@ -13,3 +13,4 @@ test('T6158', [reqlib('vector'), reqlib('primitive')], compile, ['-package vecto
 test('T7571', cmm_src, compile, [''])
 test('T7575', unless(wordsize(32), skip), compile, [''])
 test('T8131b', normal, compile, [''])
+test('T11649', normal, compile, [''])