[commit: ghc] wip/kavon-nosplit-llvm: changing funTy so that it returns something. for now it's just a float (ec29bf7)

[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/ec29bf7e60a5b5f54fcdb5d21a341ca00118eeb3/ghc

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

commit ec29bf7e60a5b5f54fcdb5d21a341ca00118eeb3
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Mon May 15 15:43:17 2017 +0100

    changing funTy so that it returns something. for now it's just a float


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

ec29bf7e60a5b5f54fcdb5d21a341ca00118eeb3
 compiler/llvmGen/Llvm.hs                |  3 +--
 compiler/llvmGen/Llvm/Types.hs          |  6 +++++
 compiler/llvmGen/LlvmCodeGen/Base.hs    |  3 ++-
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 43 +++++++++++++++++++++------------
 4 files changed, 36 insertions(+), 19 deletions(-)

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 8104a3a..796c5fc 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -45,7 +45,7 @@ module Llvm (
         MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
 
         -- ** Operations on the type system.
-        isGlobal, getLitType, getVarType,
+        isGlobal, getLitType, getVarType, getRetTy,
         getLink, getStatType, pVarLift, pVarLower,
         pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
 
@@ -61,4 +61,3 @@ import Llvm.AbsSyn
 import Llvm.MetaData
 import Llvm.PpLlvm
 import Llvm.Types
-
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index bf23cd8..6245642 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -267,6 +267,12 @@ getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))
 getLitType (LMNullLit    t) = t
 getLitType (LMUndefLit   t) = t
 
+-- | Return the return type of the given function or function pointer type
+getRetTy :: LlvmType -> LlvmType
+getRetTy (LMFunction(LlvmFunctionDecl{decReturnType = t})) = t
+getRetTy (LMPointer(LMFunction(LlvmFunctionDecl{decReturnType = t}))) = t
+getRetTy _ = panic "getRetTy -- not a function or function pointer!"
+
 -- | Return the 'LlvmType' of the 'LlvmStatic'
 getStatType :: LlvmStatic -> LlvmType
 getStatType (LMStaticLit   l  ) = getLitType l
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 424891f..8b01da8 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -124,7 +124,8 @@ llvmFunSig' live lbl link
   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                       | otherwise   = (x, [])
        dflags <- getDynFlags
-       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+       let retTy = LMFloat -- TODO: generate the struct that we will return.
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) retTy FixedArgs
                                  (map (toParams . getVarType) (llvmFunArgs dflags live))
                                  (llvmFunAlign dflags)
 
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 43690e9..97042a6 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -126,12 +126,18 @@ stmtToInstrs stmt = case stmt of
     CmmUnsafeForeignCall target res args
         -> genCall target res args
 
-    -- Cmm call
+    -- Cmm tail call
     CmmCall { cml_target = arg,
               cml_args_regs = live,
-              cml_cont = maybeCont } -> case maybeCont of
-                Nothing -> genJump arg live -- Tail call
-                Just cont -> panic "todo: handle non-tail CmmCall"
+              cml_cont = Nothing } -> 
+                genNativeCall Nothing arg live
+                
+    -- Cmm non-tail call
+    CmmCall { cml_target = arg,
+              cml_args_regs = live,
+              cml_cont = Just cont,
+              cml_args = argOffset } -> 
+                genNativeCall (Just (cont, argOffset)) arg live
 
     _ -> panic "Llvm.CodeGen.stmtToInstrs"
 
@@ -761,20 +767,24 @@ cmmPrimOpFunctions mop = do
     MO_AtomicWrite _ -> unsupported
     MO_Cmpxchg _     -> unsupported
 
--- | Tail function calls
-genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
+-- | Native function calls. First arg indicates whether there is a continuation.
+genNativeCall :: Maybe (Label, Int) -> CmmExpr -> [GlobalReg] -> LlvmM StmtData
 
--- Call to known function
-genJump (CmmLit (CmmLabel lbl)) live = do
+-- Native call to a known function
+genNativeCall maybeCont (CmmLit (CmmLabel lbl)) live = do
     (vf, stmts, top) <- getHsFunc live lbl
     (stgRegs, stgStmts) <- funEpilogue live
-    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
-    let s2  = Return Nothing
-    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+    let retTy = getRetTy $ getVarType vf
+    case maybeCont of
+        _ -> do -- native tail call
+            (retV, s1) <- doExpr retTy $ Call TailCall vf stgRegs llvmStdFunAttrs
+            let s2  = Return (Just retV)
+            return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
         
+        -- Just (cont, offset) -> panic "kavon, handle non-tail known calls."
     
--- Call to unknown function / address
-genJump expr live = do
+-- Tail call to unknown function / address. TODO: check if the expr is P64[Sp] to gen a ret.
+genNativeCall _ expr live = do
     fty <- llvmFunTy live
     (vf, stmts, top) <- exprToVar expr
     dflags <- getDynFlags
@@ -783,13 +793,14 @@ genJump expr live = do
          ty | isPointer ty -> LM_Bitcast
          ty | isInt ty     -> LM_Inttoptr
 
-         ty -> panic $ "genJump: Expr is of bad type for function call! ("
+         ty -> panic $ "genNativeCall: Expr is of bad type for function call! ("
                      ++ showSDoc dflags (ppr ty) ++ ")"
 
     (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
     (stgRegs, stgStmts) <- funEpilogue live
-    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
-    let s3 = Return Nothing
+    let retTy = getRetTy fty
+    (retV, s2) <- doExpr retTy $ Call TailCall v1 stgRegs llvmStdFunAttrs
+    let s3 = Return (Just retV)
     return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
             top)