PPC NCG: Add DWARF constants and debug labels

Fixes #11261

10 files changed, 65 insertions, 41 deletions

diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
index 16bdded699..29592c106e 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
@@ -12,6 +12,7 @@ import Outputable
 
 import GHC.Platform.Reg
 import GHC.CmmToAsm.X86.Regs
+import GHC.CmmToAsm.PPC.Regs (toRegNo)
 
 import Data.Word
 
@@ -215,6 +216,7 @@ dwarfRegNo p r = case platformArch p of
     | r == xmm13 -> 30
     | r == xmm14 -> 31
     | r == xmm15 -> 32
+  ArchPPC_64 _ -> fromIntegral $ toRegNo r
   _other -> error "dwarfRegNo: Unsupported platform or unknown register!"
 
 -- | Virtual register number to use for return address.
@@ -226,4 +228,5 @@ dwarfReturnRegNo p
   = case platformArch p of
     ArchX86    -> 8  -- eip
     ArchX86_64 -> 16 -- rip
+    ArchPPC_64 ELF_V2 -> 65 -- lr (link register)
     _other     -> error "dwarfReturnRegNo: Unsupported platform!"
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 90b670c9b0..16557dba71 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -30,10 +30,13 @@ import GHC.CmmToAsm.PPC.Instr
 import GHC.CmmToAsm.PPC.Cond
 import GHC.CmmToAsm.PPC.Regs
 import GHC.CmmToAsm.CPrim
+import GHC.Cmm.DebugBlock
+   ( DebugBlock(..) )
 import GHC.CmmToAsm.Monad
    ( NatM, getNewRegNat, getNewLabelNat
    , getBlockIdNat, getPicBaseNat, getNewRegPairNat
    , getPicBaseMaybeNat, getPlatform, getConfig
+   , getDebugBlock, getFileId
    )
 import GHC.CmmToAsm.Instr
 import GHC.CmmToAsm.PIC
@@ -53,6 +56,8 @@ import GHC.Cmm.Switch
 import GHC.Cmm.CLabel
 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
+import GHC.Core              ( Tickish(..) )
+import GHC.Types.SrcLoc      ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
 
 -- The rest:
 import OrdList
@@ -123,9 +128,17 @@ basicBlockCodeGen block = do
   let (_, nodes, tail)  = blockSplit block
       id = entryLabel block
       stmts = blockToList nodes
+  -- Generate location directive
+  dbg <- getDebugBlock (entryLabel block)
+  loc_instrs <- case dblSourceTick =<< dbg of
+    Just (SourceNote span name)
+      -> do fileid <- getFileId (srcSpanFile span)
+            let line = srcSpanStartLine span; col =srcSpanStartCol span
+            return $ unitOL $ LOCATION fileid line col name
+    _ -> return nilOL
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail
-  let instrs = mid_instrs `appOL` tail_instrs
+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs
index e622d801a8..674b19ef93 100644
--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs
@@ -187,6 +187,9 @@ data Instr
     -- comment pseudo-op
     = COMMENT FastString
 
+    -- location pseudo-op (file, line, col, name)
+    | LOCATION Int Int Int String
+
     -- some static data spat out during code
     -- generation.  Will be extracted before
     -- pretty-printing.
@@ -643,6 +646,7 @@ ppc_isMetaInstr
 ppc_isMetaInstr instr
  = case instr of
     COMMENT{}   -> True
+    LOCATION{}  -> True
     LDATA{}     -> True
     NEWBLOCK{}  -> True
     DELTA{}     -> True
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index b4b9ee804e..15e72bbb49 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -59,14 +59,17 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
             ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl
             _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
                                            -- so label needed
-         vcat (map (pprBasicBlock platform top_info) blocks)
+         vcat (map (pprBasicBlock config top_info) blocks) $$
+         (if ncgDebugLevel config > 0
+          then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+         pprSizeDecl platform lbl
 
     Just (CmmStaticsRaw info_lbl _) ->
       pprSectionAlign config (Section Text info_lbl) $$
       (if platformHasSubsectionsViaSymbols platform
           then ppr (mkDeadStripPreventer info_lbl) <> char ':'
           else empty) $$
-      vcat (map (pprBasicBlock platform top_info) blocks) $$
+      vcat (map (pprBasicBlock config top_info) blocks) $$
       -- above: Even the first block gets a label, because with branch-chain
       -- elimination, it might be the target of a goto.
       (if platformHasSubsectionsViaSymbols platform
@@ -76,7 +79,15 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
             <+> ppr info_lbl
             <+> char '-'
             <+> ppr (mkDeadStripPreventer info_lbl)
-       else empty)
+       else empty) $$
+      pprSizeDecl platform info_lbl
+
+-- | Output the ELF .size directive.
+pprSizeDecl :: Platform -> CLabel -> SDoc
+pprSizeDecl platform lbl
+ = if osElfTarget (platformOS platform)
+   then text "\t.size" <+> ppr lbl <> text ", .-" <> ppr lbl
+   else empty
 
 pprFunctionDescriptor :: CLabel -> SDoc
 pprFunctionDescriptor lab = pprGloblDecl lab
@@ -105,12 +116,19 @@ pprFunctionPrologue lab =  pprGloblDecl lab
                         $$ text "\t.localentry\t" <> ppr lab
                         <> text ",.-" <> ppr lab
 
-pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc
-pprBasicBlock platform info_env (BasicBlock blockid instrs)
+pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
+              -> SDoc
+pprBasicBlock config info_env (BasicBlock blockid instrs)
   = maybe_infotable $$
-    pprLabel platform (blockLbl blockid) $$
-    vcat (map (pprInstr platform) instrs)
+    pprLabel platform asmLbl $$
+    vcat (map (pprInstr platform) instrs) $$
+    (if  ncgDebugLevel config > 0
+      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
+      else empty
+    )
   where
+    asmLbl = blockLbl blockid
+    platform = ncgPlatform config
     maybe_infotable = case mapLookup blockid info_env of
        Nothing   -> empty
        Just (CmmStaticsRaw info_lbl info) ->
@@ -338,6 +356,9 @@ pprInstr platform instr = case instr of
    --          then text "# " <> ftext s
    --          else text "; " <> ftext s
 
+   LOCATION file line col _name
+      -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col
+
    DELTA d
       -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 
diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs
index 86675daf5f..b37fb400fc 100644
--- a/compiler/GHC/CmmToAsm/PPC/Regs.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs
@@ -31,6 +31,7 @@ module GHC.CmmToAsm.PPC.Regs (
         allMachRegNos,
         classOfRealReg,
         showReg,
+        toRegNo,
 
         -- machine specific
         allFPArgRegs,
@@ -250,7 +251,9 @@ showReg n
     | n >= 32 && n <= 63  = "%f" ++ show (n - 32)
     | otherwise           = "%unknown_powerpc_real_reg_" ++ show n
 
-
+toRegNo :: Reg -> RegNo
+toRegNo (RegReal (RealRegSingle n)) = n
+toRegNo _                           = panic "PPC.toRegNo: unsupported register"
 
 -- machine specific ------------------------------------------------------------
 
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index cffe3d9769..ce76ed388a 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -25,19 +25,14 @@ test('T9155', normal, compile, ['-O2'])
 test('T9303', normal, compile, ['-O2'])
 test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, [''])
 
-test('debug',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
-     makefile_test, [])
+test('debug', normal, makefile_test, [])
 test('T9964', normal, compile, ['-O'])
 test('T10518', [cmm_src], compile, [''])
-test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
-                      expect_broken(11261))],
-     compile, ['-g'])
+test('T10667', normal, compile, ['-g'])
 test('T12115', normal, compile, [''])
 test('T12355', normal, compile, [''])
 test('T14999',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261)),
-      when(unregisterised(), skip),
+     [when(unregisterised(), skip),
       unless(opsys('linux') and arch('x86_64') and have_gdb() and
         have_readelf(), skip)],
      makefile_test, [])
diff --git a/testsuite/tests/driver/T17586/all.T b/testsuite/tests/driver/T17586/all.T
index 3912ef34db..2ec89b4d03 100644
--- a/testsuite/tests/driver/T17586/all.T
+++ b/testsuite/tests/driver/T17586/all.T
@@ -1,3 +1 @@
-test('T17586',
-     [when(arch('powerpc64') or arch('powerpc64le'), expect_broken(11261))],
-     makefile_test, [])
+test('T17586', normal, makefile_test, [])
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index ca0e652a48..61e525b938 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -385,10 +385,10 @@ test('keep-cafs-fail',
   [ extra_files(['KeepCafsBase.hs', 'KeepCafs1.hs',
                  'KeepCafs2.hs', 'KeepCafsMain.hs']),
     when(opsys('mingw32'), expect_broken (5987)),
-    when(platform('powerpc64le-unknown-linux'), expect_broken(11261)),
     when(opsys('freebsd'), expect_broken(16035)),
     filter_stdout_lines('Evaluated a CAF|exit.*'),
     ignore_stderr, # on OS X the shell emits an "Abort trap" message to stderr
+    req_rts_linker,
   ],
   makefile_test, ['KeepCafsFail'])
 
@@ -397,7 +397,6 @@ test('keep-cafs',
   [ extra_files(['KeepCafsBase.hs', 'KeepCafs1.hs',
                  'KeepCafs2.hs', 'KeepCafsMain.hs']),
     when(opsys('mingw32'), expect_broken (5987)),
-    when(platform('powerpc64le-unknown-linux'), expect_broken(11261)),
     when(opsys('freebsd'), expect_broken(16035)),
     req_rts_linker
   ],
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 396111fb4b..875e0b5b66 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -244,21 +244,11 @@ test('T13468',
      normal,
      makefile_test, ['T13468'])
 test('T13543', only_ways(['optasm']), compile, ['-ddump-str-signatures -ddump-cpr-signatures'])
-test('T11272',
-     normal,
-     makefile_test, ['T11272'])
-test('T12600',
-     normal,
-     makefile_test, ['T12600'])
-test('T13658',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
-     compile, ['-dcore-lint'])
-test('T14779a',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
-     compile, ['-dcore-lint'])
-test('T14779b',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
-     compile, ['-dcore-lint'])
+test('T11272', normal, makefile_test, ['T11272'])
+test('T12600', normal, makefile_test, ['T12600'])
+test('T13658', normal, compile, ['-dcore-lint'])
+test('T14779a', normal, compile, ['-dcore-lint'])
+test('T14779b', normal, compile, ['-dcore-lint'])
 test('T13708', normal, compile, [''])
 
 # thunk should inline here, so check whether or not it appears in the Core
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 210949d9c6..d730632345 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -81,10 +81,8 @@ test('T13429_2', normal, compile_and_run, [''])
 test('T13750', normal, compile_and_run, [''])
 test('T14178', normal, compile_and_run, [''])
 test('T14768', reqlib('vector'), compile_and_run, [''])
-test('T14868',
-     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
-     compile_and_run, [''])
-test('T14894', [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))], compile_and_run, [''])
+test('T14868', normal, compile_and_run, [''])
+test('T14894', normal, compile_and_run, [''])
 test('T14965', normal, compile_and_run, [''])
 test('T15114', only_ways(['optasm']), compile_and_run, [''])
 test('T15436', normal, compile_and_run, [''])