[commit: ghc] wip/kavon-nosplit-llvm: adding support for rewriting labels in the LLVM Mangler (584ad81)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/kavon-nosplit-llvm
Link       : http://ghc.haskell.org/trac/ghc/changeset/584ad81133bd684d4a0e3b0eef3ec4eb09da6611/ghc

>---------------------------------------------------------------

commit 584ad81133bd684d4a0e3b0eef3ec4eb09da6611
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Tue Jun 6 16:48:13 2017 +0100

    adding support for rewriting labels in the LLVM Mangler


>---------------------------------------------------------------

584ad81133bd684d4a0e3b0eef3ec4eb09da6611
 compiler/llvmGen/LlvmMangler.hs | 38 ++++++++++++++++++++++++--------------
 1 file changed, 24 insertions(+), 14 deletions(-)

diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index f9b41a5..ed38202 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -23,6 +23,7 @@ import Cmm
 import Compiler.Hoopl
 import Compiler.Hoopl.Internals ( uniqueToLbl )
 import Data.List ( intersperse )
+import Data.Maybe ( fromMaybe )
 
 -- | Read in assembly file and process
 llvmFixupAsm :: DynFlags -> LabelMap CmmStatics -> FilePath -> FilePath -> IO ()
@@ -34,17 +35,23 @@ llvmFixupAsm dflags gcInfo f1 f2 = {-# SCC "llvm_mangler" #-}
         hClose w
         return ()
   where
+    doRewrite a = rewriteLine dflags (labRewrites gcInfo) rewrites a
+    
     go :: Handle -> Handle -> IO ()
     go r w = do
       e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
-      let writeline a = B.hPutStrLn w (rewriteLine dflags (rewrites gcInfo) a) >> go r w
+      let writeline a = B.hPutStrLn w (doRewrite a) >> go r w
       case e_l of
         Right l -> writeline l
         Left _  -> return ()
 
--- | These are the rewrites that the mangler will perform
-rewrites :: LabelMap CmmStatics -> [Rewrite]
-rewrites info = [addInfoTable info] -- TODO(kavon): reenable [rewriteSymType, rewriteAVX, addInfoTable info]
+-- | These are the non-label rewrites that the mangler will perform
+rewrites :: [Rewrite]
+rewrites = [rewriteSymType, rewriteAVX]
+
+-- | These are the label-based rewrites that the mangler will perform
+labRewrites :: LabelMap CmmStatics -> [Rewrite]
+labRewrites info = [addInfoTable info]
 
 type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
 
@@ -97,21 +104,24 @@ addInfoTable info _ line = do
         szName _ = error "szName -- invalid byte width"
             
 
-
-    
-
 -- | Rewrite a line of assembly source with the given rewrites,
--- taking the first rewrite that applies.
-rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
-rewriteLine dflags rewrites l =
-    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
-      Nothing        -> l
-      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
+-- taking the first rewrite that applies for each kind of rewrite (label and non-label).
+rewriteLine :: DynFlags -> [Rewrite] -> [Rewrite] -> B.ByteString -> B.ByteString
+rewriteLine dflags labRewrites rewrites l =
+    case (maybNewSym, maybNewRest) of
+        (Nothing, Nothing) -> l -- avoid concat
+        (newS, newR)       -> cat (fromMaybe symbol newS) (fromMaybe rest newR)
   where
+    cat sym rst = B.concat $ [sym, B.pack "\t", rst]
+    
+    findRwOf txt rws = firstJust $ map (\rw -> rw dflags txt) rws
+    
     (symbol, rest) = splitLine l
+    maybNewSym = findRwOf symbol labRewrites  -- check for new label part
+    maybNewRest = findRwOf rest rewrites      -- check for new non-label part
 
     firstJust :: [Maybe a] -> Maybe a
-    firstJust (Just x:_) = Just x
+    firstJust (jx@(Just _):_) = jx
     firstJust []         = Nothing
     firstJust (_:rest)   = firstJust rest