diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.3.9.1 +version: 3.3.10.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -16,7 +16,7 @@ handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. . - For haddock, see . + For haddock, see . extra-source-files: src/LLVM/General/Internal/FFI/Analysis.h src/LLVM/General/Internal/FFI/Constant.h @@ -38,7 +38,7 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.3 - tag: v3.3.9.1 + tag: v3.3.10.0 flag shared-llvm description: link against llvm shared rather than static library @@ -62,7 +62,7 @@ parsec >= 3.1.3, array >= 0.4.0.0, setenv >= 0.1.0, - llvm-general-pure == 3.3.9.1 + llvm-general-pure == 3.3.10.0 extra-libraries: stdc++ hs-source-dirs: src extensions: @@ -194,8 +194,8 @@ HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1, - llvm-general == 3.3.9.1, - llvm-general-pure == 3.3.9.1, + llvm-general == 3.3.10.0, + llvm-general-pure == 3.3.10.0, containers >= 0.4.2.1, mtl >= 2.0.1.0 hs-source-dirs: test diff --git a/src/LLVM/General/Internal/Constant.hs b/src/LLVM/General/Internal/Constant.hs --- a/src/LLVM/General/Internal/Constant.hs +++ b/src/LLVM/General/Internal/Constant.hs @@ -26,6 +26,7 @@ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.FFI.LLVMCTypes (valueSubclassIdP) import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.General.Internal.FFI.Type as FFI import qualified LLVM.General.Internal.FFI.User as FFI import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.Internal.FFI.BinaryOperator as FFI @@ -92,11 +93,16 @@ f' <- referGlobal f b' <- getBlockForAddress f b liftIO $ FFI.blockAddress (FFI.upCast f') b' - A.C.Struct p ms -> do - Context context <- gets encodeStateContext + A.C.Struct nm p ms -> do p <- encodeM p ms <- encodeM ms - liftIO $ FFI.constStructInContext context ms p + case nm of + Nothing -> do + Context context <- gets encodeStateContext + liftIO $ FFI.constStructInContext context ms p + Just nm -> do + t <- lookupNamedType nm + liftIO $ FFI.constNamedStruct t ms o -> $(do let constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) TH.caseE [| o |] $ do @@ -127,7 +133,8 @@ decodeM c = scopeAnyCont $ do let v = FFI.upCast c :: Ptr FFI.Value u = FFI.upCast c :: Ptr FFI.User - t <- decodeM =<< liftIO (FFI.typeOf v) + ft <- liftIO (FFI.typeOf v) + t <- decodeM ft valueSubclassId <- liftIO $ FFI.getValueSubclassId v nOps <- liftIO $ FFI.getNumOperands u let globalRef = return A.C.GlobalReference `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) @@ -171,8 +178,11 @@ return A.C.BlockAddress `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c) - [valueSubclassIdP|ConstantStruct|] -> - return A.C.Struct `ap` (return $ A.isPacked t) `ap` getConstantOperands + [valueSubclassIdP|ConstantStruct|] -> do + return A.C.Struct + `ap` (return $ case t of A.NamedTypeReference n -> Just n; _ -> Nothing) + `ap` (decodeM =<< liftIO (FFI.isPackedStruct ft)) + `ap` getConstantOperands [valueSubclassIdP|ConstantDataArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData [valueSubclassIdP|ConstantArray|] -> diff --git a/src/LLVM/General/Internal/FFI/Constant.hs b/src/LLVM/General/Internal/FFI/Constant.hs --- a/src/LLVM/General/Internal/FFI/Constant.hs +++ b/src/LLVM/General/Internal/FFI/Constant.hs @@ -53,6 +53,11 @@ constStructInContext ctx (n, cs) p = constStructInContext' ctx cs n p +foreign import ccall unsafe "LLVMConstNamedStruct" constNamedStruct' :: + Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +constNamedStruct ty (n, cs) = constNamedStruct' ty cs n + foreign import ccall unsafe "LLVM_General_GetConstantDataSequentialElementAsConstant" getConstantDataSequentialElementAsConstant :: Ptr Constant -> CUInt -> IO (Ptr Constant) diff --git a/src/LLVM/General/Internal/FFI/Value.hs b/src/LLVM/General/Internal/FFI/Value.hs --- a/src/LLVM/General/Internal/FFI/Value.hs +++ b/src/LLVM/General/Internal/FFI/Value.hs @@ -32,3 +32,6 @@ foreign import ccall unsafe "LLVMReplaceAllUsesWith" replaceAllUsesWith :: Ptr Value -> Ptr Value -> IO () + +foreign import ccall unsafe "LLVMDumpValue" dumpValue :: + Ptr Value -> IO () diff --git a/test/LLVM/General/Test/Constants.hs b/test/LLVM/General/Test/Constants.hs --- a/test/LLVM/General/Test/Constants.hs +++ b/test/LLVM/General/Test/Constants.hs @@ -91,7 +91,7 @@ ), ( "struct", StructureType False (replicate 2 (IntegerType 32)), - C.Struct False (replicate 2 (C.Int 32 1)), + C.Struct Nothing False (replicate 2 (C.Int 32 1)), "global { i32, i32 } { i32 1, i32 1 }" ), ( "dataarray", @@ -101,7 +101,7 @@ ), ( "array", ArrayType 3 (StructureType False [IntegerType 32]), - C.Array (StructureType False [IntegerType 32]) [C.Struct False [C.Int 32 i] | i <- [1,2,1]], + C.Array (StructureType False [IntegerType 32]) [C.Struct Nothing False [C.Int 32 i] | i <- [1,2,1]], "global [3 x { i32 }] [{ i32 } { i32 1 }, { i32 } { i32 2 }, { i32 } { i32 1 }]" ), ( "datavector", diff --git a/test/LLVM/General/Test/Module.hs b/test/LLVM/General/Test/Module.hs --- a/test/LLVM/General/Test/Module.hs +++ b/test/LLVM/General/Test/Module.hs @@ -383,7 +383,25 @@ ] s <- withModuleFromAST' context ast moduleLLVMAssembly m <- withModuleFromLLVMAssembly' context s moduleAST - m @?= ast + m @?= ast, + + testCase "struct constant" $ do + let s = "; ModuleID = ''\n\ + \\n\ + \%0 = type { i32 }\n\ + \\n\ + \@0 = constant %0 { i32 1 }, align 4\n" + ast = Module "" Nothing Nothing [ + TypeDefinition (UnName 0) (Just $ StructureType False [IntegerType 32]), + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, + G.isConstant = True, + G.type' = NamedTypeReference (UnName 0), + G.initializer = Just $ C.Struct (Just $ UnName 0) False [ C.Int 32 1 ], + G.alignment = 4 + } + ] + strCheck ast s ], testGroup "failures" [