Set type of function references to function pointers

see #15
llvm-hs · Feb 7, 2018 · 1497273 · 1497273
1 parent e2dec47
commit 1497273
Show file tree

Hide file tree

Showing 5 changed files with 67 additions and 3 deletions.
diff --git a/llvm-hs-quote.cabal b/llvm-hs-quote.cabal
@@ -62,6 +62,7 @@ test-suite test
                       LLVM.Quote.Test.InlineAssembly
                       LLVM.Quote.Test.Instructions
                       LLVM.Quote.Test.Metadata
+                      LLVM.Quote.Test.Module
   build-depends:      base
                     , containers
                     , llvm-hs-pure

diff --git a/src/LLVM/Quote/Parser/Parser.y b/src/LLVM/Quote/Parser/Parser.y
@@ -568,7 +568,7 @@ dialect :
 
 callableOperand :: { [A.Type] -> A.CallableOperand }
 callableOperand :
-    type coperand       { \ts -> Right ($2 (A.FunctionType $1 ts False)) }
+    type coperand       { \ts -> Right ($2 (A.PointerType (A.FunctionType $1 ts False) (A.AddrSpace 0))) }
   | type 'asm' sideeffect alignstack dialect STRING ',' STRING
                        { \ts -> Left (A.InlineAssembly (A.FunctionType $1 ts False) (fromString $6) (fromString $8) $3 $4 $5) }
 

diff --git a/test/LLVM/Quote/Test/Instructions.hs b/test/LLVM/Quote/Test/Instructions.hs
@@ -574,7 +574,7 @@ tests = let a t = LocalReference t . UnName in testGroup "Instructions" [
              tailCallKind = Nothing,
              callingConvention = CC.C,
              returnAttributes = [],
-             function = Right (ConstantOperand (C.GlobalReference (FunctionType void [i32, float, ptr i32, i64, i1, (VectorType 2 i32), (StructureType False [i32, i32])] False) (UnName 0))),
+             function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType void [i32, float, ptr i32, i64, i1, (VectorType 2 i32), (StructureType False [i32, i32])] False)) (UnName 0))),
              arguments = [ (LocalReference i32 (UnName 0), [])
                          , (LocalReference float (UnName 1), [])
                          , (LocalReference (ptr i32) (UnName 2), [])
@@ -762,7 +762,7 @@ tests = let a t = LocalReference t . UnName in testGroup "Instructions" [
               Do $ Invoke {
                callingConvention' = CC.C,
                returnAttributes' = [],
-               function' = Right (ConstantOperand (C.GlobalReference (FunctionType void [i32, i16] False) (UnName 0))),
+               function' = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType void [i32, i16] False)) (UnName 0))),
                arguments' = [
                 (ConstantOperand (C.Int 32 4), []),
                 (ConstantOperand (C.Int 16 8), [])

diff --git a/test/LLVM/Quote/Test/Module.hs b/test/LLVM/Quote/Test/Module.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module LLVM.Quote.Test.Module
+  ( tests
+  )where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import LLVM.Quote.LLVM
+
+import LLVM.AST
+import LLVM.AST.CallingConvention
+import LLVM.AST.Constant
+import LLVM.AST.Global
+import LLVM.AST.Type
+
+tests :: TestTree
+tests = testGroup "Module" [
+  testCase "calls have the proper type" $ do
+    let s = [llmod|
+             define void @f() {
+             entry:
+               call void @g()
+               ret void
+             }
+             define void @g() {
+             entry:
+               ret void
+             }
+            |]
+    let ast = Module "<string>" "<string>" Nothing Nothing
+          [ GlobalDefinition functionDefaults
+              { name = "f"
+              , returnType = void
+              , basicBlocks =
+                  [ BasicBlock
+                      "entry"
+                      [Do
+                         (Call
+                            Nothing
+                            C
+                            []
+                            (Right (ConstantOperand (GlobalReference (ptr (FunctionType void [] False)) (Name "g"))))
+                            []
+                            []
+                            [])
+                      ]
+                      (Do (Ret Nothing []))
+                  ]
+              }
+          , GlobalDefinition functionDefaults
+              { name = "g"
+              , returnType = void
+              , basicBlocks =
+                  [ BasicBlock "entry" [] (Do (Ret Nothing []))
+                  ]
+              }
+          ]
+    s @?= ast
+  ]
diff --git a/test/LLVM/Quote/Test/Tests.hs b/test/LLVM/Quote/Test/Tests.hs
@@ -7,6 +7,7 @@ import qualified LLVM.Quote.Test.DataLayout as DataLayout
 import qualified LLVM.Quote.Test.InlineAssembly as InlineAssembly
 import qualified LLVM.Quote.Test.Instructions as Instructions
 import qualified LLVM.Quote.Test.Metadata as Metadata
+import qualified LLVM.Quote.Test.Module as Module
 
 tests :: TestTree
 tests = testGroup "language-llvm-quote"
@@ -15,4 +16,5 @@ tests = testGroup "language-llvm-quote"
   , InlineAssembly.tests
   , Instructions.tests
   , Metadata.tests
+  , Module.tests
   ]