[commit: ghc] wip/kavon-nosplit-llvm: need to add ppr support for CPSCall (1ae76b5)

[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/1ae76b5a3c829ccb8384eba57936df38cf00eb8d/ghc

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

commit 1ae76b5a3c829ccb8384eba57936df38cf00eb8d
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Wed May 31 15:37:50 2017 +0100

    need to add ppr support for CPSCall


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

1ae76b5a3c829ccb8384eba57936df38cf00eb8d
 compiler/llvmGen/Llvm/Types.hs          |  7 +++++++
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 28 ++++++++++++++--------------
 2 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index a84446c..8e04ed7 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -583,6 +583,13 @@ data LlvmCallType
   = StdCall
   -- | Tail call, perform the call in the current stack frame.
   | TailCall
+  -- | A non-tail call in continuation-passing style,
+  -- which is described with the intrinsic @llvm.experimental.cpscall
+  | CPSCall {
+        info_id :: Int64,    -- an ID used by the mangler 
+        ra_off :: Int32,     -- byte offset from Sp for the return address
+        sp_argnum :: Int16   -- indicates the Sp arg passed to callee
+    }
   deriving (Eq,Show)
 
 -- | Different calling conventions a function can use.
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 16add51..6353355 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -38,7 +38,7 @@ import Control.Monad.Trans.Writer
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 #endif
-import Data.List ( nub )
+import Data.List ( nub, elemIndex )
 import Data.Maybe ( catMaybes )
 import Control.Monad ( foldM )
 
@@ -821,27 +821,27 @@ genNativeCall' maybeCont fv live = do
 
 mkNonTailCall :: DynFlags -> ContInfo -> LlvmType -> LlvmVar -> [LlvmVar] -> LlvmM LlvmStatements
 mkNonTailCall dflags contInfo retTy vf stgRegs = do
-    (retV, callStm) <- doExpr retTy $ Call StdCall vf stgRegs llvmStdFunAttrs
-    let s1 = withReturnMeta dflags contInfo callStm
+    let ct = getCallType dflags contInfo
+    (retV, callStm) <- doExpr retTy $ Call ct vf stgRegs llvmStdFunAttrs
     endStms <- doReturnTo contInfo retV
-    return $ s1 `consOL` endStms
+    return $ callStm `consOL` endStms
     
-cps_retpt :: LMString
-cps_retpt = fsLit "cps.retpt" 
             
-withReturnMeta :: DynFlags -> ContInfo -> LlvmStatement -> LlvmStatement
-withReturnMeta dflags (retl, argOff, _) stm = let 
-        -- TODO some unique name for the mangler corresponding to retl
-        name = MetaStr $ fsLit "todo"
+getCallType :: DynFlags -> ContInfo -> LlvmCallType
+getCallType dflags (retl, argOff, _) = let
+        -- mangler will look for this unique number
+        info64 = fromIntegral $ getKey $ getUnique retl
         
         -- offset into the Sp where the return address should be written
         wordBytes = widthInBytes $ wordWidth dflags
-        offInt = argOff - wordBytes
-        off = MetaStr $ mkFastString $ show offInt
+        ra32 = fromIntegral $ argOff - wordBytes
         
-        expr = MetaStruct [name, off]
+        -- get argument number of Sp in our calling convention
+        allRegs = activeStgRegs $ targetPlatform dflags
+        Just spArgnum = elemIndex Sp allRegs
+        argnum16 = fromIntegral spArgnum
     in
-        MetaStmt [MetaAnnot cps_retpt expr] stm
+        CPSCall {info_id = info64, ra_off = ra32, sp_argnum = argnum16}