[commit: ghc] wip/kavon-nosplit-llvm: now properly using cpscall intrinsic. need to update mangler next (5378d06)

[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/5378d06eb75acabd0fec5fe3a72b1dfa7732ec9e/ghc

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

commit 5378d06eb75acabd0fec5fe3a72b1dfa7732ec9e
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Thu Jun 1 16:23:44 2017 +0100

    now properly using cpscall intrinsic. need to update mangler next


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

5378d06eb75acabd0fec5fe3a72b1dfa7732ec9e
 compiler/llvmGen/Llvm/Types.hs          |  7 -----
 compiler/llvmGen/LlvmCodeGen/Base.hs    | 17 +++++++++++-
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 47 ++++++++++++++++++++-------------
 3 files changed, 45 insertions(+), 26 deletions(-)

diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 03c404d..45c68af 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -583,13 +583,6 @@ 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/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index ac49c0c..47db6c4 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -31,7 +31,7 @@ module LlvmCodeGen.Base (
         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
         getGlobalPtr, generateExternDecls,
 
-        aliasify,
+        aliasify, cpsCallOf,
     ) where
 
 #include "HsVersions.h"
@@ -501,6 +501,21 @@ aliasify (LMGlobal var val) = do
            , LMGlobal aliasVar (Just aliasVal)
            ]
 
+cpsCallOf :: LlvmType -> LlvmType
+cpsCallOf givenFn = LMFunction $
+    LlvmFunctionDecl {
+        -- NB skipping type mangling because of current assumptions
+        decName = fsLit "llvm.experimental.cpscall.x",
+        funcLinkage = ExternallyVisible,
+        funcCc = CC_Ghc,
+        decReturnType = getRetTy givenFn,
+        decVarargs = VarArgs,
+        decParams = map noAttr [givenFn, i64, i32, i16],
+        funcAlign = Nothing
+    }
+    where
+        noAttr ty = (ty, [])
+
 -- Note [Llvm Forward References]
 --
 -- The issue here is that LLVM insists on being strongly typed at
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 6353355..4b8d4ae 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -779,8 +779,8 @@ genNativeCall :: Maybe ContInfo -> CmmExpr -> [GlobalReg] -> LlvmM StmtData
 -- Native call to a known Cmm function 
 genNativeCall maybeCont (CmmLit (CmmLabel lbl)) live = do
     (vf, stmts, top) <- getHsFunc live lbl
-    rest <- genNativeCall' maybeCont vf live
-    return (stmts `appOL` rest, top)
+    (rest, top2) <- genNativeCall' maybeCont vf live
+    return (stmts `appOL` rest, top ++ top2)
     
 -- Native call to unknown Cmm function / address.
 genNativeCall maybeCont expr live = do
@@ -796,12 +796,12 @@ genNativeCall maybeCont expr live = do
                      ++ showSDoc dflags (ppr ty) ++ ")"
                      
     (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
-    rest <- genNativeCall' maybeCont v1 live
-    return (stmts `snocOL` s1 `appOL` rest, top)
+    (rest, top2) <- genNativeCall' maybeCont v1 live
+    return (stmts `snocOL` s1 `appOL` rest, top ++ top2)
 
 -- now that we have the function we want to call as an LlvmVar, actually
 -- build the statements needed to do so.
-genNativeCall' :: Maybe ContInfo -> LlvmVar -> [GlobalReg] -> LlvmM LlvmStatements
+genNativeCall' :: Maybe ContInfo -> LlvmVar -> [GlobalReg] -> LlvmM StmtData
 genNativeCall' maybeCont fv live = do
     dflags <- getDynFlags
     (stgRegs, stgStmts) <- funEpilogue live
@@ -811,37 +811,48 @@ genNativeCall' maybeCont fv live = do
         Nothing -> do 
             (retV, s1) <- doExpr retTy $ Call TailCall fv stgRegs llvmStdFunAttrs
             let s2  = Return (Just retV)
-            return (stgStmts `snocOL` s1 `snocOL` s2)
+            return (stgStmts `snocOL` s1 `snocOL` s2, [])
             
         -- non-tail call
         Just contInfo -> do
-            ntCallStms <- mkNonTailCall dflags contInfo retTy fv stgRegs
-            return (stgStmts `appOL` ntCallStms)
+            (ntCallStms, top) <- mkNonTailCall dflags contInfo retTy fv stgRegs
+            return (stgStmts `appOL` ntCallStms, top)
 
 
-mkNonTailCall :: DynFlags -> ContInfo -> LlvmType -> LlvmVar -> [LlvmVar] -> LlvmM LlvmStatements
+mkNonTailCall :: DynFlags -> ContInfo -> LlvmType -> LlvmVar -> [LlvmVar] -> LlvmM StmtData
 mkNonTailCall dflags contInfo retTy vf stgRegs = do
-    let ct = getCallType dflags contInfo
-    (retV, callStm) <- doExpr retTy $ Call ct vf stgRegs llvmStdFunAttrs
+    -- fetch the intrinsic.
+    let cpscallTy @ (LMFunction decl) = cpsCallOf $ getVarType vf
+    (intFun, intStm, top) <- getInstrinct2 (decName decl) cpscallTy
+    
+    -- collect the args to the intrinsic
+    let consts = cpsCallConsts dflags contInfo
+        args = vf : consts ++ stgRegs
+    
+    (retV, callStm) <- doExpr retTy $ Call StdCall intFun args llvmStdFunAttrs
     endStms <- doReturnTo contInfo retV
-    return $ callStm `consOL` endStms
+    return (intStm `snocOL` callStm `appOL` endStms, top)
     
             
-getCallType :: DynFlags -> ContInfo -> LlvmCallType
-getCallType dflags (retl, argOff, _) = let
+cpsCallConsts :: DynFlags -> ContInfo -> [LlvmVar]
+cpsCallConsts dflags (retl, argOff, _) = let
         -- mangler will look for this unique number
-        info64 = fromIntegral $ getKey $ getUnique retl
+        info64 = toInteger $ getKey $ getUnique retl
         
         -- offset into the Sp where the return address should be written
         wordBytes = widthInBytes $ wordWidth dflags
-        ra32 = fromIntegral $ argOff - wordBytes
+        ra32 = toInteger $ argOff - wordBytes
         
         -- get argument number of Sp in our calling convention
         allRegs = activeStgRegs $ targetPlatform dflags
         Just spArgnum = elemIndex Sp allRegs
-        argnum16 = fromIntegral spArgnum
+        argnum16 = toInteger spArgnum
+        
+        mk ty val = LMLitVar $ LMIntLit val ty
     in
-        CPSCall {info_id = info64, ra_off = ra32, sp_argnum = argnum16}
+        [mk i64 info64,
+         mk i32 ra32,
+         mk i16 argnum16]