[commit: ghc] wip/kavon-nosplit-llvm: corresponding updates to mangler for stack-align issue (0a00225)

[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/0a0022517a189810d5904873151ffbc1964cc268/ghc

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

commit 0a0022517a189810d5904873151ffbc1964cc268
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Sat Jun 17 19:08:46 2017 +0100

    corresponding updates to mangler for stack-align issue


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

0a0022517a189810d5904873151ffbc1964cc268
 compiler/llvmGen/LlvmCodeGen/Base.hs |  2 +-
 compiler/llvmGen/LlvmMangler.hs      | 50 ++++++++++++++++++++++--------------
 2 files changed, 32 insertions(+), 20 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 01e0191..943d08d 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -190,7 +190,7 @@ llvmStdFunAttrs = [NoUnwind]
 
 -- | Llvm standard function definition attributes
 llvmStdFunDefAttrs :: [LlvmFuncAttr]
-llvmStdFunDefAttrs = [NoUnwind, Naked]
+llvmStdFunDefAttrs = [NoUnwind]
 
 -- | Convert a list of types to a list of function parameters
 -- (each with no parameter attributes)
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 27f4a1f..ee7b110 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -43,19 +43,20 @@ llvmFixupAsm :: DynFlags -> LabelMap ManglerStr -> FilePath -> FilePath -> IO ()
 llvmFixupAsm dflags gcInfo f1 f2 = {-# SCC "llvm_mangler" #-}
     withTiming (pure dflags) (text "LLVM Mangler") id $
     withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
-        go r w
+        go r w []
         hClose r
         hClose w
         return ()
   where
-    doRewrite a = rewriteLine dflags (labRewrites gcInfo) rewrites a
+    doRewrite x = rewriteLine dflags (labRewrites gcInfo) rewrites x
     
-    go :: Handle -> Handle -> IO ()
-    go r w = do
+    go :: Handle -> Handle -> [Line] -> IO ()
+    go r w pL = do
       e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
-      let writeline a = B.hPutStrLn w (doRewrite a) >> go r w
+      let writeline x = B.hPutStrLn w newL >> go r w newPL
+            where (newPL, newL) = doRewrite x
       case e_l of
-        Right l -> writeline l
+        Right l -> writeline (pL, l)
         Left _  -> return ()
 
 -- | These are the non-label rewrites that the mangler will perform
@@ -63,10 +64,12 @@ rewrites :: [Rewrite]
 rewrites = [rewriteSymType, rewriteAVX]
 
 -- | These are the label-based rewrites that the mangler will perform
-labRewrites :: LabelMap ManglerStr -> [Rewrite]
+labRewrites :: LabelMap ManglerStr -> [LabRewrite]
 labRewrites info = [addInfoTable info]
 
-type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
+type Line = B.ByteString
+type Rewrite = DynFlags -> Line -> Maybe Line
+type LabRewrite = DynFlags -> ([Line], Line) -> Maybe Line
 
 -- XXX(kavon): debug only delete me later
 withComment :: String -> B.ByteString -> B.ByteString
@@ -76,13 +79,13 @@ withComment com line = B.concat [B.pack $ wrap com, line]
 
 -- | This rewrite looks for return points of a llvm.cpscall and adds GC info
 -- above that label.
-addInfoTable :: LabelMap ManglerStr -> Rewrite
-addInfoTable info _ line = do
+addInfoTable :: LabelMap ManglerStr -> LabRewrite
+addInfoTable info _ (prevLabs, line) = do
         retPt <- B.stripPrefix labPrefix line
         (i, _) <- B.readInt retPt
         statics <- mapLookup (toKey i) info
         fullName <- B.stripSuffix colon line
-        return $ B.concat $ (map (\f -> f fullName) statics) ++ [line]
+        return $ B.concat $ (map (\f -> f fullName) statics) ++ prevLabs ++ [line]
     where
         -- TODO(kavon): check if prefix changes on different platforms.
         labPrefix = B.pack "L" 
@@ -91,19 +94,28 @@ addInfoTable info _ line = do
         
 -- | Rewrite a line of assembly source with the given rewrites,
 -- 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)
+rewriteLine :: DynFlags -> [LabRewrite] -> [Rewrite] -> ([Line], Line) -> ([Line], Line)
+rewriteLine dflags labRewrites rewrites (prevLabs, l) =
+    case (maybNewSym, maybNewRest, B.null rest) of
+        -- untouched line only has a label, collect it and emit nothing
+        (Nothing, Nothing, True) -> (l : prevLabs, B.empty) 
+        -- a lab rewrite occurred, consuming the prevLabs in its result
+        (Just s, newR, _)        -> ([], smush s (fromMaybe rest newR))
+        -- the line did not only contain a label, and a label rewrite
+        -- hasn't occured, so we emit all collected labels
+        (Nothing, newR, _)       -> ([], smush allLabs (fromMaybe rest newR))
+            where
+                allLabs = revCat $ symbol : prevLabs
   where
-    cat sym rst = B.concat $ [sym, B.pack "\t", rst]
+    smush sym rst = B.concat $ [sym, B.pack "\t", rst]
+    
+    revCat ls = B.concat $ reverse ls
     
     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
+    maybNewSym = findRwOf (prevLabs, symbol) labRewrites  -- check for new label part
+    maybNewRest = findRwOf rest rewrites                  -- check for new non-label part
 
     firstJust :: [Maybe a] -> Maybe a
     firstJust (jx@(Just _):_) = jx