├── .gitignore ├── .hgignore ├── .hgtags ├── CHANGELOG.md ├── LICENSE ├── LLVM ├── Core.hs ├── Core │ ├── CodeGen.hs │ ├── CodeGenMonad.hs │ ├── Data.hs │ ├── Instructions.hs │ ├── Type.hs │ ├── Util.hs │ └── Vector.hs ├── ExecutionEngine.hs ├── ExecutionEngine │ ├── Engine.hs │ └── Target.hs └── Util │ ├── Arithmetic.hs │ ├── File.hs │ ├── Foreign.hs │ ├── Loop.hs │ ├── Memory.hs │ └── Optimize.hs ├── PROBLEMS.md ├── README.md ├── Setup.lhs ├── base ├── CHANGELOG.md ├── INSTALL.md ├── LICENSE ├── LLVM │ ├── FFI │ │ ├── Analysis.hsc │ │ ├── AssemblyReader.hsc │ │ ├── BitReader.hsc │ │ ├── BitWriter.hsc │ │ ├── Core.hsc │ │ ├── ExecutionEngine.hsc │ │ ├── Linker.hsc │ │ ├── Support.hsc │ │ ├── Target.hsc │ │ └── Transforms │ │ │ ├── IPO.hsc │ │ │ ├── PassManagerBuilder.hsc │ │ │ └── Scalar.hsc │ ├── ST.hs │ ├── Target │ │ ├── ARM.hs │ │ ├── CellSPU.hs │ │ ├── CppBackend.hs │ │ ├── MSP430.hs │ │ ├── Mips.hs │ │ ├── Native.hs │ │ ├── PowerPC.hs │ │ ├── Sparc.hs │ │ ├── X86.hs │ │ └── XCore.hs │ └── Wrapper │ │ ├── Analysis.hs │ │ ├── BitReader.hs │ │ ├── BitWriter.hs │ │ ├── Core.hs │ │ ├── ExecutionEngine.hs │ │ ├── Internal.hs │ │ ├── Linker.hs │ │ ├── Target.hs │ │ └── Transforms │ │ └── PassManagerBuilder.hs ├── README.md ├── Setup.hs ├── cbits │ ├── extra.cpp │ ├── free.c │ ├── malloc.c │ └── support.cpp ├── configure.ac ├── include │ ├── extra.h │ ├── hs_llvm_config.h.in │ ├── passes-inl.h │ └── support.h ├── llvm-base.buildinfo.in ├── llvm-base.buildinfo.windows.in ├── llvm-base.cabal └── tools │ ├── DiffFFI.hs │ ├── FunctionMangler.hs │ ├── FunctionMangulation.hs │ ├── IntrinsicMangler.hs │ ├── Makefile │ ├── ltrace.config │ └── ltrace.readme ├── examples ├── Align.hs ├── Arith.hs ├── Array.hs ├── BrainF.hs ├── CallConv.hs ├── Convert.hs ├── DotProd.hs ├── Fibonacci.hs ├── HelloJIT.hs ├── List.hs ├── Makefile ├── ModuleMaker.hs ├── Struct.hs ├── Varargs.hs ├── Vector.hs ├── mainfib.c └── structCheck.c ├── llvm.cabal └── tests ├── Makefile └── TestValue.hs /.gitignore: -------------------------------------------------------------------------------- 1 | config.log 2 | config.status 3 | dist/ 4 | llvm.buildinfo 5 | base/autom4te.cache/ 6 | base/configure 7 | base/include/hs_llvm_config.h 8 | base/llvm-base.buildinfo 9 | *.o 10 | *.hi 11 | *.exe 12 | examples/*_stub.h 13 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | ^(?:INSTALL.html|PROBLEMS.html|README.html|base/autom4te.cache|base/configure|base/dist|cabal-dev|dist|base/llvm-base.buildinfo)$ 2 | ^base/config\.(?:status)$ 3 | ^base/include/hs_llvm_config.h$ 4 | ^tests/(?:\.hpc|ps)$ 5 | \.(?:aux|bc|eventlog|exe|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$ 6 | ^examples/listcontent.u32$ 7 | ~$ 8 | syntax: glob 9 | .\#* 10 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 01fb5d97e3f432c67497d48476d81de5810905fa 0_6_6_0 2 | 08d6a4ad770ee3477e06290b15e64189181c9fa0 0_6_7_0 3 | 13806ed23c85b0888368f74303664bd96b8d21b3 0_5_0_0 4 | 19f96857e942431ed12d55ebb78d9f5de2c0e7f5 0_4_0_3 5 | 3dce222136d670d3feb125db2b7e04b814b1b340 0_6_0_0 6 | 54c4231af1cdc31b62d6468fe048a923de04d872 0_6_5_0 7 | 650665ad8e638c14a58421b9f9498376b398fbd1 0_6_3_0 8 | 70606ccc4577549716a403614aee10c2886183e8 0_6_0_1 9 | 7b0bf2260a2b7228d118bf0fe980a7dafffafeed 0_6_0_2 10 | 80bb101a94bd65230645216b8b5b4bfba09b8aa4 0_6_2_0 11 | 8d1e02265b046e210d9dd6fb12f8b31826020b97 0_7_0_0 12 | 9cea69bf46c2abf3533be7bcd8534ccb840f66dc 0_4_0_2 13 | 9fb52e228cc85293eb9d2684d0ce94f3c37c1fa8 0_4_4_0 14 | 9fb52e228cc85293eb9d2684d0ce94f3c37c1fa8 0_4_4_1 15 | a3bcfdf8bc470564e85e8c3052338e7882cf6b44 0_4_2_0 16 | a83e90e3194dc62f2ecebe5051add5ab25a8e926 0_6_4_0 17 | a9e288758047a5de31aa1a723fe85227377f9896 0_4_4_3 18 | adb0a1514287c8001bbb62308a0ff670307e9209 0_9_1_0 19 | bedce81bf2dcd5660dd76017a47c956da05f2313 0_0_2 20 | c0585f76919018c1cb79f67002366ca63f55ffb1 0_0_3 21 | ce3d98dc810d8bb4259bc2ba1672b186b8126082 0_9_1_1 22 | d0673796da853c64a69ca557dd019ceba8518c66 0_8_2_0 23 | d49da45de50ac1c32fc2725e227df38c8059a3a3 0_5_0_1 24 | e9629c390317a2fa35c823b7d20a46ac5b3f2e50 0_4_1_0 25 | f7e21a44f034e01c8f0e88641ff97363bb1401fe 0_8_0_2 26 | ff95e98f68eb0cc681dbc0f6803a2325fb98fb8c 0_0_1 27 | 94ee9e340ca7c09184b2d894a5783d5b65608368 0.10.0.0 28 | b4ff2b1c45b868666c2e91f22a35fdd9bcf7e5d0 0.10.0.1 29 | 11f7bcd0e7b9262ddccfdc12fb4336f021acf5ef 3.0.0.0 30 | db7aa86749debf4a4f915a7263308263ef208435 3.0.0.1 31 | 0a4a77d251642fcfc18849b74d702a162c942156 3.0.1.0 32 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | #ChangeLog 2 | 3 | ##New in 3.2.0.2 4 | 5 | 1. broken cabal file, fixed. 6 | 7 | ##New in 3.2.0.1 8 | 9 | 1. We now have a change log file! 10 | 2. Added support for a wider range of cabal versions. 11 | Both < 1.17 and >= 1.17 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ====================================================================== 2 | Haskell LLVM Bindings Release License 3 | ====================================================================== 4 | University of Illinois/NCSA 5 | Open Source License 6 | 7 | Copyright (c) 2007-2009 Bryan O'Sullivan 8 | All rights reserved. 9 | 10 | Developed by: 11 | 12 | Bryan O'Sullivan 13 | http://www.serpentine.com/blog/ 14 | 15 | Lennart Augustsson 16 | 17 | Permission is hereby granted, free of charge, to any person obtaining 18 | a copy of this software and associated documentation files (the 19 | "Software"), to deal with the Software without restriction, including 20 | without limitation the rights to use, copy, modify, merge, publish, 21 | distribute, sublicense, and/or sell copies of the Software, and to 22 | permit persons to whom the Software is furnished to do so, subject to 23 | the following conditions: 24 | 25 | * Redistributions of source code must retain the above copyright 26 | notice, this list of conditions and the following disclaimers. 27 | 28 | * Redistributions in binary form must reproduce the above 29 | copyright notice, this list of conditions and the following 30 | disclaimers in the documentation and/or other materials provided 31 | with the distribution. 32 | 33 | * Neither the names of Bryan O'Sullivan, University of Illinois at 34 | Urbana-Champaign, nor the names of its contributors may be used 35 | to endorse or promote products derived from this Software 36 | without specific prior written permission. 37 | 38 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 39 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 40 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 41 | IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR 42 | ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 43 | CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 44 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. 45 | 46 | ====================================================================== 47 | Copyrights and Licenses for Third Party Software Distributed with 48 | Haskell LLVM Bindings: 49 | ====================================================================== 50 | 51 | The Haskell LLVM Bindings software may contain code written by third 52 | parties. Any such software will have its own individual license file 53 | in the directory in which it appears. This file will describe the 54 | copyrights, license, and restrictions which apply to that code. 55 | 56 | The disclaimer of warranty in the University of Illinois Open Source 57 | License applies to all code in the Haskell LLVM Bindings Distribution, 58 | and nothing in any of the other licenses gives permission to use the 59 | name of Bryan O'Sullivan or the University of Illinois to endorse or 60 | promote products derived from this Software. 61 | 62 | The following pieces of software have additional or alternate 63 | copyrights, licenses, and/or restrictions: 64 | 65 | Program Directory 66 | ------- --------- 67 | configure . 68 | 69 | 70 | -------------------------------------------------------------------------------- /LLVM/Core.hs: -------------------------------------------------------------------------------- 1 | -- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level. 2 | -- It supports both stand alone code generation and JITing. 3 | -- The Haskell llvm package is a (relatively) high level interface to the LLVM. 4 | -- The high level interface makes it easy to construct LLVM code. 5 | -- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface. 6 | -- 7 | -- LLVM code is organized into modules (type 'Module'). 8 | -- Each module contains a number of global variables and functions (type 'Function'). 9 | -- Each functions has a number of basic blocks (type 'BasicBlock'). 10 | -- Each basic block has a number instructions, where each instruction produces 11 | -- a value (type 'Value'). 12 | -- 13 | -- Unlike assembly code for a real processor the assembly code for LLVM is 14 | -- in SSA (Static Single Assignment) form. This means that each instruction generates 15 | -- a new bound variable which may not be assigned again. 16 | -- A consequence of this is that where control flow joins from several execution 17 | -- paths there has to be a phi pseudo instruction if you want different variables 18 | -- to be joined into one. 19 | -- 20 | -- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock') 21 | -- follow the same pattern. First the entity has to be created using @newX@ (where @X@ 22 | -- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to 23 | -- given its definition using @defineX@. The reason for splitting the creation and 24 | -- definition is that you often need to be able to refer to an entity before giving 25 | -- it's body, e.g., in two mutually recursive functions. 26 | -- The the @newX@ and @defineX@ function can also be done at the same time by using 27 | -- @createX@. Furthermore, an explicit name can be given to an entity by the 28 | -- @newNamedX@ function; the @newX@ function just generates a fresh name. 29 | module LLVM.Core( 30 | -- * Initialize 31 | initializeNativeTarget, 32 | -- * Modules 33 | Module, newModule, newNamedModule, defineModule, destroyModule, createModule, 34 | ModuleProvider, createModuleProviderForExistingModule, 35 | PassManager, createPassManager, createFunctionPassManager, 36 | writeBitcodeToFile, readBitcodeFromFile, 37 | getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, 38 | -- * Instructions 39 | module LLVM.Core.Instructions, 40 | -- * Types classification 41 | module LLVM.Core.Type, 42 | -- * Extra types 43 | module LLVM.Core.Data, 44 | -- * Values and constants 45 | Value, ConstValue, valueOf, constOf, value, 46 | zero, allOnes, undef, 47 | createString, createStringNul, 48 | withString, withStringNul, 49 | withModule, Module(..), 50 | --constString, constStringNul, 51 | constVector, constArray, 52 | constStruct, constPackedStruct, 53 | toVector, fromVector, vector, 54 | -- * Code generation 55 | CodeGenFunction, CodeGenModule, 56 | -- * Functions 57 | Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, 58 | TFunction, liftCodeGenModule, getParams, 59 | -- * Global variable creation 60 | Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, 61 | externFunction, staticFunction, 62 | externGlobal, staticGlobal, 63 | GlobalMappings, getGlobalMappings, 64 | TGlobal, 65 | -- * Globals 66 | Linkage(..), 67 | -- * Basic blocks 68 | BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, createNamedBasicBlock, getCurrentBasicBlock, 69 | getBasicBlocks, 70 | fromLabel, toLabel, 71 | getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, 72 | -- * Misc 73 | addAttributes, Attribute(..), 74 | castVarArgs, 75 | -- * Debugging 76 | dumpValue, dumpType, annotateValueList, 77 | getValueName, setValueName, setValueName_ 78 | ) where 79 | 80 | import qualified LLVM.FFI.Core as FFI 81 | import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) 82 | import LLVM.Core.CodeGen 83 | import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule, liftCodeGenModule, GlobalMappings, getGlobalMappings) 84 | import LLVM.Core.Data 85 | import LLVM.Core.Instructions 86 | import LLVM.Core.Type 87 | import LLVM.Core.Vector 88 | import LLVM.Target.Native 89 | 90 | -- |Print a value. 91 | dumpValue :: Value a -> IO () 92 | dumpValue (Value v) = FFI.dumpValue v 93 | 94 | -- |Print a type. 95 | dumpType :: Value a -> IO () 96 | dumpType (Value v) = showTypeOf v >>= putStrLn 97 | 98 | -- |Get the name of a 'Value'. 99 | getValueName :: Value a -> IO String 100 | getValueName (Value a) = getValueNameU a 101 | 102 | -- |Set the name of a 'Value'. 103 | setValueName :: String -> Value a -> IO (Value a) 104 | setValueName str v@(Value a) = setValueNameU str a >> return v 105 | 106 | -- |Set the name of a 'Value'. 107 | setValueName_ :: String -> Value a -> IO () 108 | setValueName_ str (Value a) = setValueNameU str a 109 | 110 | -- |Convert a varargs function to a regular function. 111 | castVarArgs :: (CastVarArgs a b) => Function a -> Function b 112 | castVarArgs (Value a) = Value a 113 | 114 | -- TODO for types: 115 | -- Enforce free is only called on malloc memory. (Enforce only one free?) 116 | -- Enforce phi nodes a accessor of variables outside the bb 117 | -- Enforce bb terminator 118 | -- Enforce phi first 119 | -- 120 | -- TODO: 121 | -- Add Struct, PackedStruct types 122 | -- Get alignment from code gen 123 | -------------------------------------------------------------------------------- /LLVM/Core/CodeGenMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 | module LLVM.Core.CodeGenMonad( 3 | -- * Module code generation 4 | CodeGenModule, runCodeGenModule, genMSym, getModule, 5 | GlobalMappings(..), addGlobalMapping, getGlobalMappings, 6 | -- * Function code generation 7 | CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, 8 | -- * Reexport 9 | liftIO 10 | ) where 11 | import Data.Typeable 12 | import Control.Monad.State 13 | import Control.Applicative (Applicative, ) 14 | 15 | import Foreign.Ptr (Ptr, ) 16 | 17 | import LLVM.Core.Util(Module, Builder, Function) 18 | 19 | -------------------------------------- 20 | 21 | data CGMState = CGMState { 22 | cgm_module :: Module, 23 | cgm_externs :: [(String, Function)], 24 | cgm_global_mappings :: [(Function, Ptr ())], 25 | cgm_next :: !Int 26 | } 27 | deriving (Show, Typeable) 28 | newtype CodeGenModule a = CGM (StateT CGMState IO a) 29 | deriving (Functor, Applicative, Monad, MonadFix, MonadState CGMState, MonadIO, Typeable) 30 | 31 | genMSym :: String -> CodeGenModule String 32 | genMSym prefix = do 33 | s <- get 34 | let n = cgm_next s 35 | put (s { cgm_next = n + 1 }) 36 | return $ "_" ++ prefix ++ show n 37 | 38 | getModule :: CodeGenModule Module 39 | getModule = gets cgm_module 40 | 41 | runCodeGenModule :: Module -> CodeGenModule a -> IO a 42 | runCodeGenModule m (CGM body) = do 43 | let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] } 44 | evalStateT body cgm 45 | 46 | -------------------------------------- 47 | 48 | data CGFState r = CGFState { 49 | cgf_module :: CGMState, 50 | cgf_builder :: Builder, 51 | cgf_function :: Function, 52 | cgf_next :: !Int 53 | } 54 | deriving (Show, Typeable) 55 | 56 | newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) 57 | deriving (Functor, Applicative, Monad, MonadFix, MonadState (CGFState r), MonadIO, Typeable) 58 | 59 | genFSym :: CodeGenFunction a String 60 | genFSym = do 61 | s <- get 62 | let n = cgf_next s 63 | put (s { cgf_next = n + 1 }) 64 | return $ "_L" ++ show n 65 | 66 | getFunction :: CodeGenFunction a Function 67 | getFunction = gets cgf_function 68 | 69 | getBuilder :: CodeGenFunction a Builder 70 | getBuilder = gets cgf_builder 71 | 72 | getFunctionModule :: CodeGenFunction a Module 73 | getFunctionModule = gets (cgm_module . cgf_module) 74 | 75 | getExterns :: CodeGenFunction a [(String, Function)] 76 | getExterns = gets (cgm_externs . cgf_module) 77 | 78 | putExterns :: [(String, Function)] -> CodeGenFunction a () 79 | putExterns es = do 80 | cgf <- get 81 | let cgm' = (cgf_module cgf) { cgm_externs = es } 82 | put (cgf { cgf_module = cgm' }) 83 | 84 | addGlobalMapping :: 85 | Function -> Ptr () -> CodeGenModule () 86 | addGlobalMapping value func = modify $ \cgm -> 87 | cgm { cgm_global_mappings = 88 | (value,func) : cgm_global_mappings cgm } 89 | 90 | newtype GlobalMappings = 91 | GlobalMappings [(Function, Ptr ())] 92 | 93 | {- | 94 | Get a list created by calls to 'staticFunction' 95 | that must be passed to the execution engine 96 | via 'LLVM.ExecutionEngine.addGlobalMappings'. 97 | -} 98 | getGlobalMappings :: 99 | CodeGenModule GlobalMappings 100 | getGlobalMappings = 101 | gets (GlobalMappings . cgm_global_mappings) 102 | 103 | runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a 104 | runCodeGenFunction bld fn (CGF body) = do 105 | cgm <- get 106 | let cgf = CGFState { cgf_module = cgm, 107 | cgf_builder = bld, 108 | cgf_function = fn, 109 | cgf_next = 1 } 110 | (a, cgf') <- liftIO $ runStateT body cgf 111 | put (cgf_module cgf') 112 | return a 113 | 114 | -------------------------------------- 115 | 116 | -- | Allows you to define part of a module while in the middle of defining a function. 117 | liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a 118 | liftCodeGenModule (CGM act) = do 119 | cgf <- get 120 | (a, cgm') <- liftIO $ runStateT act (cgf_module cgf) 121 | put (cgf { cgf_module = cgm' }) 122 | return a 123 | -------------------------------------------------------------------------------- /LLVM/Core/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls, DeriveDataTypeable #-} 2 | module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), 3 | Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where 4 | import Data.Typeable 5 | import Foreign.Ptr(Ptr) 6 | 7 | -- TODO: 8 | -- Make instances IntN, WordN to actually do the right thing. 9 | -- Make FP128 do the right thing 10 | -- Make Array functions. 11 | 12 | -- |Variable sized signed integer. 13 | -- The /n/ parameter should belong to @PosI@. 14 | newtype IntN n = IntN Integer 15 | deriving (Show, Typeable) 16 | 17 | -- |Variable sized unsigned integer. 18 | -- The /n/ parameter should belong to @PosI@. 19 | newtype WordN n = WordN Integer 20 | deriving (Show, Typeable) 21 | 22 | -- |128 bit floating point. 23 | newtype FP128 = FP128 Rational 24 | deriving (Show, Typeable) 25 | 26 | -- |Fixed sized arrays, the array size is encoded in the /n/ parameter. 27 | newtype Array n a = Array [a] 28 | deriving (Show, Typeable) 29 | 30 | -- |Fixed sized vector, the array size is encoded in the /n/ parameter. 31 | newtype Vector n a = Vector [a] 32 | deriving (Show, Typeable) 33 | 34 | -- |Label type, produced by a basic block. 35 | data Label 36 | deriving (Typeable) 37 | 38 | -- |Struct types; a list (nested tuple) of component types. 39 | newtype Struct a = Struct a 40 | deriving (Show, Typeable) 41 | newtype PackedStruct a = PackedStruct a 42 | deriving (Show, Typeable) 43 | -------------------------------------------------------------------------------- /LLVM/Core/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables #-} 3 | module LLVM.Core.Vector(MkVector(..), vector, ) where 4 | import Data.Function 5 | import Data.TypeLevel hiding (Eq, (+), (==), (-), (*), succ, pred, div, mod, divMod, logBase) 6 | import LLVM.Core.Type 7 | import LLVM.Core.Data 8 | import LLVM.ExecutionEngine.Target 9 | import Foreign.Ptr(castPtr) 10 | import Foreign.Storable(Storable(..)) 11 | import Foreign.Marshal.Array(peekArray, pokeArray) 12 | import System.IO.Unsafe(unsafePerformIO) 13 | 14 | -- XXX Should these really be here? 15 | class (Pos n, IsPrimitive a) => MkVector va n a | va -> n a, n a -> va where 16 | toVector :: va -> Vector n a 17 | fromVector :: Vector n a -> va 18 | 19 | {- 20 | instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where 21 | toVector a = Vector [a] 22 | -} 23 | 24 | instance (IsPrimitive a) => MkVector (a, a) D2 a where 25 | toVector (a1, a2) = Vector [a1, a2] 26 | fromVector (Vector [a1, a2]) = (a1, a2) 27 | fromVector _ = error "fromVector: impossible" 28 | 29 | instance (IsPrimitive a) => MkVector (a, a, a, a) D4 a where 30 | toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4] 31 | fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4) 32 | fromVector _ = error "fromVector: impossible" 33 | 34 | instance (IsPrimitive a) => MkVector (a, a, a, a, a, a, a, a) D8 a where 35 | toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8] 36 | fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8) 37 | fromVector _ = error "fromVector: impossible" 38 | 39 | instance (Storable a, Pos n, IsPrimitive a) => Storable (Vector n a) where 40 | sizeOf a = storeSizeOfType ourTargetData (typeRef a) 41 | alignment a = aBIAlignmentOfType ourTargetData (typeRef a) 42 | peek p = fmap Vector $ peekArray (toNum (undefined :: n)) (castPtr p :: Ptr a) 43 | poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs 44 | 45 | -- XXX The JITer target data. This isn't really right. 46 | ourTargetData :: TargetData 47 | ourTargetData = unsafePerformIO getTargetData 48 | 49 | -------------------------------------- 50 | 51 | unVector :: Vector n a -> [a] 52 | unVector (Vector xs) = xs 53 | 54 | -- |Make a constant vector. Replicates or truncates the list to get length /n/. 55 | -- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'. 56 | vector :: forall a n. (Pos n) => [a] -> Vector n a 57 | vector xs = 58 | Vector (take (toNum (undefined :: n)) (cycle xs)) 59 | 60 | 61 | binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c 62 | binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys) 63 | 64 | unop :: (a -> b) -> Vector n a -> Vector n b 65 | unop op = Vector . map op . unVector 66 | 67 | instance (Eq a, Pos n) => Eq (Vector n a) where 68 | (==) = (==) `on` unVector 69 | 70 | instance (Ord a, Pos n) => Ord (Vector n a) where 71 | compare = compare `on` unVector 72 | 73 | instance (Num a, Pos n) => Num (Vector n a) where 74 | (+) = binop (+) 75 | (-) = binop (-) 76 | (*) = binop (*) 77 | negate = unop negate 78 | abs = unop abs 79 | signum = unop signum 80 | fromInteger = Vector . replicate (toNum (undefined :: n)) . fromInteger 81 | 82 | instance (Enum a, Pos n) => Enum (Vector n a) where 83 | succ = unop succ 84 | pred = unop pred 85 | fromEnum = error "Vector fromEnum" 86 | toEnum = Vector . map toEnum . replicate (toNum (undefined :: n)) 87 | 88 | instance (Real a, Pos n) => Real (Vector n a) where 89 | toRational = error "Vector toRational" 90 | 91 | instance (Integral a, Pos n) => Integral (Vector n a) where 92 | quot = binop quot 93 | rem = binop rem 94 | div = binop div 95 | mod = binop mod 96 | quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys 97 | divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys 98 | toInteger = error "Vector toInteger" 99 | 100 | instance (Fractional a, Pos n) => Fractional (Vector n a) where 101 | (/) = binop (/) 102 | fromRational = Vector . replicate (toNum (undefined :: n)) . fromRational 103 | 104 | instance (RealFrac a, Pos n) => RealFrac (Vector n a) where 105 | properFraction = error "Vector properFraction" 106 | 107 | instance (Floating a, Pos n) => Floating (Vector n a) where 108 | pi = Vector $ replicate (toNum (undefined :: n)) pi 109 | sqrt = unop sqrt 110 | log = unop log 111 | logBase = binop logBase 112 | (**) = binop (**) 113 | exp = unop exp 114 | sin = unop sin 115 | cos = unop cos 116 | tan = unop tan 117 | asin = unop asin 118 | acos = unop acos 119 | atan = unop atan 120 | sinh = unop sinh 121 | cosh = unop cosh 122 | tanh = unop tanh 123 | asinh = unop asinh 124 | acosh = unop acosh 125 | atanh = unop atanh 126 | 127 | instance (RealFloat a, Pos n) => RealFloat (Vector n a) where 128 | floatRadix = floatRadix . head . unVector 129 | floatDigits = floatDigits . head . unVector 130 | floatRange = floatRange . head . unVector 131 | decodeFloat = error "Vector decodeFloat" 132 | encodeFloat = error "Vector encodeFloat" 133 | exponent _ = 0 134 | scaleFloat 0 x = x 135 | scaleFloat _ _ = error "Vector scaleFloat" 136 | isNaN = error "Vector isNaN" 137 | isInfinite = error "Vector isInfinite" 138 | isDenormalized = error "Vector isDenormalized" 139 | isNegativeZero = error "Vector isNegativeZero" 140 | isIEEE = isIEEE . head . unVector 141 | -------------------------------------------------------------------------------- /LLVM/ExecutionEngine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} 2 | -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. 3 | module LLVM.ExecutionEngine( 4 | -- * Execution engine 5 | EngineAccess, 6 | runEngineAccess, 7 | addModuleProvider, 8 | addModule, 9 | {- 10 | runStaticConstructors, 11 | runStaticDestructors, 12 | -} 13 | getPointerToFunction, 14 | addFunctionValue, 15 | addGlobalMappings, 16 | getFreePointers, FreePointers, 17 | -- * Translation 18 | Translatable, Generic, 19 | generateFunction, generateFunctionFromRef, 20 | -- * Unsafe type conversion 21 | Unsafe, 22 | unsafePurify, 23 | -- * Simplified interface. 24 | simpleFunction, 25 | unsafeGenerateFunction, 26 | -- * Target information 27 | module LLVM.ExecutionEngine.Target 28 | ) where 29 | import System.IO.Unsafe (unsafePerformIO) 30 | 31 | import LLVM.ExecutionEngine.Engine 32 | import LLVM.FFI.Core(ValueRef) 33 | import LLVM.Core.CodeGen(Value(..)) 34 | import LLVM.Core 35 | import LLVM.ExecutionEngine.Target 36 | --import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) 37 | import Control.Monad (liftM2, ) 38 | 39 | -- |Class of LLVM function types that can be translated to the corresponding 40 | -- Haskell type. 41 | class Translatable f where 42 | translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f 43 | 44 | instance (Generic a, Translatable b) => Translatable (a -> b) where 45 | translate run args f = \ arg -> translate run (toGeneric arg : args) f 46 | 47 | instance (Generic a) => Translatable (IO a) where 48 | translate run args f = fmap fromGeneric $ run f $ reverse args 49 | 50 | -- |Generate a Haskell function from an LLVM function. 51 | -- 52 | -- Note that the function is compiled for every call (Just-In-Time compilation). 53 | -- If you want to compile the function once and call it a lot of times 54 | -- then you should better use 'getPointerToFunction'. 55 | generateFunction :: (Translatable f) => 56 | Value (Ptr f) -> EngineAccess f 57 | generateFunction (Value f) = generateFunctionFromRef f 58 | 59 | generateFunctionFromRef :: (Translatable f) => ValueRef -> EngineAccess f 60 | generateFunctionFromRef f = do 61 | run <- getRunFunction 62 | return $ translate run [] f 63 | 64 | class Unsafe a b | a -> b where 65 | unsafePurify :: a -> b -- ^Remove the IO from a function return type. This is unsafe in general. 66 | 67 | instance (Unsafe b b') => Unsafe (a->b) (a->b') where 68 | unsafePurify f = unsafePurify . f 69 | 70 | instance Unsafe (IO a) a where 71 | unsafePurify = unsafePerformIO 72 | 73 | -- |Translate a function to Haskell code. This is a simplified interface to 74 | -- the execution engine and module mechanism. 75 | -- It is based on 'generateFunction', so see there for limitations. 76 | simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f 77 | simpleFunction bld = do 78 | m <- newModule 79 | (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) 80 | prov <- createModuleProviderForExistingModule m 81 | runEngineAccess $ do 82 | addModuleProvider prov 83 | addGlobalMappings mappings 84 | generateFunction func 85 | 86 | {- 87 | m <- newModule 88 | func <- defineModule m bld 89 | -- dumpValue func 90 | prov <- createModuleProviderForExistingModule m 91 | ee <- createExecutionEngine prov 92 | pm <- createFunctionPassManager prov 93 | td <- getExecutionEngineTargetData ee 94 | addTargetData td pm 95 | addInstructionCombiningPass pm 96 | addReassociatePass pm 97 | addGVNPass pm 98 | addCFGSimplificationPass pm 99 | addPromoteMemoryToRegisterPass pm 100 | initializeFunctionPassManager pm 101 | -- print ("rc1", rc1) 102 | runFunctionPassManager pm (unValue func) 103 | -- print ("rc2", rc2) 104 | finalizeFunctionPassManager pm 105 | -- print ("rc3", rc3) 106 | -- dumpValue func 107 | return $ generateFunction ee func 108 | -} 109 | 110 | -- | Combine 'simpleFunction' and 'unsafePurify'. 111 | unsafeGenerateFunction :: (Unsafe t a, Translatable t) => 112 | CodeGenModule (Function t) -> a 113 | unsafeGenerateFunction bld = unsafePerformIO $ do 114 | fun <- simpleFunction bld 115 | return $ unsafePurify fun 116 | -------------------------------------------------------------------------------- /LLVM/ExecutionEngine/Engine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 | module LLVM.ExecutionEngine.Engine( 3 | EngineAccess, 4 | runEngineAccess, 5 | {- 6 | ExecutionEngine, 7 | -} 8 | createExecutionEngine, addModuleProvider, addModule, 9 | {- runStaticConstructors, runStaticDestructors, -} 10 | getExecutionEngineTargetData, 11 | getPointerToFunction, 12 | addFunctionValue, addGlobalMappings, 13 | getFreePointers, FreePointers, 14 | runFunction, getRunFunction, 15 | GenericValue, Generic(..) 16 | ) where 17 | import Control.Monad.State 18 | import Control.Applicative (Applicative, ) 19 | import Control.Concurrent.MVar 20 | import Data.Typeable 21 | import Data.Int 22 | import Data.Word 23 | import Foreign.Marshal.Alloc (alloca, free) 24 | import Foreign.Marshal.Array (withArrayLen) 25 | import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) 26 | import Foreign.Marshal.Utils (fromBool) 27 | import Foreign.C.String (peekCString) 28 | import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr) 29 | import LLVM.Core.CodeGen(Value(..), Function) 30 | import LLVM.Core.CodeGenMonad(GlobalMappings(..)) 31 | import Foreign.Storable (peek) 32 | import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) 33 | import System.IO.Unsafe (unsafePerformIO) 34 | 35 | import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule) 36 | import qualified LLVM.FFI.ExecutionEngine as FFI 37 | import qualified LLVM.FFI.Target as FFI 38 | import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) 39 | import qualified LLVM.Core.Util as U 40 | import LLVM.Core.Type(IsFirstClass, typeRef) 41 | 42 | {- 43 | -- |The type of the JITer. 44 | newtype ExecutionEngine = ExecutionEngine { 45 | fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine 46 | } 47 | 48 | withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) 49 | -> IO a 50 | withExecutionEngine = withForeignPtr . fromExecutionEngine 51 | 52 | -- |Create an execution engine for a module provider. 53 | -- Warning, do not call this function more than once. 54 | createExecutionEngine :: ModuleProvider -> IO ExecutionEngine 55 | createExecutionEngine prov = 56 | withModuleProvider prov $ \provPtr -> 57 | alloca $ \eePtr -> 58 | alloca $ \errPtr -> do 59 | ret <- FFI.createExecutionEngine eePtr provPtr errPtr 60 | if ret == 1 61 | then do err <- peek errPtr 62 | errStr <- peekCString err 63 | free err 64 | ioError . userError $ errStr 65 | else do ptr <- peek eePtr 66 | liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr 67 | 68 | addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () 69 | addModuleProvider ee prov = 70 | withExecutionEngine ee $ \ eePtr -> 71 | withModuleProvider prov $ \ provPtr -> 72 | FFI.addModuleProvider eePtr provPtr 73 | 74 | runStaticConstructors :: ExecutionEngine -> IO () 75 | runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors 76 | 77 | runStaticDestructors :: ExecutionEngine -> IO () 78 | runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors 79 | 80 | getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef 81 | getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData 82 | 83 | getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f) 84 | getPointerToFunction ee (Value f) = 85 | withExecutionEngine ee $ \ eePtr -> 86 | FFI.getPointerToGlobal eePtr f 87 | -} 88 | 89 | -- This global variable holds the one and only execution engine. 90 | -- It may be missing, but it never dies. 91 | -- XXX We could provide a destructor, what about functions obtained by runFunction? 92 | {-# NOINLINE theEngine #-} 93 | theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine)) 94 | theEngine = unsafePerformIO $ newMVar Nothing 95 | 96 | createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine) 97 | createExecutionEngine prov = 98 | withModuleProvider prov $ \provPtr -> 99 | alloca $ \eePtr -> 100 | alloca $ \errPtr -> do 101 | ret <- FFI.createExecutionEngine eePtr provPtr errPtr 102 | if ret == 1 103 | then do 104 | err <- peek errPtr 105 | errStr <- peekCString err 106 | free err 107 | ioError . userError $ errStr 108 | else 109 | peek eePtr 110 | 111 | getTheEngine :: IO (Ptr FFI.ExecutionEngine) 112 | getTheEngine = do 113 | mee <- takeMVar theEngine 114 | case mee of 115 | Just ee -> do putMVar theEngine mee; return ee 116 | Nothing -> do 117 | m <- createModule "__empty__" 118 | mp <- createModuleProviderForExistingModule m 119 | ee <- createExecutionEngine mp 120 | putMVar theEngine (Just ee) 121 | return ee 122 | 123 | data EAState = EAState { 124 | ea_engine :: Ptr FFI.ExecutionEngine, 125 | ea_providers :: [ModuleProvider] 126 | } 127 | deriving (Show, Typeable) 128 | 129 | newtype EngineAccess a = EA (StateT EAState IO a) 130 | deriving (Functor, Applicative, Monad, MonadState EAState, MonadIO) 131 | 132 | -- |The LLVM execution engine is encapsulated so it cannot be accessed directly. 133 | -- The reason is that (currently) there must only ever be one engine, 134 | -- so access to it is wrapped in a monad. 135 | runEngineAccess :: EngineAccess a -> IO a 136 | runEngineAccess (EA body) = do 137 | eePtr <- getTheEngine 138 | let ea = EAState { ea_engine = eePtr, ea_providers = [] } 139 | (a, _ea') <- runStateT body ea 140 | -- XXX should remove module providers again 141 | return a 142 | 143 | addModuleProvider :: ModuleProvider -> EngineAccess () 144 | addModuleProvider prov = do 145 | ea <- get 146 | put ea{ ea_providers = prov : ea_providers ea } 147 | liftIO $ withModuleProvider prov $ \ provPtr -> 148 | FFI.addModuleProvider (ea_engine ea) provPtr 149 | 150 | getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef 151 | getExecutionEngineTargetData = do 152 | eePtr <- gets ea_engine 153 | liftIO $ FFI.getExecutionEngineTargetData eePtr 154 | 155 | {- | 156 | In contrast to 'generateFunction' this compiles a function once. 157 | Thus it is faster for many calls to the same function. 158 | See @examples\/Vector.hs@. 159 | 160 | If the function calls back into Haskell code, 161 | you also have to set the function addresses 162 | using 'addFunctionValue' or 'addGlobalMappings'. 163 | -} 164 | getPointerToFunction :: Function f -> EngineAccess (FunPtr f) 165 | getPointerToFunction (Value f) = do 166 | eePtr <- gets ea_engine 167 | liftIO $ FFI.getPointerToGlobal eePtr f 168 | 169 | {- | 170 | Tell LLVM the address of an external function 171 | if it cannot resolve a name automatically. 172 | Alternatively you may declare the function 173 | with 'staticFunction' instead of 'externFunction'. 174 | -} 175 | addFunctionValue :: Function f -> FunPtr f -> EngineAccess () 176 | addFunctionValue (Value g) f = 177 | addFunctionValueCore g (castFunPtrToPtr f) 178 | 179 | {- | 180 | Pass a list of global mappings to LLVM 181 | that can be obtained from 'LLVM.Core.getGlobalMappings'. 182 | -} 183 | addGlobalMappings :: GlobalMappings -> EngineAccess () 184 | addGlobalMappings (GlobalMappings gms) = 185 | mapM_ (uncurry addFunctionValueCore) gms 186 | 187 | addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () 188 | addFunctionValueCore g f = do 189 | eePtr <- gets ea_engine 190 | liftIO $ FFI.addGlobalMapping eePtr g f 191 | 192 | addModule :: Module -> EngineAccess () 193 | addModule m = do 194 | mp <- liftIO $ createModuleProviderForExistingModule m 195 | addModuleProvider mp 196 | 197 | -- | Get all the information needed to free a function. 198 | -- Freeing code might have to be done from a (C) finalizer, so it has to done from C. 199 | -- The function c_freeFunctionObject take these pointers as arguments and frees the function. 200 | type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef) 201 | getFreePointers :: Function f -> EngineAccess FreePointers 202 | getFreePointers (Value f) = do 203 | ea <- get 204 | liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp -> 205 | return (ea_engine ea, mpp, f) 206 | 207 | -------------------------------------- 208 | 209 | newtype GenericValue = GenericValue { 210 | fromGenericValue :: ForeignPtr FFI.GenericValue 211 | } 212 | 213 | withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a 214 | withGenericValue = withForeignPtr . fromGenericValue 215 | 216 | createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue 217 | createGenericValueWith f = do 218 | ptr <- f 219 | liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr 220 | 221 | withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a 222 | withAll ps a = go [] ps 223 | where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs 224 | go ptrs _ = withArrayLen (reverse ptrs) a 225 | 226 | runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue 227 | runFunction func args = do 228 | eePtr <- gets ea_engine 229 | liftIO $ withAll args $ \argLen argPtr -> 230 | createGenericValueWith $ FFI.runFunction eePtr func 231 | (fromIntegral argLen) argPtr 232 | getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) 233 | getRunFunction = do 234 | eePtr <- gets ea_engine 235 | return $ \ func args -> 236 | withAll args $ \argLen argPtr -> 237 | createGenericValueWith $ FFI.runFunction eePtr func 238 | (fromIntegral argLen) argPtr 239 | 240 | class Generic a where 241 | toGeneric :: a -> GenericValue 242 | fromGeneric :: GenericValue -> a 243 | 244 | instance Generic () where 245 | toGeneric _ = error "toGeneric ()" 246 | fromGeneric _ = () 247 | 248 | toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue 249 | toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ 250 | FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed) 251 | 252 | fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a 253 | fromGenericInt signed val = unsafePerformIO $ 254 | withGenericValue val $ \ref -> 255 | return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) 256 | 257 | --instance Generic Bool where 258 | -- toGeneric = toGenericInt False . fromBool 259 | -- fromGeneric = toBool . fromGenericInt False 260 | 261 | instance Generic Int8 where 262 | toGeneric = toGenericInt True 263 | fromGeneric = fromGenericInt True 264 | 265 | instance Generic Int16 where 266 | toGeneric = toGenericInt True 267 | fromGeneric = fromGenericInt True 268 | 269 | instance Generic Int32 where 270 | toGeneric = toGenericInt True 271 | fromGeneric = fromGenericInt True 272 | 273 | {- 274 | instance Generic Int where 275 | toGeneric = toGenericInt True 276 | fromGeneric = fromGenericInt True 277 | -} 278 | 279 | instance Generic Int64 where 280 | toGeneric = toGenericInt True 281 | fromGeneric = fromGenericInt True 282 | 283 | instance Generic Word8 where 284 | toGeneric = toGenericInt False 285 | fromGeneric = fromGenericInt False 286 | 287 | instance Generic Word16 where 288 | toGeneric = toGenericInt False 289 | fromGeneric = fromGenericInt False 290 | 291 | instance Generic Word32 where 292 | toGeneric = toGenericInt False 293 | fromGeneric = fromGenericInt False 294 | 295 | instance Generic Word64 where 296 | toGeneric = toGenericInt False 297 | fromGeneric = fromGenericInt False 298 | 299 | toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue 300 | toGenericReal val = unsafePerformIO $ createGenericValueWith $ 301 | FFI.createGenericValueOfFloat (typeRef val) (realToFrac val) 302 | 303 | fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a 304 | fromGenericReal val = unsafePerformIO $ 305 | withGenericValue val $ \ ref -> 306 | return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref 307 | 308 | instance Generic Float where 309 | toGeneric = toGenericReal 310 | fromGeneric = fromGenericReal 311 | 312 | instance Generic Double where 313 | toGeneric = toGenericReal 314 | fromGeneric = fromGenericReal 315 | 316 | instance Generic (Ptr a) where 317 | toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer 318 | fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer 319 | 320 | instance Generic (StablePtr a) where 321 | toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr 322 | fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer 323 | -------------------------------------------------------------------------------- /LLVM/ExecutionEngine/Target.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, DeriveDataTypeable #-} 2 | module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where 3 | import Data.Typeable 4 | import Data.TypeLevel(Nat, reifyIntegral) 5 | import Foreign.C.String 6 | import System.IO.Unsafe(unsafePerformIO) 7 | 8 | import LLVM.Core.Data(WordN) 9 | import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData) 10 | 11 | import qualified LLVM.FFI.Core as FFI 12 | import qualified LLVM.FFI.Target as FFI 13 | 14 | type Type = FFI.TypeRef 15 | 16 | data TargetData = TargetData { 17 | aBIAlignmentOfType :: Type -> Int, 18 | aBISizeOfType :: Type -> Int, 19 | littleEndian :: Bool, 20 | callFrameAlignmentOfType :: Type -> Int, 21 | -- elementAtOffset :: Type -> Word64 -> Int, 22 | intPtrType :: Type, 23 | -- offsetOfElements :: Int -> Word64, 24 | pointerSize :: Int, 25 | -- preferredAlignmentOfGlobal :: Value a -> Int, 26 | preferredAlignmentOfType :: Type -> Int, 27 | sizeOfTypeInBits :: Type -> Int, 28 | storeSizeOfType :: Type -> Int 29 | } 30 | deriving (Typeable) 31 | 32 | withIntPtrType :: (forall n . (Nat n) => WordN n -> a) -> a 33 | withIntPtrType f = reifyIntegral sz (\ n -> f (g n)) 34 | where g :: n -> WordN n 35 | g _ = error "withIntPtrType: argument used" 36 | sz = pointerSize $ unsafePerformIO getTargetData 37 | 38 | -- Gets the target data for the JIT target. 39 | getEngineTargetDataRef :: IO FFI.TargetDataRef 40 | getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData 41 | 42 | -- Normally the TargetDataRef never changes, so the operation 43 | -- are really pure functions. 44 | makeTargetData :: FFI.TargetDataRef -> TargetData 45 | makeTargetData r = TargetData { 46 | aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r, 47 | aBISizeOfType = fromIntegral . FFI.aBISizeOfType r, 48 | littleEndian = FFI.byteOrder r /= 0, 49 | callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r, 50 | intPtrType = FFI.intPtrType r, 51 | pointerSize = fromIntegral $ FFI.pointerSize r, 52 | preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r, 53 | sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r, 54 | storeSizeOfType = fromIntegral . FFI.storeSizeOfType r 55 | } 56 | 57 | getTargetData :: IO TargetData 58 | getTargetData = fmap makeTargetData getEngineTargetDataRef 59 | 60 | targetDataFromString :: String -> TargetData 61 | targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData 62 | -------------------------------------------------------------------------------- /LLVM/Util/Arithmetic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} 2 | {-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies #-} 3 | module LLVM.Util.Arithmetic( 4 | TValue, 5 | Cmp(..), 6 | (%==), (%/=), (%<), (%<=), (%>), (%>=), 7 | (%&&), (%||), 8 | (?), (??), 9 | retrn, set, 10 | ArithFunction, arithFunction, 11 | UnwrapArgs, toArithFunction, 12 | recursiveFunction, 13 | CallIntrinsic, 14 | ) where 15 | import Data.Word 16 | import Data.Int 17 | import qualified Data.TypeLevel.Num as TypeNum 18 | import qualified LLVM.Core as LLVM 19 | import LLVM.Core hiding (cmp, ) 20 | import LLVM.Util.Loop(mapVector, mapVector2) 21 | 22 | -- |Synonym for @CodeGenFunction r (Value a)@. 23 | type TValue r a = CodeGenFunction r (Value a) 24 | 25 | {-# DEPRECATED cmp "use LLVM.Core.cmp instead" #-} 26 | class (CmpRet a b) => Cmp a b | a -> b where 27 | cmp :: IntPredicate -> Value a -> Value a -> TValue r b 28 | 29 | instance Cmp Bool Bool where cmp = icmp 30 | instance Cmp Word8 Bool where cmp = icmp 31 | instance Cmp Word16 Bool where cmp = icmp 32 | instance Cmp Word32 Bool where cmp = icmp 33 | instance Cmp Word64 Bool where cmp = icmp 34 | instance Cmp Int8 Bool where cmp = icmp . adjSigned 35 | instance Cmp Int16 Bool where cmp = icmp . adjSigned 36 | instance Cmp Int32 Bool where cmp = icmp . adjSigned 37 | instance Cmp Int64 Bool where cmp = icmp . adjSigned 38 | instance Cmp Float Bool where cmp = fcmp . adjFloat 39 | instance Cmp Double Bool where cmp = fcmp . adjFloat 40 | instance Cmp FP128 Bool where cmp = fcmp . adjFloat 41 | {- 42 | instance (Pos n) => Cmp (Vector n Bool) (Vector n Bool) where cmp = icmp 43 | instance (Pos n) => Cmp (Vector n Word8) (Vector n Bool) where cmp = icmp 44 | instance (Pos n) => Cmp (Vector n Word16) (Vector n Bool) where cmp = icmp 45 | instance (Pos n) => Cmp (Vector n Word32) (Vector n Bool) where cmp = icmp 46 | instance (Pos n) => Cmp (Vector n Word64) (Vector n Bool) where cmp = icmp 47 | instance (Pos n) => Cmp (Vector n Int8) (Vector n Bool) where cmp = icmp . adjSigned 48 | instance (Pos n) => Cmp (Vector n Int16) (Vector n Bool) where cmp = icmp . adjSigned 49 | instance (Pos n) => Cmp (Vector n Int32) (Vector n Bool) where cmp = icmp . adjSigned 50 | instance (Pos n) => Cmp (Vector n Int64) (Vector n Bool) where cmp = icmp . adjSigned 51 | instance (Pos n) => Cmp (Vector n Float) (Vector n Bool) where cmp = fcmp . adjFloat 52 | instance (Pos n) => Cmp (Vector n Double) (Vector n Bool) where cmp = fcmp . adjFloat 53 | instance (Pos n) => Cmp (Vector n FP128) (Vector n Bool) where cmp = fcmp . adjFloat 54 | -} 55 | instance (Pos n) => Cmp (Vector n Float) (Vector n Bool) where 56 | cmp op = mapVector2 (fcmp (adjFloat op)) 57 | instance (Pos n) => Cmp (Vector n Word32) (Vector n Bool) where 58 | cmp op = mapVector2 (cmp op) 59 | 60 | adjSigned :: IntPredicate -> IntPredicate 61 | adjSigned IntUGT = IntSGT 62 | adjSigned IntUGE = IntSGE 63 | adjSigned IntULT = IntSLT 64 | adjSigned IntULE = IntSLE 65 | adjSigned p = p 66 | 67 | adjFloat :: IntPredicate -> FPPredicate 68 | adjFloat IntEQ = FPOEQ 69 | adjFloat IntNE = FPONE 70 | adjFloat IntUGT = FPOGT 71 | adjFloat IntUGE = FPOGE 72 | adjFloat IntULT = FPOLT 73 | adjFloat IntULE = FPOLE 74 | adjFloat _ = error "adjFloat" 75 | 76 | infix 4 %==, %/=, %<, %<=, %>=, %> 77 | -- |Comparison functions. 78 | (%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a b) => TValue r a -> TValue r a -> TValue r b 79 | (%==) = binop $ LLVM.cmp CmpEQ 80 | (%/=) = binop $ LLVM.cmp CmpNE 81 | (%>) = binop $ LLVM.cmp CmpGT 82 | (%>=) = binop $ LLVM.cmp CmpGE 83 | (%<) = binop $ LLVM.cmp CmpLT 84 | (%<=) = binop $ LLVM.cmp CmpLE 85 | 86 | infixr 3 %&& 87 | infixr 2 %|| 88 | -- |Lazy and. 89 | (%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool 90 | a %&& b = a ? (b, return (valueOf False)) 91 | -- |Lazy or. 92 | (%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool 93 | a %|| b = a ? (return (valueOf True), b) 94 | 95 | infix 0 ? 96 | -- |Conditional, returns first element of the pair when condition is true, otherwise second. 97 | (?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a 98 | c ? (t, f) = do 99 | lt <- newBasicBlock 100 | lf <- newBasicBlock 101 | lj <- newBasicBlock 102 | c' <- c 103 | condBr c' lt lf 104 | defineBasicBlock lt 105 | rt <- t 106 | lt' <- getCurrentBasicBlock 107 | br lj 108 | defineBasicBlock lf 109 | rf <- f 110 | lf' <- getCurrentBasicBlock 111 | br lj 112 | defineBasicBlock lj 113 | phi [(rt, lt'), (rf, lf')] 114 | 115 | infix 0 ?? 116 | (??) :: (IsFirstClass a, CmpRet a b) => TValue r b -> (TValue r a, TValue r a) -> TValue r a 117 | c ?? (t, f) = do 118 | c' <- c 119 | t' <- t 120 | f' <- f 121 | select c' t' f' 122 | 123 | -- | Return a value from an 'arithFunction'. 124 | retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () 125 | retrn x = x >>= ret 126 | 127 | -- | Use @x <- set $ ...@ to make a binding. 128 | set :: TValue r a -> (CodeGenFunction r (TValue r a)) 129 | set x = do x' <- x; return (return x') 130 | 131 | instance (Show (TValue r a)) 132 | instance (Eq (TValue r a)) 133 | instance (Ord (TValue r a)) 134 | 135 | instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Num (TValue r a) where 136 | (+) = binop add 137 | (-) = binop sub 138 | (*) = binop mul 139 | negate = (>>= neg) 140 | abs x = x %< 0 ?? (-x, x) 141 | signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) 142 | fromInteger = return . valueOf . fromInteger 143 | 144 | instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Enum (TValue r a) where 145 | succ x = x + 1 146 | pred x = x - 1 147 | fromEnum _ = error "CodeGenFunction Value: fromEnum" 148 | toEnum = fromIntegral 149 | 150 | instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (TValue r a) where 151 | toRational _ = error "CodeGenFunction Value: toRational" 152 | 153 | instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where 154 | quot = binop idiv 155 | rem = binop irem 156 | quotRem x y = (quot x y, rem x y) 157 | toInteger _ = error "CodeGenFunction Value: toInteger" 158 | 159 | instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where 160 | (/) = binop fdiv 161 | fromRational = return . valueOf . fromRational 162 | 163 | instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where 164 | properFraction _ = error "CodeGenFunction Value: properFraction" 165 | 166 | instance (Cmp a b, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where 167 | pi = return $ valueOf pi 168 | sqrt = callIntrinsic1 "sqrt" 169 | sin = callIntrinsic1 "sin" 170 | cos = callIntrinsic1 "cos" 171 | (**) = callIntrinsic2 "pow" 172 | exp = callIntrinsic1 "exp" 173 | log = callIntrinsic1 "log" 174 | 175 | asin _ = error "LLVM missing intrinsic: asin" 176 | acos _ = error "LLVM missing intrinsic: acos" 177 | atan _ = error "LLVM missing intrinsic: atan" 178 | 179 | sinh x = (exp x - exp (-x)) / 2 180 | cosh x = (exp x + exp (-x)) / 2 181 | asinh x = log (x + sqrt (x*x + 1)) 182 | acosh x = log (x + sqrt (x*x - 1)) 183 | atanh x = (log (1 + x) - log (1 - x)) / 2 184 | 185 | instance (Cmp a b, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where 186 | floatRadix _ = floatRadix (undefined :: a) 187 | floatDigits _ = floatDigits (undefined :: a) 188 | floatRange _ = floatRange (undefined :: a) 189 | decodeFloat _ = error "CodeGenFunction Value: decodeFloat" 190 | encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat" 191 | exponent _ = 0 192 | scaleFloat 0 x = x 193 | scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat" 194 | isNaN _ = error "CodeGenFunction Value: isNaN" 195 | isInfinite _ = error "CodeGenFunction Value: isInfinite" 196 | isDenormalized _ = error "CodeGenFunction Value: isDenormalized" 197 | isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero" 198 | isIEEE _ = isIEEE (undefined :: a) 199 | 200 | binop :: (Value a -> Value b -> TValue r c) -> 201 | TValue r a -> TValue r b -> TValue r c 202 | binop op x y = do 203 | x' <- x 204 | y' <- y 205 | op x' y' 206 | 207 | {- 208 | If we add the ReadNone attribute, then LLVM-2.8 complains: 209 | 210 | llvm/examples$ Arith_dyn.exe 211 | Attribute readnone only applies to the function! 212 | %2 = call readnone double @llvm.sin.f64(double %0) 213 | Attribute readnone only applies to the function! 214 | %3 = call readnone double @llvm.exp.f64(double %2) 215 | Broken module found, compilation aborted! 216 | Stack dump: 217 | 0. Running pass 'Function Pass Manager' on module '_module'. 218 | 1. Running pass 'Module Verifier' on function '@_fun1' 219 | Aborted 220 | -} 221 | addReadNone :: Value a -> CodeGenFunction r (Value a) 222 | addReadNone x = do 223 | -- addAttributes x 0 [ReadNoneAttribute] 224 | return x 225 | 226 | callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) => 227 | String -> Value a -> TValue r b 228 | callIntrinsicP1 fn x = do 229 | op :: Function (a -> IO b) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a)) 230 | {- 231 | You can add these attributes, 232 | but the verifier pass in the optimizer checks whether they match 233 | the attributes that are declared for that intrinsic. 234 | If we omit adding attributes then the right attributes are added automatically. 235 | addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute] 236 | -} 237 | call op x >>= addReadNone 238 | 239 | callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) => 240 | String -> Value a -> Value b -> TValue r c 241 | callIntrinsicP2 fn x y = do 242 | op :: Function (a -> b -> IO c) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a)) 243 | call op x y >>= addReadNone 244 | 245 | ------------------------------------------- 246 | 247 | class ArithFunction a b | a -> b, b -> a where 248 | arithFunction' :: a -> b 249 | 250 | instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where 251 | arithFunction' x = x >>= ret 252 | 253 | instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where 254 | arithFunction' f = arithFunction' . f . return 255 | 256 | -- |Unlift a function with @TValue@ to have @Value@ arguments. 257 | arithFunction :: ArithFunction a b => a -> b 258 | arithFunction = arithFunction' 259 | 260 | ------------------------------------------- 261 | 262 | class UncurryN a b | a -> b, b -> a where 263 | uncurryN :: a -> b 264 | curryN :: b -> a 265 | 266 | instance UncurryN (CodeGenFunction r a) (() -> CodeGenFunction r a) where 267 | uncurryN i = \ () -> i 268 | curryN f = f () 269 | 270 | instance (UncurryN t (b -> c)) => UncurryN (a -> t) ((a, b) -> c) where 271 | uncurryN f = \ (a, b) -> uncurryN (f a) b 272 | curryN f = \ a -> curryN (\ b -> f (a, b)) 273 | 274 | class LiftTuple r a b | a -> b, b -> a where 275 | liftTuple :: a -> CodeGenFunction r b 276 | 277 | instance LiftTuple r () () where 278 | liftTuple = return 279 | 280 | instance (LiftTuple r b b') => LiftTuple r (CodeGenFunction r a, b) (a, b') where 281 | liftTuple (a, b) = do a' <- a; b' <- liftTuple b; return (a', b') 282 | 283 | class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => 284 | UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where 285 | unwrapArgs :: a2 -> a 286 | instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => 287 | UnwrapArgs a a1 b1 b a2 r where 288 | unwrapArgs f = curryN $ \ x -> do x' <- liftTuple x; uncurryN f x' 289 | 290 | -- |Lift a function from having @Value@ arguments to having @TValue@ arguments. 291 | toArithFunction :: (CallArgs f g r, UnwrapArgs a a1 b1 b g r) => 292 | Function f -> a 293 | toArithFunction f = unwrapArgs (call f) 294 | 295 | ------------------------------------------- 296 | 297 | -- |Define a recursive 'arithFunction', gets passed itself as the first argument. 298 | recursiveFunction :: 299 | (CallArgs a g r0, 300 | UnwrapArgs a11 a1 b1 b g r0, 301 | FunctionArgs a a2 r1, 302 | ArithFunction a3 a2, 303 | IsFunction a) => 304 | (a11 -> a3) -> CodeGenModule (Function a) 305 | recursiveFunction af = do 306 | f <- newFunction ExternalLinkage 307 | let f' = toArithFunction f 308 | defineFunction f $ arithFunction (af f') 309 | return f 310 | 311 | ------------------------------------------- 312 | 313 | class CallIntrinsic a where 314 | callIntrinsic1' :: String -> Value a -> TValue r a 315 | callIntrinsic2' :: String -> Value a -> Value a -> TValue r a 316 | 317 | instance CallIntrinsic Float where 318 | callIntrinsic1' = callIntrinsicP1 319 | callIntrinsic2' = callIntrinsicP2 320 | 321 | instance CallIntrinsic Double where 322 | callIntrinsic1' = callIntrinsicP1 323 | callIntrinsic2' = callIntrinsicP2 324 | 325 | {- 326 | I think such a special case for certain systems 327 | would be better handled as in LLVM.Extra.Extension. 328 | (lemming) 329 | -} 330 | macOS :: Bool 331 | #if defined(__MACOS__) 332 | macOS = True 333 | #else 334 | macOS = False 335 | #endif 336 | 337 | instance (Pos n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where 338 | callIntrinsic1' s x = 339 | if macOS && TypeNum.toInt (undefined :: n) == 4 && 340 | elem s ["sqrt", "log", "exp", "sin", "cos", "tan"] 341 | then do 342 | op <- externFunction ("v" ++ s ++ "f") 343 | call op x >>= addReadNone 344 | else mapVector (callIntrinsic1' s) x 345 | callIntrinsic2' s = mapVector2 (callIntrinsic2' s) 346 | 347 | callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a 348 | callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x' 349 | 350 | callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a 351 | callIntrinsic2 s = binop (callIntrinsic2' s) 352 | -------------------------------------------------------------------------------- /LLVM/Util/File.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where 2 | import System.Cmd(system) 3 | 4 | import LLVM.Core 5 | import LLVM.ExecutionEngine 6 | 7 | writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () 8 | writeCodeGenModule name f = do 9 | m <- newModule 10 | _ <- defineModule m f 11 | writeBitcodeToFile name m 12 | 13 | optimize :: FilePath -> IO () 14 | optimize name = do 15 | _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name 16 | return () 17 | 18 | optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t) 19 | optimizeFunction = fmap snd . optimizeFunction' 20 | 21 | optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t) 22 | optimizeFunction' mdl = do 23 | m <- newModule 24 | mf <- defineModule m mdl 25 | fName <- getValueName mf 26 | 27 | let name = "__tmp__" ++ fName ++ ".bc" 28 | writeBitcodeToFile name m 29 | 30 | optimize name 31 | 32 | m' <- readBitcodeFromFile name 33 | funcs <- getModuleValues m' 34 | 35 | -- removeFile name 36 | 37 | let Just mf' = castModuleValue =<< lookup fName funcs 38 | 39 | return (m', mf') 40 | 41 | optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t 42 | optimizeFunctionCG mdl = do 43 | (m', mf') <- optimizeFunction' mdl 44 | rf <- runEngineAccess $ do 45 | addModule m' 46 | generateFunction mf' 47 | return rf 48 | -------------------------------------------------------------------------------- /LLVM/Util/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- These are replacements for the broken equivalents in Foreign.*. 3 | -- The functions in Foreign.* do not obey the required alignment. 4 | module LLVM.Util.Foreign where 5 | 6 | import Foreign.Ptr(alignPtr, Ptr) 7 | import Foreign.Storable(Storable(poke, sizeOf, alignment)) 8 | import Foreign.Marshal.Alloc(allocaBytes) 9 | import Foreign.Marshal.Array(allocaArray, pokeArray) 10 | 11 | with :: Storable a => a -> (Ptr a -> IO b) -> IO b 12 | with x act = 13 | alloca $ \ p -> do 14 | poke p x 15 | act p 16 | 17 | alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b 18 | alloca act = 19 | allocaBytes (2 * sizeOf (undefined :: a)) $ \ p -> 20 | act $ alignPtr p (alignment (undefined :: a)) 21 | 22 | withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b 23 | withArrayLen xs act = 24 | let l = length xs in 25 | allocaArray (l+1) $ \ p -> do 26 | let p' = alignPtr p (alignment (head xs)) 27 | pokeArray p' xs 28 | act l p' 29 | 30 | -------------------------------------------------------------------------------- /LLVM/Util/Loop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeOperators, FlexibleContexts #-} 2 | module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where 3 | import Data.TypeLevel hiding (Bool) 4 | import LLVM.Core 5 | 6 | class Phi a where 7 | phis :: BasicBlock -> a -> CodeGenFunction r a 8 | addPhis :: BasicBlock -> a -> a -> CodeGenFunction r () 9 | 10 | {- 11 | infixr 1 :* 12 | -- XXX should use HList if it was packaged in a nice way. 13 | data a :* b = a :* b 14 | deriving (Eq, Ord, Show, Read) 15 | 16 | instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where 17 | phis bb (a :* b) = do 18 | a' <- phi [(a, bb)] 19 | b' <- phis bb b 20 | return (a' :* b') 21 | addPhis bb (a :* b) (a' :* b') = do 22 | addPhiInputs a [(a', bb)] 23 | addPhis bb b b' 24 | -} 25 | 26 | instance Phi () where 27 | phis _ _ = return () 28 | addPhis _ _ _ = return () 29 | 30 | instance (IsFirstClass a) => Phi (Value a) where 31 | phis bb a = do 32 | a' <- phi [(a, bb)] 33 | return a' 34 | addPhis bb a a' = do 35 | addPhiInputs a [(a', bb)] 36 | 37 | instance (Phi a, Phi b) => Phi (a, b) where 38 | phis bb (a, b) = do 39 | a' <- phis bb a 40 | b' <- phis bb b 41 | return (a', b') 42 | addPhis bb (a, b) (a', b') = do 43 | addPhis bb a a' 44 | addPhis bb b b' 45 | 46 | instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where 47 | phis bb (a, b, c) = do 48 | a' <- phis bb a 49 | b' <- phis bb b 50 | c' <- phis bb c 51 | return (a', b', c') 52 | addPhis bb (a, b, c) (a', b', c') = do 53 | addPhis bb a a' 54 | addPhis bb b b' 55 | addPhis bb c c' 56 | 57 | -- Loop the index variable from low to high. The state in the loop starts as start, and is modified 58 | -- by incr in each iteration. 59 | forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) => 60 | Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a 61 | forLoop low high start incr = do 62 | top <- getCurrentBasicBlock 63 | loop <- newBasicBlock 64 | body <- newBasicBlock 65 | exit <- newBasicBlock 66 | 67 | br loop 68 | 69 | defineBasicBlock loop 70 | i <- phi [(low, top)] 71 | vars <- phis top start 72 | t <- cmp CmpNE i high 73 | condBr t body exit 74 | 75 | defineBasicBlock body 76 | 77 | vars' <- incr i vars 78 | i' <- add i (valueOf 1 :: Value i) 79 | 80 | body' <- getCurrentBasicBlock 81 | addPhis body' vars vars' 82 | addPhiInputs i [(i', body')] 83 | br loop 84 | defineBasicBlock exit 85 | 86 | return vars 87 | 88 | -------------------------------------- 89 | 90 | mapVector :: forall a b n r . 91 | (Pos n, IsPrimitive b) => 92 | (Value a -> CodeGenFunction r (Value b)) -> 93 | Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) 94 | mapVector f v = 95 | forLoop (valueOf 0) (valueOf (toNum (undefined :: n))) (value undef) $ \ i w -> do 96 | x <- extractelement v i 97 | y <- f x 98 | insertelement w y i 99 | 100 | mapVector2 :: forall a b c n r . 101 | (Pos n, IsPrimitive c) => 102 | (Value a -> Value b -> CodeGenFunction r (Value c)) -> 103 | Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) 104 | mapVector2 f v1 v2 = 105 | forLoop (valueOf 0) (valueOf (toNum (undefined :: n))) (value undef) $ \ i w -> do 106 | x <- extractelement v1 i 107 | y <- extractelement v2 i 108 | z <- f x y 109 | insertelement w z i 110 | -------------------------------------------------------------------------------- /LLVM/Util/Memory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module LLVM.Util.Memory ( 3 | memcpy, 4 | memmove, 5 | memset, 6 | IsLengthType, 7 | ) where 8 | 9 | import LLVM.Core 10 | 11 | import Data.Word (Word8, Word32, Word64, ) 12 | 13 | 14 | class IsFirstClass len => IsLengthType len where 15 | 16 | instance IsLengthType Word32 where 17 | instance IsLengthType Word64 where 18 | 19 | 20 | memcpyFunc :: 21 | forall len. 22 | IsLengthType len => 23 | TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) 24 | memcpyFunc = 25 | newNamedFunction ExternalLinkage $ 26 | "llvm.memcpy.p0i8.p0i8." ++ typeName (undefined :: len) 27 | 28 | memcpy :: 29 | IsLengthType len => 30 | CodeGenModule 31 | (Value (Ptr Word8) -> 32 | Value (Ptr Word8) -> 33 | Value len -> 34 | Value Word32 -> 35 | Value Bool -> 36 | CodeGenFunction r ()) 37 | memcpy = 38 | fmap 39 | (\f dest src len align volatile -> 40 | fmap (const()) $ call f dest src len align volatile) 41 | memcpyFunc 42 | 43 | 44 | memmoveFunc :: 45 | forall len. 46 | IsLengthType len => 47 | TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) 48 | memmoveFunc = 49 | newNamedFunction ExternalLinkage $ 50 | "llvm.memmove.p0i8.p0i8." ++ typeName (undefined :: len) 51 | 52 | memmove :: 53 | IsLengthType len => 54 | CodeGenModule 55 | (Value (Ptr Word8) -> 56 | Value (Ptr Word8) -> 57 | Value len -> 58 | Value Word32 -> 59 | Value Bool -> 60 | CodeGenFunction r ()) 61 | memmove = 62 | fmap 63 | (\f dest src len align volatile -> 64 | fmap (const()) $ call f dest src len align volatile) 65 | memmoveFunc 66 | 67 | 68 | memsetFunc :: 69 | forall len. 70 | IsLengthType len => 71 | TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ()) 72 | memsetFunc = 73 | newNamedFunction ExternalLinkage $ 74 | "llvm.memset.p0i8." ++ typeName (undefined :: len) 75 | 76 | memset :: 77 | IsLengthType len => 78 | CodeGenModule 79 | (Value (Ptr Word8) -> 80 | Value Word8 -> 81 | Value len -> 82 | Value Word32 -> 83 | Value Bool -> 84 | CodeGenFunction r ()) 85 | memset = 86 | fmap 87 | (\f dest val len align volatile -> 88 | fmap (const()) $ call f dest val len align volatile) 89 | memsetFunc 90 | -------------------------------------------------------------------------------- /LLVM/Util/Optimize.hs: -------------------------------------------------------------------------------- 1 | {- 2 | LLVM does not export its functions 3 | @createStandardFunctionPasses@ and 4 | @createStandardModulePasses@ via its C interface 5 | and interfacing to C-C++ wrappers is not very portable. 6 | Thus we reimplement these functions 7 | from @opt.cpp@ and @StandardPasses.h@ in Haskell. 8 | However this way we risk inconsistencies 9 | between 'optimizeModule' and the @opt@ shell command. 10 | -} 11 | module LLVM.Util.Optimize(optimizeModule) where 12 | 13 | import LLVM.Core.Util(Module, withModule) 14 | import qualified LLVM.FFI.Core as FFI 15 | import qualified LLVM.FFI.Support as FFI 16 | import LLVM.FFI.Transforms.Scalar 17 | import Control.Exception (bracket) 18 | 19 | 20 | {- | 21 | Result tells whether the module was modified by any of the passes. 22 | -} 23 | optimizeModule :: Int -> Module -> IO Bool 24 | optimizeModule optLevel mdl = 25 | withModule mdl $ \ m -> 26 | {- 27 | Core.Util.createPassManager would provide a finalizer for us, 28 | but I think it is better here to immediately dispose the manager 29 | when we need it no longer. 30 | -} 31 | bracket FFI.createPassManager FFI.disposePassManager $ \ passes -> 32 | 33 | {- 34 | Note on LLVM-2.6 to 2.8 (at least): 35 | As far as I understand, if we do not set target data, 36 | then the optimizer will only perform machine independent optimizations. 37 | If we set target data 38 | (e.g. an empty layout string obtained from a module without 'target data' specification.) 39 | we risk that the optimizer switches to a wrong layout 40 | (e.g. to 64 bit pointers on a 32 bit machine for empty layout string) 41 | and thus generates corrupt code. 42 | 43 | Currently it seems to be safer to disable 44 | machine dependent optimization completely. 45 | 46 | http://llvm.org/bugs/show_bug.cgi?id=6394 47 | 48 | -- Pass the module target data to the pass manager. 49 | target <- FFI.getDataLayout m >>= createTargetData 50 | addTargetData target passes 51 | -} 52 | 53 | {- 54 | opt.cpp does not use a FunctionPassManager for function optimization, 55 | but a module PassManager. 56 | Thus we do it the same way. 57 | I assume that we would need a FunctionPassManager 58 | only if we wanted to apply individual optimizations to functions. 59 | 60 | fPasses <- FFI.createFunctionPassManager mp 61 | -} 62 | bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do 63 | -- add module target data? 64 | 65 | -- tools/opt/opt.cpp: AddStandardCompilePasses 66 | addVerifierPass passes 67 | addOptimizationPasses passes fPasses optLevel 68 | 69 | {- if we wanted to do so, we could loop through all functions and optimize them. 70 | initializeFunctionPassManager fPasses 71 | runFunctionPassManager fPasses fcn 72 | -} 73 | 74 | functionsModified <- FFI.runPassManager fPasses m 75 | 76 | moduleModified <- FFI.runPassManager passes m 77 | 78 | return $ 79 | toEnum (fromIntegral moduleModified) || 80 | toEnum (fromIntegral functionsModified) 81 | 82 | -- tools/opt/opt.cpp: AddOptimizationPasses 83 | addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () 84 | addOptimizationPasses passes fPasses optLevel = do 85 | createStandardFunctionPasses fPasses optLevel 86 | createStandardModulePasses passes optLevel True True (optLevel > 1) True True True 87 | 88 | createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () 89 | createStandardFunctionPasses fPasses optLevel = 90 | FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) 91 | 92 | -- llvm/Support/StandardPasses.h: createStandardModulePasses 93 | createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () 94 | createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = 95 | FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) 96 | (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) 97 | (f (not inliningPass)) 98 | where f True = 1 99 | f _ = 0 100 | 101 | 102 | {- 103 | ToDo: 104 | Function that adds passes according to a list of opt-options. 105 | This would simplify to get consistent behaviour between opt and optimizeModule. 106 | 107 | -adce addAggressiveDCEPass 108 | -deadargelim addDeadArgEliminationPass 109 | -deadtypeelim addDeadTypeEliminationPass 110 | -dse addDeadStoreEliminationPass 111 | -functionattrs addFunctionAttrsPass 112 | -globalopt addGlobalOptimizerPass 113 | -indvars addIndVarSimplifyPass 114 | -instcombine addInstructionCombiningPass 115 | -ipsccp addIPSCCPPass 116 | -jump-threading addJumpThreadingPass 117 | -licm addLICMPass 118 | -loop-deletion addLoopDeletionPass 119 | -loop-rotate addLoopRotatePass 120 | -memcpyopt addMemCpyOptPass 121 | -prune-eh addPruneEHPass 122 | -reassociate addReassociatePass 123 | -scalarrepl addScalarReplAggregatesPass 124 | -sccp addSCCPPass 125 | -simplifycfg addCFGSimplificationPass 126 | -simplify-libcalls addSimplifyLibCallsPass 127 | -strip-dead-prototypes addStripDeadPrototypesPass 128 | -tailcallelim addTailCallEliminationPass 129 | -verify addVerifierPass 130 | -} 131 | -------------------------------------------------------------------------------- /PROBLEMS.md: -------------------------------------------------------------------------------- 1 | Known problems 2 | -------------- 3 | 4 | If you have solutions to any of the problems listed below, please let 5 | me know, or better yet, send a patch. Thanks! 6 | 7 | 8 | Can't use LLVM bindings from ghci 9 | --------------------------------- 10 | 11 | ghci versions < 7.7 have their own special linker that dynamically 12 | links static libraries rather than using the system dynamic linker. 13 | This is the source of a long history of ffi + ghci bugs, and fundamentally unfixable. 14 | 15 | If you have troubles using llvm with ghci versions >= 7.7 , that is a 16 | bug on the GHCI or llvm-hs sides, please file a bug report so we can resolve it. 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Notice 2 | -------- 3 | 4 | > Please note that this package is deprecated and the Haskell LLVM community has shifted to llvm-hs, which can be found on 5 | [Hackage](http://hackage.haskell.org/package/llvm-hs) and [Github](https://github.com/llvm-hs). 6 | 7 | if you have any questions you can find many members of the Haskell LLVM community on the #haskell-llvm freenode irc channel. 8 | 9 | 10 | Haskell LLVM bindings 11 | --------------------- 12 | 13 | This package provides Haskell bindings for the popular 14 | [LLVM](http://llvm.org/) compiler infrastructure project. 15 | 16 | 17 | Compatibility 18 | ------------- 19 | 20 | We try to stay up to date with LLVM releases. The current version of 21 | this package is compatible with LLVM 2.9 and 2.8. Please understand 22 | that the package may or may not work against older LLVM releases; we 23 | don't have the time or resources to test across multiple releases. 24 | 25 | 26 | Configuration 27 | ------------- 28 | 29 | By default, when you run `cabal install`, the Haskell bindings will be 30 | configured to look for LLVM in `/usr/local`. 31 | 32 | If you have LLVM installed in a different location, e.g. `/usr`, you 33 | can tell the `configure` script where to find it as follows: 34 | 35 | cabal install --configure-option=--with-llvm-prefix=/usr 36 | 37 | 38 | Package status - what to expect 39 | ------------------------------- 40 | 41 | This package is still under development. 42 | 43 | The high level bindings are currently incomplete, so there are some 44 | limits on what you can do. Adding new functions is generally easy, 45 | though, so don't be afraid to get your hands dirty. 46 | 47 | The high level interface is mostly safe, but the type system cannot 48 | protect against everything that can go wrong, so take care. And, of 49 | course, there's no way to guarantee anything about the generated code. 50 | 51 | 52 | Staying in touch 53 | ---------------- 54 | 55 | There is a low-volume mailing list named 56 | [haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm). 57 | If you use the LLVM bindings, you should think about joining. 58 | 59 | If you want to contribute patches, please clone a copy of the 60 | [git repository](https://github.com/bos/llvm): 61 | 62 | git clone git://github.com/bos/llvm 63 | 64 | Patches are best submitted via the github "pull request" interface. 65 | 66 | To file a bug or a request for an enhancement, please use the 67 | [github issue tracker](https://github.com/bos/llvm/issues). 68 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /base/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | #Changes 2 | 3 | ### 06-06-2013 Scott West 4 | - Updated to support more of the LLVM C API, including some global 5 | functions, type functions, and more. 6 | - Added some of the exception handling mechanisms including invoke and 7 | friends. 8 | - Removed LLVM 2.x functions such as TypeHandles which have been removed 9 | in more recent versions of LLVM in favour of Struct types. 10 | - Added check to configure.ac to accept only LLVM 3.x. 11 | -------------------------------------------------------------------------------- /base/INSTALL.md: -------------------------------------------------------------------------------- 1 | Build and installation instructions 2 | ----------------------------------- 3 | 4 | Please don't think of these as canonical build instructions yet, as 5 | this work is rather early along. Let me tell you what's working for 6 | *me*, and hopefully this information will be enough to get you going. 7 | 8 | 9 | Prerequisites 10 | ------------- 11 | 12 | Firstly, you'll need to have LLVM. I recommend installing LLVM 13 | version 2.9 (from [llvm.org](http://llvm.org/releases/)), which is 14 | what this package has mostly been tested with. 15 | 16 | We try to work with both the current and one previous release of LLVM. 17 | 18 | It's easy to install LLVM itself from source: 19 | 20 | cd llvm 21 | ./configure --prefix=$SOMEWHERE 22 | make 23 | make install 24 | 25 | It's a good idea to have `$SOMEWHERE/bin` in your path. 26 | 27 | Installing from source on Windows requires MinGW. 28 | 29 | 30 | Building 31 | -------- 32 | 33 | (*Note*: If you're building from a clone of the `git` repository 34 | rather than a release, you *must* run `autoreconf` before you can 35 | build!) 36 | 37 | This is a normal Haskell package, but needs a `configure` script to 38 | configure some system-specific details of LLVM. 39 | 40 | If you have LLVM installed in a fairly normal location (`/usr` or 41 | `/usr/local`), the usual install command should just work: 42 | 43 | cabal install 44 | 45 | On the other hand, if you've installed LLVM in an unusual place, 46 | you'll need some `--configure-option` magic to tell the build where to 47 | find it: 48 | 49 | cabal install --configure-option --with-llvm-prefix=$SOMEWHERE 50 | 51 | 52 | Building examples 53 | ----------------- 54 | 55 | In the `examples` directory are a few example programs. There's a GNU 56 | Makefile in there, so running `make` in that directory will build the 57 | examples, as will `make examples` in the top-level directory. Doing 58 | `make run` will build and run the examples. 59 | 60 | Note: On older versions of MacOS X you may see a lot of "atom sorting 61 | error" warnings. They seem to be harmless. 62 | -------------------------------------------------------------------------------- /base/LICENSE: -------------------------------------------------------------------------------- 1 | ====================================================================== 2 | Haskell LLVM Bindings Release License 3 | ====================================================================== 4 | University of Illinois/NCSA 5 | Open Source License 6 | 7 | Copyright (c) 2007-2009 Bryan O'Sullivan 8 | All rights reserved. 9 | 10 | Developed by: 11 | 12 | Bryan O'Sullivan 13 | http://www.serpentine.com/blog/ 14 | 15 | Lennart Augustsson 16 | 17 | Permission is hereby granted, free of charge, to any person obtaining 18 | a copy of this software and associated documentation files (the 19 | "Software"), to deal with the Software without restriction, including 20 | without limitation the rights to use, copy, modify, merge, publish, 21 | distribute, sublicense, and/or sell copies of the Software, and to 22 | permit persons to whom the Software is furnished to do so, subject to 23 | the following conditions: 24 | 25 | * Redistributions of source code must retain the above copyright 26 | notice, this list of conditions and the following disclaimers. 27 | 28 | * Redistributions in binary form must reproduce the above 29 | copyright notice, this list of conditions and the following 30 | disclaimers in the documentation and/or other materials provided 31 | with the distribution. 32 | 33 | * Neither the names of Bryan O'Sullivan, University of Illinois at 34 | Urbana-Champaign, nor the names of its contributors may be used 35 | to endorse or promote products derived from this Software 36 | without specific prior written permission. 37 | 38 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 39 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 40 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 41 | IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR 42 | ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 43 | CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 44 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. 45 | 46 | ====================================================================== 47 | Copyrights and Licenses for Third Party Software Distributed with 48 | Haskell LLVM Bindings: 49 | ====================================================================== 50 | 51 | The Haskell LLVM Bindings software may contain code written by third 52 | parties. Any such software will have its own individual license file 53 | in the directory in which it appears. This file will describe the 54 | copyrights, license, and restrictions which apply to that code. 55 | 56 | The disclaimer of warranty in the University of Illinois Open Source 57 | License applies to all code in the Haskell LLVM Bindings Distribution, 58 | and nothing in any of the other licenses gives permission to use the 59 | name of Bryan O'Sullivan or the University of Illinois to endorse or 60 | promote products derived from this Software. 61 | 62 | The following pieces of software have additional or alternate 63 | copyrights, licenses, and/or restrictions: 64 | 65 | Program Directory 66 | ------- --------- 67 | configure . 68 | 69 | 70 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Analysis.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.Analysis where 4 | import Foreign.C.String(CString) 5 | #if __GLASGOW_HASKELL__ >= 704 6 | import Foreign.C.Types(CInt(..)) 7 | #else 8 | import Foreign.C.Types(CInt) 9 | #endif 10 | import Foreign.Ptr(Ptr) 11 | 12 | import LLVM.FFI.Core 13 | 14 | type VerifierFailureAction = CInt 15 | 16 | foreign import ccall unsafe "LLVMVerifyFunction" verifyFunction 17 | :: ValueRef -> VerifierFailureAction -> IO CInt 18 | foreign import ccall unsafe "LLVMVerifyModule" verifyModule 19 | :: ModuleRef -> VerifierFailureAction -> (Ptr CString) -> IO CInt 20 | foreign import ccall unsafe "LLVMViewFunctionCFG" viewFunctionCFG 21 | :: ValueRef -> IO () 22 | foreign import ccall unsafe "LLVMViewFunctionCFGOnly" viewFunctionCFGOnly 23 | :: ValueRef -> IO () 24 | -------------------------------------------------------------------------------- /base/LLVM/FFI/AssemblyReader.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.AssemblyReader where 4 | import Foreign.C.String(CString) 5 | #if __GLASGOW_HASKELL__ >= 704 6 | import Foreign.C.Types(CInt(..)) 7 | #else 8 | import Foreign.C.Types(CInt) 9 | #endif 10 | import Foreign.Ptr(Ptr) 11 | 12 | import LLVM.FFI.Core 13 | 14 | foreign import ccall unsafe "LLVMGetModuleFromAssembly" getModuleFromAssembly 15 | :: CString -> CInt -> Ptr CString -> IO ModuleRef 16 | -------------------------------------------------------------------------------- /base/LLVM/FFI/BitReader.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.BitReader where 4 | import Foreign.C.String(CString) 5 | #if __GLASGOW_HASKELL__ >= 704 6 | import Foreign.C.Types(CInt(..)) 7 | #else 8 | import Foreign.C.Types(CInt) 9 | #endif 10 | import Foreign.Ptr(Ptr) 11 | 12 | import LLVM.FFI.Core 13 | 14 | foreign import ccall unsafe "LLVMGetBitcodeModuleProvider" getBitcodeModuleProvider 15 | :: MemoryBufferRef -> (Ptr ModuleProviderRef) -> (Ptr CString) -> IO CInt 16 | foreign import ccall unsafe "LLVMParseBitcode" parseBitcode 17 | :: MemoryBufferRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt 18 | foreign import ccall unsafe "LLVMGetBitcodeModuleProviderInContext" getBitcodeModuleProviderInContext 19 | :: ContextRef -> MemoryBufferRef -> (Ptr ModuleProviderRef) -> (Ptr CString) -> IO CInt 20 | foreign import ccall unsafe "LLVMParseBitcodeInContext" parseBitcodeInContext 21 | :: ContextRef -> MemoryBufferRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt 22 | foreign import ccall unsafe "LLVMGetBitcodeModule" getBitcodeModule 23 | :: MemoryBufferRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt 24 | foreign import ccall unsafe "LLVMGetBitcodeModuleInContext" getBitcodeModuleInContext 25 | :: ContextRef -> MemoryBufferRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt 26 | -------------------------------------------------------------------------------- /base/LLVM/FFI/BitWriter.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.BitWriter where 4 | import Foreign.C.String(CString) 5 | #if __GLASGOW_HASKELL__ >= 704 6 | import Foreign.C.Types(CInt(..)) 7 | #else 8 | import Foreign.C.Types(CInt) 9 | #endif 10 | 11 | import LLVM.FFI.Core 12 | 13 | foreign import ccall unsafe "LLVMWriteBitcodeToFile" writeBitcodeToFile 14 | :: ModuleRef -> CString -> IO CInt 15 | foreign import ccall unsafe "LLVMWriteBitcodeToFileHandle" writeBitcodeToFileHandle 16 | :: ModuleRef -> CInt -> IO CInt 17 | foreign import ccall unsafe "LLVMWriteBitcodeToFD" writeBitcodeToFD 18 | :: ModuleRef -> CInt -> CInt -> CInt -> IO CInt 19 | -------------------------------------------------------------------------------- /base/LLVM/FFI/ExecutionEngine.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-} 2 | 3 | module LLVM.FFI.ExecutionEngine 4 | ( 5 | -- * Execution engines 6 | ExecutionEngine 7 | , createExecutionEngine 8 | , ptrDisposeExecutionEngine 9 | , createInterpreter 10 | , createJITCompiler 11 | , addModuleProvider 12 | , removeModuleProvider 13 | , findFunction 14 | , freeMachineCodeForFunction 15 | , runStaticConstructors 16 | , runStaticDestructors 17 | , runFunction 18 | , runFunctionAsMain 19 | , getExecutionEngineTargetData 20 | , addGlobalMapping 21 | , getPointerToGlobal 22 | 23 | , addModule 24 | , createExecutionEngineForModule 25 | , createInterpreterForModule 26 | , createJITCompilerForModule 27 | , disposeExecutionEngine 28 | , removeModule 29 | 30 | -- * Generic values 31 | , GenericValue 32 | , GenericValueRef 33 | , createGenericValueOfInt 34 | , genericValueToInt 35 | , genericValueIntWidth 36 | , createGenericValueOfFloat 37 | , genericValueToFloat 38 | , createGenericValueOfPointer 39 | , genericValueToPointer 40 | , ptrDisposeGenericValue 41 | 42 | -- * Linking 43 | -- , linkInInterpreter 44 | , linkInJIT 45 | ) where 46 | import Data.Typeable 47 | import Foreign.C.String (CString) 48 | #if __GLASGOW_HASKELL__ >= 704 49 | import Foreign.C.Types (CDouble(..), CInt(..), CUInt(..), CULLong(..)) 50 | #else 51 | import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) 52 | #endif 53 | import Foreign.Ptr (Ptr, FunPtr) 54 | 55 | import LLVM.FFI.Core (ModuleRef, ModuleProviderRef, TypeRef, ValueRef) 56 | import LLVM.FFI.Target(TargetDataRef) 57 | 58 | data ExecutionEngine 59 | deriving (Typeable) 60 | type ExecutionEngineRef = Ptr ExecutionEngine 61 | 62 | foreign import ccall unsafe "LLVMCreateExecutionEngine" createExecutionEngine 63 | :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString 64 | -> IO CInt 65 | 66 | foreign import ccall unsafe "&LLVMDisposeExecutionEngine" ptrDisposeExecutionEngine 67 | :: FunPtr (ExecutionEngineRef -> IO ()) 68 | 69 | foreign import ccall unsafe "LLVMRunStaticConstructors" runStaticConstructors 70 | :: ExecutionEngineRef -> IO () 71 | 72 | foreign import ccall unsafe "LLVMRunStaticDestructors" runStaticDestructors 73 | :: ExecutionEngineRef -> IO () 74 | 75 | 76 | data GenericValue 77 | deriving (Typeable) 78 | type GenericValueRef = Ptr GenericValue 79 | 80 | foreign import ccall unsafe "LLVMCreateGenericValueOfInt" 81 | createGenericValueOfInt :: TypeRef -> CULLong -> CInt 82 | -> IO GenericValueRef 83 | 84 | foreign import ccall unsafe "LLVMGenericValueToInt" genericValueToInt 85 | :: GenericValueRef -> CInt -> CULLong 86 | 87 | foreign import ccall unsafe "LLVMCreateGenericValueOfFloat" 88 | createGenericValueOfFloat :: TypeRef -> CDouble -> IO GenericValueRef 89 | 90 | foreign import ccall unsafe "LLVMGenericValueToFloat" genericValueToFloat 91 | :: TypeRef -> GenericValueRef -> CDouble 92 | 93 | foreign import ccall unsafe "&LLVMDisposeGenericValue" ptrDisposeGenericValue 94 | :: FunPtr (GenericValueRef -> IO ()) 95 | 96 | {- 97 | safe call is important, since the running LLVM code may call back into Haskell code 98 | 99 | See 100 | http://www.cse.unsw.edu.au/~chak/haskell/ffi/ffi/ffise3.html#x6-130003.3 says: 101 | 102 | "Optionally, an import declaration can specify, 103 | after the calling convention, 104 | the safety level that should be used when invoking an external entity. 105 | ..." 106 | -} 107 | foreign import ccall safe "LLVMRunFunction" runFunction 108 | :: ExecutionEngineRef -> ValueRef -> CUInt 109 | -> Ptr GenericValueRef -> IO GenericValueRef 110 | 111 | foreign import ccall unsafe "LLVMAddModuleProvider" addModuleProvider 112 | :: ExecutionEngineRef -> ModuleProviderRef -> IO () 113 | foreign import ccall unsafe "LLVMCreateGenericValueOfPointer" 114 | createGenericValueOfPointer :: Ptr a -> IO GenericValueRef 115 | foreign import ccall unsafe "LLVMCreateInterpreter" createInterpreter 116 | :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString -> IO CInt 117 | foreign import ccall unsafe "LLVMCreateJITCompiler" createJITCompiler 118 | :: Ptr ExecutionEngineRef -> ModuleProviderRef -> CUInt -> Ptr CString -> IO CInt 119 | foreign import ccall unsafe "LLVMFindFunction" findFunction 120 | :: ExecutionEngineRef -> CString -> Ptr ValueRef -> IO CInt 121 | foreign import ccall unsafe "LLVMFreeMachineCodeForFunction" 122 | freeMachineCodeForFunction :: ExecutionEngineRef -> ValueRef -> IO () 123 | foreign import ccall unsafe "LLVMGenericValueIntWidth" genericValueIntWidth 124 | :: GenericValueRef -> IO CUInt 125 | foreign import ccall unsafe "LLVMGenericValueToPointer" genericValueToPointer 126 | :: GenericValueRef -> IO (Ptr a) 127 | foreign import ccall unsafe "LLVMRemoveModuleProvider" removeModuleProvider 128 | :: ExecutionEngineRef -> ModuleProviderRef -> Ptr ModuleRef -> Ptr CString 129 | -> IO CInt 130 | foreign import ccall safe "LLVMRunFunctionAsMain" runFunctionAsMain 131 | :: ExecutionEngineRef -> ValueRef -> CUInt 132 | -> Ptr CString -- ^ argv 133 | -> Ptr CString -- ^ envp 134 | -> IO CInt 135 | 136 | foreign import ccall unsafe "LLVMGetExecutionEngineTargetData" getExecutionEngineTargetData 137 | :: ExecutionEngineRef -> IO TargetDataRef 138 | foreign import ccall unsafe "LLVMAddGlobalMapping" addGlobalMapping 139 | :: ExecutionEngineRef -> ValueRef -> Ptr () -> IO () 140 | 141 | foreign import ccall unsafe "LLVMGetPointerToGlobal" getPointerToGlobal 142 | :: ExecutionEngineRef -> ValueRef -> IO (FunPtr a) 143 | 144 | {- 145 | foreign import ccall unsafe "LLVMLinkInInterpreter" linkInInterpreter 146 | :: IO () 147 | -} 148 | foreign import ccall unsafe "LLVMLinkInJIT" linkInJIT 149 | :: IO () 150 | 151 | foreign import ccall unsafe "LLVMAddModule" addModule 152 | :: ExecutionEngineRef -> ModuleRef -> IO () 153 | foreign import ccall unsafe "LLVMCreateExecutionEngineForModule" createExecutionEngineForModule 154 | :: (Ptr ExecutionEngineRef) -> ModuleRef -> (Ptr CString) -> IO CInt 155 | foreign import ccall unsafe "LLVMCreateInterpreterForModule" createInterpreterForModule 156 | :: (Ptr ExecutionEngineRef) -> ModuleRef -> (Ptr CString) -> IO CInt 157 | foreign import ccall unsafe "LLVMCreateJITCompilerForModule" createJITCompilerForModule 158 | :: (Ptr ExecutionEngineRef) -> ModuleRef -> CUInt -> (Ptr CString) -> IO CInt 159 | foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine 160 | :: ExecutionEngineRef -> IO () 161 | {- 162 | foreign import ccall unsafe "LLVMDisposeGenericValue" disposeGenericValue 163 | :: GenericValueRef -> IO () 164 | -} 165 | foreign import ccall unsafe "LLVMRemoveModule" removeModule 166 | :: ExecutionEngineRef -> ModuleRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt 167 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Linker.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 | 3 | module LLVM.FFI.Linker where 4 | import LLVM.FFI.Core 5 | import Foreign.C.String(CString) 6 | import Foreign.C.Types(CUInt(..), CInt(..)) 7 | import Foreign.Ptr(Ptr) 8 | 9 | #if LLVM_HS_VERSION > 301 10 | #include 11 | #else 12 | #define LLVMLinkerDestroySource 0 13 | #define LLVMLinkerPreserveSource 1 14 | #endif 15 | 16 | data LinkerMode = DestroySource | PreserveSource 17 | deriving (Show, Eq) 18 | 19 | fromLinkerMode :: LinkerMode -> CUInt 20 | fromLinkerMode DestroySource = (#const LLVMLinkerDestroySource) 21 | fromLinkerMode PreserveSource = (#const LLVMLinkerDestroySource) 22 | 23 | toLinkerMode :: CUInt -> LinkerMode 24 | toLinkerMode c | c == (#const LLVMLinkerDestroySource) = DestroySource 25 | toLinkerMode c | c == (#const LLVMLinkerPreserveSource) = PreserveSource 26 | toLinkerMode c = error $ "LLVM.FFI.Linker.toLinkerMode: unrecognized linker mode" ++ show c 27 | 28 | foreign import ccall unsafe "LLVMLinkModules" linkModules 29 | :: ModuleRef -> ModuleRef -> CUInt -> Ptr CString -> IO CInt -------------------------------------------------------------------------------- /base/LLVM/FFI/Support.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 | 3 | module LLVM.FFI.Support 4 | ( 5 | createStandardModulePasses 6 | , createStandardFunctionPasses 7 | , addEmitObjectPass 8 | , disablePrettyStackTrace 9 | ) where 10 | 11 | #if __GLASGOW_HASKELL__ >= 704 12 | import Foreign.C.Types (CInt(..), CUInt(..)) 13 | #else 14 | import Foreign.C.Types (CInt, CUInt) 15 | #endif 16 | import Foreign.C.String (CString) 17 | import LLVM.FFI.Core (PassManagerRef, ModuleRef) 18 | 19 | foreign import ccall unsafe "LLVMCreateStandardFunctionPasses" createStandardFunctionPasses 20 | :: PassManagerRef -> CUInt -> IO () 21 | 22 | foreign import ccall unsafe "LLVMCreateStandardModulePasses" createStandardModulePasses 23 | :: PassManagerRef -> CUInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO () 24 | 25 | foreign import ccall unsafe "LLVMAddEmitObjectPass" addEmitObjectPass 26 | :: ModuleRef -> CString -> IO CUInt 27 | 28 | foreign import ccall unsafe "LLVMDisablePrettyStackTrace" disablePrettyStackTrace 29 | :: IO () 30 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Target.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-} 2 | 3 | module LLVM.FFI.Target where 4 | import Data.Typeable 5 | import Foreign.C.String (CString) 6 | #if __GLASGOW_HASKELL__ >= 704 7 | import Foreign.C.Types (CInt(..), CUInt(..), CULLong(..)) 8 | #else 9 | import Foreign.C.Types (CInt, CUInt, CULLong) 10 | #endif 11 | import Foreign.Ptr (Ptr) 12 | 13 | import LLVM.FFI.Core 14 | 15 | -- enum { LLVMBigEndian, LLVMLittleEndian }; 16 | type ByteOrdering = CInt 17 | 18 | data TargetData 19 | deriving (Typeable) 20 | type TargetDataRef = Ptr TargetData 21 | 22 | foreign import ccall unsafe "LLVMABIAlignmentOfType" aBIAlignmentOfType 23 | :: TargetDataRef -> TypeRef -> CUInt 24 | foreign import ccall unsafe "LLVMABISizeOfType" aBISizeOfType 25 | :: TargetDataRef -> TypeRef -> CULLong 26 | foreign import ccall unsafe "LLVMAddTargetData" addTargetData 27 | :: TargetDataRef -> PassManagerRef -> IO () 28 | foreign import ccall unsafe "LLVMByteOrder" byteOrder 29 | :: TargetDataRef -> ByteOrdering 30 | foreign import ccall unsafe "LLVMCallFrameAlignmentOfType" callFrameAlignmentOfType 31 | :: TargetDataRef -> TypeRef -> CUInt 32 | foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" copyStringRepOfTargetData 33 | :: TargetDataRef -> IO CString 34 | foreign import ccall unsafe "LLVMCreateTargetData" createTargetData 35 | :: CString -> IO TargetDataRef 36 | foreign import ccall unsafe "LLVMDisposeTargetData" disposeTargetData 37 | :: TargetDataRef -> IO () 38 | foreign import ccall unsafe "LLVMElementAtOffset" elementAtOffset 39 | :: TargetDataRef -> TypeRef -> CULLong -> CUInt 40 | foreign import ccall unsafe "LLVMIntPtrType" intPtrType 41 | :: TargetDataRef -> TypeRef 42 | -- Removed in LLVM_3.0 ? 43 | -- foreign import ccall unsafe "LLVMInvalidateStructLayout" invalidateStructLayout 44 | -- :: TargetDataRef -> TypeRef -> IO () 45 | foreign import ccall unsafe "LLVMOffsetOfElement" offsetOfElement 46 | :: TargetDataRef -> TypeRef -> CUInt -> CULLong 47 | foreign import ccall unsafe "LLVMPointerSize" pointerSize 48 | :: TargetDataRef -> CUInt 49 | foreign import ccall unsafe "LLVMPreferredAlignmentOfGlobal" preferredAlignmentOfGlobal 50 | :: TargetDataRef -> ValueRef -> CUInt 51 | foreign import ccall unsafe "LLVMPreferredAlignmentOfType" preferredAlignmentOfType 52 | :: TargetDataRef -> TypeRef -> CUInt 53 | foreign import ccall unsafe "LLVMSizeOfTypeInBits" sizeOfTypeInBits 54 | :: TargetDataRef -> TypeRef -> CULLong 55 | foreign import ccall unsafe "LLVMStoreSizeOfType" storeSizeOfType 56 | :: TargetDataRef -> TypeRef -> CULLong 57 | 58 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Transforms/IPO.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.Transforms.IPO where 4 | 5 | import LLVM.FFI.Core 6 | 7 | foreign import ccall unsafe "LLVMAddArgumentPromotionPass" addArgumentPromotionPass 8 | :: PassManagerRef -> IO () 9 | foreign import ccall unsafe "LLVMAddConstantMergePass" addConstantMergePass 10 | :: PassManagerRef -> IO () 11 | foreign import ccall unsafe "LLVMAddDeadArgEliminationPass" addDeadArgEliminationPass 12 | :: PassManagerRef -> IO () 13 | foreign import ccall unsafe "LLVMAddFunctionAttrsPass" addFunctionAttrsPass 14 | :: PassManagerRef -> IO () 15 | foreign import ccall unsafe "LLVMAddFunctionInliningPass" addFunctionInliningPass 16 | :: PassManagerRef -> IO () 17 | foreign import ccall unsafe "LLVMAddGlobalDCEPass" addGlobalDCEPass 18 | :: PassManagerRef -> IO () 19 | foreign import ccall unsafe "LLVMAddGlobalOptimizerPass" addGlobalOptimizerPass 20 | :: PassManagerRef -> IO () 21 | foreign import ccall unsafe "LLVMAddIPConstantPropagationPass" addIPConstantPropagationPass 22 | :: PassManagerRef -> IO () 23 | foreign import ccall unsafe "LLVMAddPruneEHPass" addPruneEHPass 24 | :: PassManagerRef -> IO () 25 | foreign import ccall unsafe "LLVMAddIPSCCPPass" addIPSCCPPass 26 | :: PassManagerRef -> IO () 27 | foreign import ccall unsafe "LLVMAddStripDeadPrototypesPass" addStripDeadPrototypesPass 28 | :: PassManagerRef -> IO () 29 | foreign import ccall unsafe "LLVMAddStripSymbolsPass" addStripSymbolsPass 30 | :: PassManagerRef -> IO () 31 | foreign import ccall unsafe "LLVMAddAlwaysInlinerPass" addAlwaysInlinerPass 32 | :: PassManagerRef -> IO () 33 | foreign import ccall unsafe "LLVMAddInternalizePass" addInternalizePass 34 | :: PassManagerRef -> IO () 35 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Transforms/PassManagerBuilder.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-} 2 | module LLVM.FFI.Transforms.PassManagerBuilder where 3 | 4 | import Foreign.C.Types 5 | import Foreign.Ptr (Ptr, FunPtr) 6 | import Data.Typeable(Typeable) 7 | 8 | import LLVM.FFI.Core 9 | 10 | data PassManagerBuilder 11 | deriving (Typeable) 12 | type PassManagerBuilderRef = Ptr PassManagerBuilder 13 | 14 | foreign import ccall unsafe "LLVMPassManagerBuilderCreate" passManagerBuilderCreate 15 | :: IO PassManagerBuilderRef 16 | 17 | foreign import ccall unsafe "LLVMPassManagerBuilderDispose" passManagerBuilderDispose 18 | :: PassManagerBuilderRef -> IO () 19 | 20 | foreign import ccall unsafe "&LLVMPassManagerBuilderDispose" ptrPassManagerBuilderDispose 21 | :: FunPtr (PassManagerBuilderRef -> IO ()) 22 | 23 | foreign import ccall unsafe "LLVMPassManagerBuilderSetOptLevel" passManagerBuilderSetOptLevel 24 | :: PassManagerBuilderRef -> CUInt -> IO () 25 | 26 | foreign import ccall unsafe "LLVMPassManagerBuilderSetSizeLevel" passManagerBuilderSetSizeLevel 27 | :: PassManagerBuilderRef -> CUInt -> IO () 28 | 29 | foreign import ccall unsafe "LLVMPassManagerBuilderPopulateFunctionPassManager" passManagerBuilderPopulateFunctionPassManager 30 | :: PassManagerBuilderRef -> PassManagerRef -> IO () 31 | 32 | foreign import ccall unsafe "LLVMPassManagerBuilderPopulateModulePassManager" passManagerBuilderPopulateModulePassManager 33 | :: PassManagerBuilderRef -> PassManagerRef -> IO () 34 | 35 | foreign import ccall unsafe "LLVMPassManagerBuilderPopulateLTOPassManager" passManagerBuilderPopulateLTOPassManager 36 | :: PassManagerBuilderRef -> PassManagerRef -> CInt -> CInt -> IO () 37 | -------------------------------------------------------------------------------- /base/LLVM/FFI/Transforms/Scalar.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} 2 | 3 | module LLVM.FFI.Transforms.Scalar where 4 | 5 | import LLVM.FFI.Core 6 | 7 | foreign import ccall unsafe "LLVMAddCFGSimplificationPass" addCFGSimplificationPass 8 | :: PassManagerRef -> IO () 9 | foreign import ccall unsafe "LLVMAddConstantPropagationPass" addConstantPropagationPass 10 | :: PassManagerRef -> IO () 11 | foreign import ccall unsafe "LLVMAddDemoteMemoryToRegisterPass" addDemoteMemoryToRegisterPass 12 | :: PassManagerRef -> IO () 13 | foreign import ccall unsafe "LLVMAddGVNPass" addGVNPass 14 | :: PassManagerRef -> IO () 15 | foreign import ccall unsafe "LLVMAddInstructionCombiningPass" addInstructionCombiningPass 16 | :: PassManagerRef -> IO () 17 | foreign import ccall unsafe "LLVMAddPromoteMemoryToRegisterPass" addPromoteMemoryToRegisterPass 18 | :: PassManagerRef -> IO () 19 | foreign import ccall unsafe "LLVMAddReassociatePass" addReassociatePass 20 | :: PassManagerRef -> IO () 21 | foreign import ccall unsafe "LLVMAddAggressiveDCEPass" addAggressiveDCEPass 22 | :: PassManagerRef -> IO () 23 | foreign import ccall unsafe "LLVMAddDeadStoreEliminationPass" addDeadStoreEliminationPass 24 | :: PassManagerRef -> IO () 25 | foreign import ccall unsafe "LLVMAddIndVarSimplifyPass" addIndVarSimplifyPass 26 | :: PassManagerRef -> IO () 27 | foreign import ccall unsafe "LLVMAddJumpThreadingPass" addJumpThreadingPass 28 | :: PassManagerRef -> IO () 29 | foreign import ccall unsafe "LLVMAddLICMPass" addLICMPass 30 | :: PassManagerRef -> IO () 31 | foreign import ccall unsafe "LLVMAddLoopDeletionPass" addLoopDeletionPass 32 | :: PassManagerRef -> IO () 33 | foreign import ccall unsafe "LLVMAddLoopRotatePass" addLoopRotatePass 34 | :: PassManagerRef -> IO () 35 | foreign import ccall unsafe "LLVMAddLoopUnrollPass" addLoopUnrollPass 36 | :: PassManagerRef -> IO () 37 | foreign import ccall unsafe "LLVMAddLoopUnswitchPass" addLoopUnswitchPass 38 | :: PassManagerRef -> IO () 39 | foreign import ccall unsafe "LLVMAddMemCpyOptPass" addMemCpyOptPass 40 | :: PassManagerRef -> IO () 41 | foreign import ccall unsafe "LLVMAddSCCPPass" addSCCPPass 42 | :: PassManagerRef -> IO () 43 | foreign import ccall unsafe "LLVMAddScalarReplAggregatesPass" addScalarReplAggregatesPass 44 | :: PassManagerRef -> IO () 45 | foreign import ccall unsafe "LLVMAddSimplifyLibCallsPass" addSimplifyLibCallsPass 46 | :: PassManagerRef -> IO () 47 | foreign import ccall unsafe "LLVMAddTailCallEliminationPass" addTailCallEliminationPass 48 | :: PassManagerRef -> IO () 49 | foreign import ccall unsafe "LLVMAddVerifierPass" addVerifierPass 50 | :: PassManagerRef -> IO () 51 | foreign import ccall unsafe "LLVMAddLoopIdiomPass" addLoopIdiomPass 52 | :: PassManagerRef -> IO () 53 | foreign import ccall unsafe "LLVMAddScalarReplAggregatesPassSSA" addScalarReplAggregatesPassSSA 54 | :: PassManagerRef -> IO () 55 | foreign import ccall unsafe "LLVMAddScalarReplAggregatesPassWithThreshold" addScalarReplAggregatesPassWithThreshold 56 | :: PassManagerRef -> IO () 57 | foreign import ccall unsafe "LLVMAddCorrelatedValuePropagationPass" addCorrelatedValuePropagationPass 58 | :: PassManagerRef -> IO () 59 | foreign import ccall unsafe "LLVMAddEarlyCSEPass" addEarlyCSEPass 60 | :: PassManagerRef -> IO () 61 | foreign import ccall unsafe "LLVMAddLowerExpectIntrinsicPass" addLowerExpectIntrinsicPass 62 | :: PassManagerRef -> IO () 63 | foreign import ccall unsafe "LLVMAddTypeBasedAliasAnalysisPass" addTypeBasedAliasAnalysisPass 64 | :: PassManagerRef -> IO () 65 | foreign import ccall unsafe "LLVMAddBasicAliasAnalysisPass" addBasicAliasAnalysisPass 66 | :: PassManagerRef -> IO () 67 | -------------------------------------------------------------------------------- /base/LLVM/Target/ARM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.ARM(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeARMTargetInfo 7 | initializeARMTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeARMTargetInfo" initializeARMTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeARMTarget" initializeARMTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/CellSPU.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.CellSPU(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeCellSPUTargetInfo 7 | initializeCellSPUTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeCellSPUTargetInfo" initializeCellSPUTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeCellSPUTarget" initializeCellSPUTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/CppBackend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.CppBackend(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeCppBackendTargetInfo 7 | initializeCppBackendTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeCppBackendTargetInfo" initializeCppBackendTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeCppBackendTarget" initializeCppBackendTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/MSP430.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.MSP430(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeMSP430TargetInfo 7 | initializeMSP430Target 8 | 9 | foreign import ccall unsafe "LLVMInitializeMSP430TargetInfo" initializeMSP430TargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeMSP430Target" initializeMSP430Target :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/Mips.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.Mips(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeMipsTargetInfo 7 | initializeMipsTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeMipsTargetInfo" initializeMipsTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeMipsTarget" initializeMipsTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/Native.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 | module LLVM.Target.Native(initializeNativeTarget) where 3 | import Control.Monad 4 | import Control.Concurrent.MVar 5 | import System.IO.Unsafe 6 | 7 | import Foreign.C.Types 8 | 9 | -- TARGET is expanded by CPP to the native target architecture. 10 | import LLVM.Target.TARGET 11 | 12 | foreign import ccall unsafe "LLVMInitNativeTarget" 13 | llvmInitializeNativeTarget :: IO CUInt 14 | 15 | -- | Initialize jitter to the native target. 16 | -- The operation is idempotent. 17 | initializeNativeTarget :: IO () 18 | initializeNativeTarget = do 19 | done <- takeMVar refDone 20 | when (not done) (llvmInitializeNativeTarget >> return ()) -- initializeTarget 21 | putMVar refDone True 22 | 23 | -- UNSAFE: global variable to keep track of initialization state. 24 | refDone :: MVar Bool 25 | refDone = unsafePerformIO $ newMVar False 26 | -------------------------------------------------------------------------------- /base/LLVM/Target/PowerPC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.PowerPC(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializePowerPCTargetInfo 7 | initializePowerPCTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializePowerPCTargetInfo" initializePowerPCTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializePowerPCTarget" initializePowerPCTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/Sparc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.Sparc(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeSparcTargetInfo 7 | initializeSparcTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeSparcTargetInfo" initializeSparcTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeSparcTarget" initializeSparcTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/X86.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.X86(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeX86TargetInfo 7 | initializeX86Target 8 | 9 | foreign import ccall unsafe "LLVMInitializeX86TargetInfo" initializeX86TargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeX86Target" initializeX86Target :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Target/XCore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module LLVM.Target.XCore(initializeTarget) where 3 | 4 | initializeTarget :: IO () 5 | initializeTarget = do 6 | initializeXCoreTargetInfo 7 | initializeXCoreTarget 8 | 9 | foreign import ccall unsafe "LLVMInitializeXCoreTargetInfo" initializeXCoreTargetInfo :: IO () 10 | foreign import ccall unsafe "LLVMInitializeXCoreTarget" initializeXCoreTarget :: IO () 11 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/Analysis.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.Analysis where 2 | 3 | import qualified LLVM.FFI.Analysis as FFI 4 | import qualified LLVM.FFI.Core as FFI 5 | import LLVM.Wrapper.Core 6 | import LLVM.Wrapper.Internal 7 | 8 | import Foreign.C.String (peekCString) 9 | import Foreign.Marshal.Alloc (alloca) 10 | import Foreign.Marshal.Utils (toBool) 11 | import Foreign.Storable (peek) 12 | import Foreign.ForeignPtr.Safe (withForeignPtr) 13 | 14 | -- VerifierFailureAction 2 is 'no side effects' 15 | verifyFunction :: Value -> IO Bool 16 | verifyFunction f = fmap toBool $ FFI.verifyFunction f 2 17 | 18 | verifyModule :: Module -> IO (Maybe String) 19 | verifyModule (MkModule m _) = 20 | alloca $ \msgPtr -> do 21 | result <- withForeignPtr m (\m' -> FFI.verifyModule m' 2 msgPtr) 22 | msg <- peek msgPtr 23 | if not . toBool $ result 24 | then return Nothing 25 | else do str <- peekCString msg 26 | FFI.disposeMessage msg 27 | return $ Just str 28 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/BitReader.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.BitReader (parseBitcodeInContext) where 2 | 3 | import Foreign.Marshal.Alloc (alloca) 4 | import Foreign.Marshal.Utils (toBool) 5 | import Foreign.C.String (peekCString) 6 | import Foreign.Storable (peek) 7 | import Foreign.ForeignPtr.Safe (withForeignPtr) 8 | 9 | import qualified LLVM.FFI.BitReader as FFI 10 | 11 | import LLVM.Wrapper.Internal 12 | import LLVM.Wrapper.Core 13 | 14 | parseBitcodeInContext :: Context -> MemoryBuffer -> IO (Either String Module) 15 | parseBitcodeInContext ctx buf = 16 | alloca $ \msgPtr -> 17 | alloca $ \modPtr -> 18 | withForeignPtr ctx $ \ctx' -> 19 | withForeignPtr buf $ \buf' -> do 20 | errOccurred <- FFI.parseBitcodeInContext ctx' buf' modPtr msgPtr 21 | if toBool errOccurred 22 | then fmap Left $ peek msgPtr >>= peekCString 23 | else fmap Right $ peek modPtr >>= initModule 24 | 25 | -- TODO: Work out the memory dynamics of this 26 | getBitcodeModuleInContext :: Context -> MemoryBuffer -> IO (Either String Module) 27 | getBitcodeModuleInContext ctx buf = 28 | alloca $ \msgPtr -> 29 | alloca $ \modPtr -> 30 | withForeignPtr ctx $ \ctx' -> 31 | withForeignPtr buf $ \buf' -> do 32 | errOccurred <- FFI.getBitcodeModuleInContext ctx' buf' modPtr msgPtr 33 | if toBool errOccurred 34 | then fmap Left $ peek msgPtr >>= peekCString 35 | else fmap Right $ peek modPtr >>= initModule 36 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/BitWriter.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.BitWriter where 2 | 3 | import Foreign.C.String 4 | import Foreign.ForeignPtr.Safe (withForeignPtr) 5 | import Control.Monad 6 | 7 | import qualified LLVM.FFI.BitWriter as FFI 8 | import LLVM.Wrapper.Core 9 | import LLVM.Wrapper.Internal 10 | 11 | writeBitcodeToFile :: Module -> FilePath -> IO () 12 | writeBitcodeToFile (MkModule m _) p = do 13 | result <- withForeignPtr m (withCString p . FFI.writeBitcodeToFile) 14 | when (result /= 0) $ 15 | fail $ "Failed to write bitcode to " ++ p 16 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/ExecutionEngine.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.ExecutionEngine 2 | ( module LLVM.FFI.ExecutionEngine 3 | -- * Execution engines 4 | , ExecutionEngine 5 | , findFunction 6 | , runFunction 7 | , runFunctionAsMain 8 | 9 | , createExecutionEngineForModule 10 | , createInterpreterForModule 11 | , createJITCompilerForModule 12 | 13 | -- * Generic values 14 | , createGenericValueOfInt 15 | , genericValueToInt 16 | ) where 17 | 18 | import LLVM.FFI.ExecutionEngine 19 | ( runStaticConstructors 20 | , runStaticDestructors 21 | , genericValueToFloat 22 | , createGenericValueOfFloat 23 | , disposeExecutionEngine 24 | , addModuleProvider 25 | , getExecutionEngineTargetData 26 | , freeMachineCodeForFunction 27 | , genericValueIntWidth 28 | , linkInJIT 29 | , addModule 30 | ) 31 | 32 | import qualified LLVM.FFI.ExecutionEngine as FFI.EE 33 | import qualified LLVM.FFI.Core as FFI 34 | 35 | import Control.Monad 36 | 37 | import Foreign.Ptr (Ptr) 38 | import Foreign.C.String 39 | import Foreign.C.Types 40 | import Foreign.Marshal.Array 41 | import Foreign.Marshal.Alloc 42 | import Foreign.Marshal.Utils 43 | import Foreign.Storable 44 | 45 | type ExecutionEngine = Ptr FFI.EE.ExecutionEngine -- FFI.EE.ExecutionEngineRef 46 | type GenericValue = Ptr FFI.EE.GenericValue -- FFI.EE.GenericValueRef 47 | 48 | type Type = FFI.TypeRef 49 | type Module = FFI.ModuleRef 50 | type Value = FFI.ValueRef 51 | 52 | createGenericValueOfInt :: Type -> CULLong -> Bool -> IO GenericValue 53 | createGenericValueOfInt ty n isSigned 54 | = FFI.EE.createGenericValueOfInt ty n (fromBool isSigned) 55 | 56 | genericValueToInt :: GenericValue -> Bool -> CULLong 57 | genericValueToInt genVal isSigned = FFI.EE.genericValueToInt genVal (fromBool isSigned) 58 | 59 | runFunction :: ExecutionEngine -> Value -> CUInt -> [GenericValue] -> IO GenericValue 60 | runFunction ee f numArgs args 61 | = withArray args $ \ptr -> FFI.EE.runFunction ee f numArgs ptr 62 | 63 | findFunction :: ExecutionEngine -> String -> IO (Maybe Value) 64 | findFunction ee name 65 | = alloca $ \funPtr -> 66 | withCString name $ \s -> do 67 | r <- liftM toBool (FFI.EE.findFunction ee s funPtr) 68 | if r 69 | then return Nothing 70 | else liftM Just (peek funPtr) 71 | 72 | runFunctionAsMain :: ExecutionEngine -> Value -> [String] -> [String] -> IO Bool 73 | runFunctionAsMain ee val argv envp 74 | = do argcstrs <- argcstrings 75 | envcstrs <- envcstrings 76 | withArray argcstrs $ \args -> 77 | withArray envcstrs $ \env -> 78 | liftM toBool (FFI.EE.runFunctionAsMain ee val (fromIntegral $ length argv) args env) 79 | where argcstrings = mapM newCString argv 80 | envcstrings = mapM newCString envp 81 | 82 | createJITCompilerForModule :: Module -> CUInt -> IO ExecutionEngine 83 | createJITCompilerForModule m optlvl 84 | = alloca $ \msgPtr -> 85 | alloca $ \eeref -> do 86 | r <- FFI.EE.createJITCompilerForModule eeref m optlvl msgPtr 87 | if toBool r 88 | then peek msgPtr >>= peekCString >>= fail 89 | else peek eeref 90 | 91 | createInterpreterForModule :: Module -> IO ExecutionEngine 92 | createInterpreterForModule m 93 | = alloca $ \msgPtr -> 94 | alloca $ \eeref -> do 95 | r <- FFI.EE.createInterpreterForModule eeref m msgPtr 96 | if toBool r 97 | then peek msgPtr >>= peekCString >>= fail 98 | else peek eeref 99 | 100 | createExecutionEngineForModule :: Module -> IO ExecutionEngine 101 | createExecutionEngineForModule m 102 | = alloca $ \msgPtr -> 103 | alloca $ \eeref -> do 104 | r <- FFI.EE.createExecutionEngineForModule eeref m msgPtr 105 | if toBool r 106 | then peek msgPtr >>= peekCString >>= fail 107 | else peek eeref 108 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/Internal.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.Internal where 2 | 3 | import Foreign.ForeignPtr.Safe (ForeignPtr, newForeignPtr) 4 | import qualified Foreign.Concurrent as FC (newForeignPtr) 5 | import Foreign.Ptr (Ptr) 6 | 7 | import Control.Monad 8 | import Data.IORef 9 | 10 | import qualified LLVM.FFI.Core as FFI 11 | import qualified LLVM.FFI.Transforms.PassManagerBuilder as FFI 12 | 13 | data Module = MkModule (ForeignPtr FFI.Module) (IORef Bool) 14 | deriving Eq 15 | 16 | data PassManager = MkPassManager (ForeignPtr FFI.PassManager) 17 | deriving Eq 18 | 19 | data PassManagerBuilder = MkPassManagerBuilder (ForeignPtr FFI.PassManagerBuilder) 20 | deriving Eq 21 | 22 | moduleFinalizer :: Ptr FFI.Module -> IORef Bool -> IO () 23 | moduleFinalizer m ours = do 24 | isOurs <- readIORef ours 25 | when isOurs $ FFI.disposeModule m 26 | 27 | initModule :: Ptr FFI.Module -> IO Module 28 | initModule ptr = do 29 | ours <- newIORef True 30 | fptr <- FC.newForeignPtr ptr (moduleFinalizer ptr ours) 31 | return $ MkModule fptr ours 32 | 33 | initPassManager :: Ptr FFI.PassManager -> IO PassManager 34 | initPassManager ptr = fmap MkPassManager (newForeignPtr FFI.ptrDisposePassManager ptr) 35 | 36 | initPassManagerBuilder :: Ptr FFI.PassManagerBuilder -> IO PassManagerBuilder 37 | initPassManagerBuilder ptr = fmap MkPassManagerBuilder (newForeignPtr FFI.ptrPassManagerBuilderDispose ptr) 38 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/Linker.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.Linker ( LinkerMode(..) 2 | , linkModules ) where 3 | 4 | import qualified LLVM.FFI.Linker as FFI 5 | import LLVM.FFI.Linker (LinkerMode(..)) 6 | import qualified LLVM.FFI.Core as FFI 7 | import LLVM.Wrapper.Core 8 | import LLVM.Wrapper.Internal 9 | 10 | import Foreign.C.String (peekCString) 11 | import Foreign.Marshal.Alloc (alloca) 12 | import Foreign.Marshal.Utils (toBool) 13 | import Foreign.Storable (peek) 14 | import Foreign.ForeignPtr.Safe (withForeignPtr) 15 | 16 | import Data.IORef 17 | 18 | linkModules :: Module -> Module -> LinkerMode -> IO (Maybe String) 19 | linkModules (MkModule dest _) (MkModule src srcOurs) mode = 20 | withForeignPtr dest $ \dest' -> 21 | withForeignPtr src $ \src' -> 22 | alloca $ \msgPtr -> do 23 | result <- FFI.linkModules dest' src' (FFI.fromLinkerMode mode) msgPtr 24 | writeIORef srcOurs False 25 | msg <- peek msgPtr 26 | if not . toBool $ result 27 | then return Nothing 28 | else do str <- peekCString msg 29 | FFI.disposeMessage msg 30 | return (Just str) 31 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/Target.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.Target 2 | ( module LLVM.FFI.Target 3 | , TargetData 4 | , ByteOrdering(..) 5 | , byteOrder 6 | , copyStringRepOfTargetData 7 | , createTargetData 8 | , withTargetData 9 | ) where 10 | 11 | import LLVM.FFI.Target 12 | ( addTargetData 13 | , disposeTargetData 14 | , intPtrType 15 | , callFrameAlignmentOfType 16 | , aBIAlignmentOfType 17 | , aBISizeOfType 18 | , pointerSize 19 | , preferredAlignmentOfGlobal 20 | , preferredAlignmentOfType 21 | , sizeOfTypeInBits 22 | , storeSizeOfType 23 | , elementAtOffset 24 | , offsetOfElement 25 | ) 26 | 27 | import qualified LLVM.FFI.Target as FFI.T 28 | 29 | import Foreign.C.String (peekCString, withCString) 30 | import Control.Exception (finally) 31 | 32 | type TargetData = FFI.T.TargetDataRef 33 | 34 | data ByteOrdering = BigEndian | LittleEndian deriving Eq 35 | 36 | byteOrder :: TargetData -> ByteOrdering 37 | byteOrder td = if FFI.T.byteOrder td == 0 then BigEndian else LittleEndian 38 | 39 | copyStringRepOfTargetData :: TargetData -> IO String 40 | copyStringRepOfTargetData td = do s <- FFI.T.copyStringRepOfTargetData td 41 | peekCString s 42 | 43 | createTargetData :: String -> IO TargetData 44 | createTargetData str = withCString str $ \p -> FFI.T.createTargetData p 45 | 46 | withTargetData :: String -> (TargetData -> IO a) -> IO a 47 | withTargetData str f = do t <- createTargetData str 48 | finally (f t) (FFI.T.disposeTargetData t) 49 | -------------------------------------------------------------------------------- /base/LLVM/Wrapper/Transforms/PassManagerBuilder.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Wrapper.Transforms.PassManagerBuilder where 2 | 3 | import Foreign.C.Types 4 | import Foreign.ForeignPtr.Safe (withForeignPtr) 5 | import Foreign.Marshal.Utils (fromBool, toBool) 6 | 7 | import qualified LLVM.FFI.Transforms.PassManagerBuilder as FFI 8 | import LLVM.Wrapper.Internal 9 | 10 | passManagerBuilderCreate :: IO PassManagerBuilder 11 | passManagerBuilderCreate = initPassManagerBuilder =<< FFI.passManagerBuilderCreate 12 | 13 | passManagerBuilderSetOptLevel :: PassManagerBuilder -> CUInt -> IO () 14 | passManagerBuilderSetOptLevel (MkPassManagerBuilder p) level = 15 | withForeignPtr p (`FFI.passManagerBuilderSetOptLevel` level) 16 | 17 | passManagerBuilderSetSizeLevel :: PassManagerBuilder -> CUInt -> IO () 18 | passManagerBuilderSetSizeLevel (MkPassManagerBuilder p) level = 19 | withForeignPtr p (`FFI.passManagerBuilderSetSizeLevel` level) 20 | 21 | passManagerBuilderPopulateFunctionPassManager :: PassManagerBuilder -> PassManager -> IO () 22 | passManagerBuilderPopulateFunctionPassManager (MkPassManagerBuilder b) (MkPassManager m) = 23 | withForeignPtr b $ \bptr -> 24 | withForeignPtr m $ \mptr -> 25 | FFI.passManagerBuilderPopulateFunctionPassManager bptr mptr 26 | 27 | passManagerBuilderPopulateModulePassManager :: PassManagerBuilder -> PassManager -> IO () 28 | passManagerBuilderPopulateModulePassManager (MkPassManagerBuilder b) (MkPassManager m) = 29 | withForeignPtr b $ \bptr -> 30 | withForeignPtr m $ \mptr -> 31 | FFI.passManagerBuilderPopulateModulePassManager bptr mptr 32 | 33 | passManagerBuilderPopulateLTOPassManager :: PassManagerBuilder -> PassManager -> Bool -> Bool -> IO () 34 | passManagerBuilderPopulateLTOPassManager (MkPassManagerBuilder b) (MkPassManager m) internalize inline = 35 | withForeignPtr b $ \bptr -> 36 | withForeignPtr m $ \mptr -> 37 | FFI.passManagerBuilderPopulateLTOPassManager bptr mptr (fromBool internalize) (fromBool inline) 38 | 39 | -------------------------------------------------------------------------------- /base/README.md: -------------------------------------------------------------------------------- 1 | Haskell LLVM bindings 2 | --------------------- 3 | 4 | This package provides Haskell bindings for the popular 5 | [LLVM](http://llvm.org/) compiler infrastructure project. 6 | 7 | 8 | Compatibility 9 | ------------- 10 | 11 | We try to stay up to date with LLVM releases. The current version of 12 | this package is compatible with LLVM 2.9 and 2.8. Please understand 13 | that the package may or may not work against older LLVM releases; we 14 | don't have the time or resources to test across multiple releases. 15 | 16 | 17 | Configuration 18 | ------------- 19 | 20 | By default, when you run `cabal install`, the Haskell bindings will be 21 | configured to look for LLVM in `/usr/local`. 22 | 23 | If you have LLVM installed in a different location, e.g. `/usr`, you 24 | can tell the `configure` script where to find it as follows: 25 | 26 | cabal install --configure-option=--with-llvm-prefix=/usr 27 | 28 | 29 | Package status - what to expect 30 | ------------------------------- 31 | 32 | This package is still under development. 33 | 34 | The high level bindings are currently incomplete, so there are some 35 | limits on what you can do. Adding new functions is generally easy, 36 | though, so don't be afraid to get your hands dirty. 37 | 38 | The high level interface is mostly safe, but the type system cannot 39 | protect against everything that can go wrong, so take care. And, of 40 | course, there's no way to guarantee anything about the generated code. 41 | 42 | 43 | GHCi 44 | ---- 45 | 46 | llvm-base will not work under GHCi. It fails to resolve some symbols, 47 | however under GHC it works fine. It appears related to the bugs listed in: 48 | 49 | http://hackage.haskell.org/trac/ghc/ticket/3333 50 | http://hackage.haskell.org/trac/ghc/ticket/3658 51 | http://hackage.haskell.org/trac/ghc/ticket/5987 52 | 53 | ghci versions < 7.7 have their own special linker, we do not support it. 54 | ghci versions >= 7.7 use the system dynamic linker, we do support it. 55 | If you have a problem using llvm-base with ghci >= 7.7 please file a bug report. 56 | 57 | Staying in touch 58 | ---------------- 59 | 60 | There is a low-volume mailing list named 61 | [haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm). 62 | If you use the LLVM bindings, you should think about joining. 63 | 64 | If you want to contribute patches, please clone a copy of the 65 | [git repository](https://github.com/bos/llvm): 66 | 67 | git clone git://github.com/bos/llvm 68 | 69 | Patches are best submitted via the github "pull request" interface. 70 | 71 | To file a bug or a request for an enhancement, please use the 72 | [github issue tracker](https://github.com/bos/llvm/issues). 73 | -------------------------------------------------------------------------------- /base/Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | import System.Directory 6 | import System.Environment 7 | import System.FilePath 8 | import System.Info 9 | import System.Process 10 | import System.IO.Error ( isDoesNotExistError ) 11 | import Control.Monad 12 | import Control.Exception 13 | import Data.Char ( isSpace, isDigit ) 14 | import Data.List 15 | import Data.Maybe 16 | import Distribution.Simple 17 | import Distribution.Simple.Setup 18 | import Distribution.InstalledPackageInfo 19 | import Distribution.PackageDescription 20 | import Distribution.Simple.LocalBuildInfo 21 | import Distribution.Simple.Install 22 | import Distribution.Simple.Register 23 | import Distribution.Simple.Utils 24 | import Distribution.Text ( display ) 25 | import Language.Haskell.TH 26 | 27 | main = do 28 | let hooks = autoconfUserHooks { postConf = if os == "mingw32" 29 | then generateBuildInfo 30 | else postConf autoconfUserHooks 31 | , instHook = installHookWithExtraGhciLibraries 32 | , regHook = regHookWithExtraGhciLibraries 33 | } 34 | defaultMainWithHooks hooks 35 | 36 | -- On Windows we can't count on the configure script, so generate the 37 | -- llvm.buildinfo from a template. 38 | generateBuildInfo _ conf _ _ = do 39 | let args = configConfigureArgs conf 40 | let pref = "--with-llvm-config=" 41 | configbin <- 42 | case [ p | arg <- args, Just p <- [stripPrefix pref arg] ] of 43 | [p] -> return p 44 | _ -> do 45 | r <- tryJust (guard . isDoesNotExistError) 46 | (readProcess "llvm-config" ["--bindir"] "") 47 | case r of 48 | Left _ -> error $ "Use '--configure-option " ++ pref ++ "PATH' to give llvm-config path" 49 | Right p -> return $ takeWhile (/= '\n') p ++ "/llvm-config" 50 | info <- readFile "llvm-base.buildinfo.windows.in" 51 | let llvmconfig = (\opts -> fmap (takeWhile (/= '\n')) $ readProcess configbin opts "") 52 | cppflags <- llvmconfig ["--cppflags"] 53 | version <- llvmconfig ["--version"] 54 | let major = read $ takeWhile isDigit version 55 | minor = read . takeWhile isDigit . tail $ dropWhile (/= '.') version 56 | hsversion = major * 100 + minor 57 | cflags <- llvmconfig ["--cflags"] 58 | libs <- fmap (subst "-l" "") $ llvmconfig ["--libs"] 59 | libdir <- llvmconfig ["--libdir"] 60 | ldopts <- llvmconfig ["--ldflags"] 61 | includedir <- llvmconfig ["--includedir"] 62 | let substs = [ ("@llvm_cppflags@", cppflags) 63 | , ("@llvm_num_version@", show hsversion) 64 | , ("@llvm_cflags@", cflags) 65 | , ("@llvm_extra_libs@", libs) 66 | , ("@llvm_extra_libdirs@", libdir) 67 | , ("@llvm_ldoptions@", ldopts) 68 | , ("@llvm_includedir@", includedir) 69 | ] 70 | writeFile "llvm-base.buildinfo" $ foldl (\i (key, val) -> subst key val i) info substs 71 | 72 | subst from to [] = [] 73 | subst from to xs | Just r <- stripPrefix from xs = to ++ subst from to r 74 | subst from to (x:xs) = x : subst from to xs 75 | 76 | {- 77 | To compensate for Cabal's current design, 78 | we need to replicate the default registration hook code here, 79 | to inject a value for extra-ghci-libraries into the package registration info. 80 | (Inspired by 'Gtk2HsSetup.hs'.) 81 | This only works for Cabal 1.10, 82 | thus we added an according constraint to llvm.cabal. 83 | 84 | We define an extension field 'x-extra-ghci-libraries' in the .buildinfo file 85 | in order to communicate the version information of the LLVM dynamic library 86 | from the configure script to the registration code. 87 | -} 88 | installHookWithExtraGhciLibraries :: PackageDescription -> LocalBuildInfo 89 | -> UserHooks -> InstallFlags -> IO () 90 | installHookWithExtraGhciLibraries pkg_descr localbuildinfo _ flags = do 91 | let copyFlags = defaultCopyFlags { 92 | copyDistPref = installDistPref flags, 93 | copyDest = toFlag NoCopyDest, 94 | copyVerbosity = installVerbosity flags 95 | } 96 | install pkg_descr localbuildinfo copyFlags 97 | let registerFlags = defaultRegisterFlags { 98 | regDistPref = installDistPref flags, 99 | regInPlace = installInPlace flags, 100 | regPackageDB = installPackageDB flags, 101 | regVerbosity = installVerbosity flags 102 | } 103 | when (hasLibs pkg_descr) $ register' pkg_descr localbuildinfo registerFlags 104 | 105 | regHookWithExtraGhciLibraries :: PackageDescription -> LocalBuildInfo 106 | -> UserHooks -> RegisterFlags -> IO () 107 | regHookWithExtraGhciLibraries pkg_descr localbuildinfo _ flags = 108 | if hasLibs pkg_descr 109 | then register' pkg_descr localbuildinfo flags 110 | else setupMessage verbosity 111 | "Package contains no library to register:" (packageId pkg_descr) 112 | where verbosity = fromFlag (regVerbosity flags) 113 | 114 | 115 | 116 | {- 117 | this is the workaround for conditional compilation if template haskell was more 118 | permissive, but isn't 119 | 120 | --- what i'd like to write, but can't because template haskell rejecting 121 | the branch that has the wrong api version 122 | extractCLBI x= 123 | $(if cabalVersion >= Version [1,17,0] [] 124 | then [| getComponentLocalBuildInfo 'x CLibName |] 125 | else [| 126 | let LocalBuildInfo { libraryConfig = Just clbi } = 'x 127 | in clbi |] 128 | ) 129 | 130 | 131 | -} 132 | 133 | --- horrible hack to support cabal versions both above and below 1.17 134 | extractCLBI x= 135 | $(if cabalVersion >= Version [1,17,0] [] 136 | then appE (appE ( varE $ mkName "getComponentLocalBuildInfo") ( varE 'x) ) (conE ( mkName "CLibName")) 137 | 138 | else letE 139 | [valD (recP 140 | (mkName "LocalBuildInfo" ) 141 | [fieldPat (mkName "libraryConfig") 142 | (conP (mkName "Just") [varP $ mkName "clbi"] ) ] ) 143 | (normalB $ varE 'x) [] ] 144 | (varE $ mkName "clbi") ) 145 | 146 | register' :: PackageDescription -> LocalBuildInfo 147 | -> RegisterFlags -- ^Install in the user's database?; verbose 148 | -> IO () 149 | register' pkg@PackageDescription { library = Just lib } 150 | lbi regFlags 151 | = do 152 | let clbi = extractCLBI lbi 153 | installedPkgInfoRaw <- generateRegistrationInfo 154 | verbosity pkg lib lbi clbi inplace distPref 155 | 156 | let ghciLibraries = case lookup "x-extra-ghci-libraries" (customFieldsBI (libBuildInfo lib)) of 157 | Just s | not (all isSpace s) -> [s] 158 | _ -> [] 159 | installedPkgInfo = installedPkgInfoRaw { 160 | extraGHCiLibraries = ghciLibraries } 161 | 162 | -- Three different modes: 163 | case () of 164 | _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo 165 | | modeGenerateRegScript -> die "Generate Reg Script not supported" 166 | | otherwise -> registerPackage verbosity 167 | installedPkgInfo pkg lbi inplace 168 | (withPackageDB lbi) 169 | 170 | where 171 | modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) 172 | modeGenerateRegScript = fromFlag (regGenScript regFlags) 173 | inplace = fromFlag (regInPlace regFlags) 174 | packageDb = nub $ withPackageDB lbi ++ 175 | maybeToList (flagToMaybe (regPackageDB regFlags)) 176 | distPref = fromFlag (regDistPref regFlags) 177 | verbosity = fromFlag (regVerbosity regFlags) 178 | regFile = fromMaybe (display (packageId pkg) <.> "conf") 179 | (fromFlag (regGenPkgConf regFlags)) 180 | writeRegistrationFile installedPkgInfo = do 181 | notice verbosity ("Creating package registration file: " ++ regFile) 182 | writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) 183 | 184 | register' _ _ regFlags = notice verbosity "No package to register" 185 | where 186 | verbosity = fromFlag (regVerbosity regFlags) 187 | -------------------------------------------------------------------------------- /base/cbits/free.c: -------------------------------------------------------------------------------- 1 | #ifndef __STDC_LIMIT_MACROS 2 | #define __STDC_LIMIT_MACROS 3 | #endif 4 | #ifndef __STDC_CONSTANT_MACROS 5 | #define __STDC_CONSTANT_MACROS 6 | #endif 7 | 8 | #include 9 | #include 10 | 11 | /* C function to free function object resources. Can be called from a finalizer. */ 12 | void 13 | c_freeFunctionObject(LLVMExecutionEngineRef execEngine, 14 | LLVMModuleProviderRef moduleProvider, 15 | LLVMValueRef f) 16 | { 17 | LLVMModuleRef mod; 18 | LLVMFreeMachineCodeForFunction(execEngine, f); 19 | if (!LLVMRemoveModuleProvider(execEngine, moduleProvider, &mod, 0)) { 20 | LLVMDisposeModule(mod); 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /base/cbits/malloc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #ifdef DEBUG 5 | #include 6 | #endif 7 | 8 | #ifdef TEST 9 | #include 10 | #endif 11 | 12 | 13 | size_t gcd(size_t x, size_t y) { 14 | while (x!=0) { 15 | size_t tmp = y%x; 16 | y = x; 17 | x = tmp; 18 | } 19 | return y; 20 | }; 21 | 22 | __inline__ 23 | size_t lcm(size_t x, size_t y) { 24 | return x*(y/gcd(x,y)); 25 | }; 26 | 27 | __inline__ 28 | size_t round_down_multiple(size_t x, size_t y) { 29 | return x - (x%y); 30 | }; 31 | 32 | /* 33 | This is the alignment that malloc always warrants. 34 | If smaller alignments are requested, then we do not need to pad. 35 | 36 | FIXME: 37 | This was only tested on ix86-linux. 38 | How to get the right number for every platform? 39 | */ 40 | const size_t default_align = 8; 41 | 42 | /* 43 | We have to waste a lot of memory, 44 | since we need an aligned address 45 | and before that space for a pointer. 46 | Less memory can be wasted if 'free' also gets size and align information. 47 | In this case we could omit padding in some cases 48 | and in the other cases we could put the pointer after the memory chunk, 49 | which allows us to use less padding. 50 | */ 51 | void *aligned_malloc(size_t size, size_t requested_align) { 52 | const size_t ptrsize = sizeof(void *); 53 | /* 54 | Ensure that alignment always allows to store a pointer 55 | (to the whole allocated block). 56 | */ 57 | const size_t align = lcm(requested_align, ptrsize); 58 | const size_t pad = align; 59 | void *ptr = malloc(pad+ptrsize+size); 60 | if (ptr) { 61 | void **alignedptr = (void **) round_down_multiple((size_t)(ptr+pad+ptrsize), align); 62 | *(alignedptr-1) = ptr; 63 | #ifdef DEBUG 64 | printf("allocated size %x with alignment %x at %08x %08x \n", 65 | size, align, (size_t) ptr, (size_t) alignedptr); 66 | #endif 67 | return alignedptr; 68 | } else { 69 | return NULL; 70 | } 71 | }; 72 | 73 | /* align must be a power of two */ 74 | void *power2_aligned_malloc(size_t size, size_t align) { 75 | const size_t ptrsize = sizeof(void *); 76 | size_t pad = align>=default_align ? align-default_align : 0; 77 | void *ptr = malloc(pad+ptrsize+size); 78 | if (ptr) { 79 | void **alignedptr = (void **)((size_t)(ptr+pad+ptrsize) & (-align)); 80 | *(alignedptr-1) = ptr; 81 | #ifdef DEBUG 82 | printf("allocated size 0x%x with alignment 0x%x at %08x %08x \n", 83 | size, align, (size_t) ptr, (size_t) alignedptr); 84 | #endif 85 | return alignedptr; 86 | } else { 87 | return NULL; 88 | } 89 | }; 90 | 91 | void aligned_free(void *alignedptr) { 92 | if (alignedptr) { 93 | void **sptr = (void **) alignedptr; 94 | void *ptr = *(sptr - 1); 95 | #ifdef DEBUG 96 | printf("freed %08x %08x \n", (size_t) ptr, (size_t) alignedptr); 97 | #endif 98 | free(ptr); 99 | } else { 100 | /* 101 | What shall we do about NULL pointers? 102 | Crash immediately? Make an official crash by 'free'? 103 | */ 104 | free(alignedptr); 105 | } 106 | }; 107 | 108 | 109 | /* 110 | Abuse a pointer type as a size_t compatible type 111 | and choose a name that will hopefully not clash 112 | with names an llvm user already uses (such as 'malloc'). 113 | */ 114 | void *aligned_malloc_sizeptr(void *size, void *align) { 115 | return aligned_malloc((size_t) size, (size_t) align); 116 | } 117 | 118 | 119 | const int 120 | prepadsize = 1024, 121 | postpadsize = 1024; 122 | 123 | void *padded_aligned_malloc(size_t size, size_t align) { 124 | void *ptr = aligned_malloc(prepadsize+size+postpadsize, align); 125 | return ptr ? ptr+prepadsize : NULL; 126 | }; 127 | 128 | void padded_aligned_free(void *ptr) { 129 | aligned_free(ptr ? ptr-prepadsize : NULL); 130 | }; 131 | 132 | 133 | #ifdef TEST 134 | void test_gcd (size_t x, size_t y) { 135 | printf("gcd(%d,%d) = %d\n", x, y, gcd (x,y)); 136 | } 137 | 138 | void test_malloc (size_t size, size_t align) { 139 | uint8_t *ptr = aligned_malloc (size, align); 140 | if (ptr) { 141 | if (((size_t) ptr) % align) { 142 | printf ("ptr %08x not correctly aligned\n", (size_t) ptr); 143 | } 144 | size_t k; 145 | for (k = 0; k(pass_man); 33 | 34 | if (func_man) { 35 | Builder.populateFunctionPassManager (*func_man); 36 | } else { 37 | // printf ("Cannot create function passes for module pass manager\n"); 38 | } 39 | } 40 | 41 | void LLVMCreateStandardModulePasses(LLVMPassManagerRef PM, 42 | unsigned OptLevel, 43 | int OptimizeSize, 44 | int UnitAtATime, 45 | int UnrollLoops, 46 | int SimplifyLibCalls, 47 | int HaveExceptions, 48 | int DisableInline) 49 | { 50 | llvm::PassManagerBuilder Builder; 51 | Builder.OptLevel = OptLevel; 52 | Builder.SizeLevel = OptimizeSize; 53 | Builder.DisableUnrollLoops = !UnrollLoops; 54 | Builder.DisableSimplifyLibCalls = !SimplifyLibCalls; 55 | Builder.DisableUnitAtATime = !UnitAtATime; 56 | 57 | Pass *InliningPass = 0; 58 | 59 | if (DisableInline) { 60 | // No inlining pass 61 | } else if (OptLevel) { 62 | unsigned Threshold = 225; 63 | if (OptLevel > 2) 64 | Threshold = 275; 65 | Builder.Inliner = createFunctionInliningPass(Threshold); 66 | } else { 67 | Builder.Inliner = createAlwaysInlinerPass(); 68 | } 69 | 70 | Builder.populateModulePassManager (*unwrap(PM)); 71 | } 72 | 73 | void LLVMDisablePrettyStackTrace() 74 | { 75 | llvm::DisablePrettyStackTrace = true; 76 | } 77 | 78 | -------------------------------------------------------------------------------- /base/configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT([Haskell LLVM FFI bindings], [3.2.0.0], [bos@serpentine.com], [llvm-base]) 2 | 3 | AC_CONFIG_SRCDIR([LLVM/FFI/Core.hsc]) 4 | 5 | AC_CONFIG_FILES([llvm-base.buildinfo]) 6 | 7 | AC_CONFIG_HEADERS([include/hs_llvm_config.h]) 8 | 9 | AC_PROG_CXX 10 | 11 | AC_LANG(C++) 12 | 13 | AC_ARG_WITH(compiler, 14 | [AS_HELP_STRING([--with-compiler], 15 | [use the given Haskell compiler])], 16 | compiler="$withval", 17 | compiler=ghc)dnl 18 | 19 | AC_ARG_WITH(llvm_prefix, 20 | [AS_HELP_STRING([--with-llvm-prefix], 21 | [use the version of LLVM at the given location])], 22 | llvm_prefix="$withval", 23 | llvm_prefix="$prefix")dnl 24 | 25 | AC_ARG_WITH(llvm_bindir, 26 | [AS_HELP_STRING([--with-llvm-bindir], 27 | [use LLVM binaries at the given location])], 28 | llvm_bindir="$withval", 29 | llvm_bindir="$llvm_prefix/bin")dnl 30 | 31 | AC_PATH_PROGS(llvm_config, [llvm-config], 32 | [AC_MSG_ERROR(could not find llvm-config in $llvm_bindir)], 33 | ["$llvm_bindir:$PATH"]) 34 | 35 | dnl * Choose target platform 36 | dnl 37 | dnl We don't use the standard autoconf macros for this, but instead 38 | dnl ask GHC what platform it is for. Why? We need to generate a library 39 | dnl matching the compiler. 40 | dnl NB: This code is from GHC's configure (where the corresponding code for 41 | dnl guessing host and build variables can be found, too) 42 | 43 | dnl Guess target platform if necessary. 44 | m4_divert_once([HELP_CANON], 45 | [[ 46 | System types: 47 | --target=TARGET configure for building compilers for TARGET [guessed]]])dnl 48 | 49 | if test "$target" = "" 50 | then 51 | if test "${compiler}" != "" 52 | then 53 | target=`${compiler} +RTS --info | grep '^ ,("Target platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` 54 | echo "Target platform inferred as: $target" 55 | else 56 | echo "Can't work out target platform" 57 | exit 1 58 | fi 59 | fi 60 | 61 | dnl Determine target-specific options 62 | dnl This is important as Snow Leopard (Mac OS X 10.6) defaults to generating 63 | dnl 64-bit code. 64 | case $target in 65 | i386-apple-darwin) 66 | TARGET_CPPFLAGS="-m32" 67 | TAGRET_LDFLAGS="-m32" 68 | ;; 69 | x86_64-apple-darwin) 70 | TARGET_CPPFLAGS="-m64" 71 | TAGRET_LDFLAGS="-m64" 72 | ;; 73 | esac 74 | 75 | llvm_version="`$llvm_config --version`" 76 | AC_MSG_RESULT(found LLVM version $llvm_version) 77 | llvm_cppflags="`$llvm_config --cppflags`" 78 | llvm_includedir="`$llvm_config --includedir`" 79 | llvm_ldflags="`$llvm_config --ldflags`" 80 | llvm_cflags="`$llvm_config --cflags` `$llvm_config --cxxflags`" 81 | llvm_all_libs="`$llvm_config --libs all`" 82 | llvm_target="`$llvm_config --libs engine | sed 's/.*LLVM\(.[[^ ]]*\)CodeGen.*/\1/'`" 83 | 84 | CPPFLAGS="$llvm_cppflags $CPPFLAGS $TARGET_CPPFLAGS" 85 | LDFLAGS="$llvm_ldflags $LDFLAGS $TARGET_LDFLAGS" 86 | 87 | llvm_extra_ghci_libs="" 88 | 89 | dnl We use the fact that the struct type was only introduced in version 90 | dnl 3.0 to filter out prior version, as they are no longer supported. 91 | AC_SEARCH_LIBS([LLVMStructType],[LLVM-$llvm_version]) 92 | if test "$ac_cv_search_LLVMStructType" = "no"; then 93 | AC_MSG_ERROR([LLVM > 3 required, found $llvm_version]) 94 | fi 95 | 96 | AC_SEARCH_LIBS([LLVMModuleCreateWithName],[LLVM-$llvm_version]) 97 | if test "$ac_cv_search_LLVMModuleCreateWithName" = "no"; then 98 | llvm_all_libs="`$llvm_config --libs all`" 99 | else 100 | llvm_extra_ghci_libs="LLVM-$llvm_version" 101 | llvm_all_libs="$LIBS" 102 | fi 103 | 104 | dnl We need to separate libraries that need to be linked from other linker options. 105 | llvm_extra_libs="" 106 | llvm_extra_libdirs="" 107 | llvm_ldoptions="" 108 | for opt in $llvm_all_libs $llvm_ldflags; do 109 | case $opt in 110 | -l*) llvm_extra_libs="$llvm_extra_libs `echo $opt | sed 's/^-l//'`";; 111 | -L*) llvm_extra_libdirs="$llvm_extra_libdirs `echo $opt | sed 's/^-L//'`";; 112 | *) llvm_ldoptions="$llvm_ldoptions $opt";; 113 | esac 114 | done 115 | 116 | AC_CHECK_HEADERS([llvm-c/Core.h], [], 117 | [AC_MSG_ERROR(could not find LLVM C bindings)]) 118 | 119 | AC_CHECK_HEADERS([llvm/ADT/StringRef.h]) 120 | AC_CHECK_HEADERS([llvm/Support/DynamicLibrary.h], [], [], 121 | [#ifdef HAVE_LLVM_ADT_STRINGREF_H 122 | # include 123 | #endif]) 124 | 125 | dnl Checking that we really have an LLVM version available. 126 | dnl We check both in the single-shared library and with the many-library 127 | dnl version that may be installed. 128 | AC_CHECK_LIB(LLVM-$llvm_version, LLVMModuleCreateWithName, [], []) 129 | if test "$ac_cv_lib_LLVM-$llvm_version_LLVMModuleCreateWithName" = "no"; then 130 | save_LIBS="$LIBS" 131 | LIBS="-lLLVMSupport -lpthread -ldl $LIBS" 132 | 133 | AC_CHECK_LIB(LLVMCore, LLVMModuleCreateWithName, [], []) 134 | if test "$ac_cv_lib_LLVMCore_LLVMModuleCreateWithName" = "no"; then 135 | unset ac_cv_lib_LLVMCore_LLVMModuleCreateWithName 136 | 137 | dnl trying again but now without -lpthread and -ldl 138 | LIBS="-lLLVMSupport $save_LIBS" 139 | AC_CHECK_LIB(LLVMCore, LLVMModuleCreateWithName, [], 140 | [AC_MSG_ERROR(could not find LLVM C bindings)]) 141 | fi 142 | fi 143 | 144 | llvm_num_version="`echo $llvm_version | sed 's/svn$//' | tr . 0`" 145 | AC_DEFINE_UNQUOTED([HS_LLVM_VERSION], [$llvm_num_version], 146 | [Define to the version of LLVM, e.g. 209 for 2.9.]) 147 | 148 | AC_SUBST([llvm_num_version]) 149 | AC_SUBST([llvm_version]) 150 | AC_SUBST([llvm_cppflags]) 151 | AC_SUBST([llvm_cflags]) 152 | AC_SUBST([llvm_extra_libs]) 153 | AC_SUBST([llvm_extra_libdirs]) 154 | AC_SUBST([llvm_extra_ghci_libs]) 155 | AC_SUBST([llvm_target]) 156 | AC_SUBST([llvm_includedir]) 157 | AC_SUBST([llvm_ldoptions]) 158 | 159 | AC_OUTPUT 160 | -------------------------------------------------------------------------------- /base/include/extra.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2008-10, Mahadevan R All rights reserved. 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions are met: 6 | * 7 | * * Redistributions of source code must retain the above copyright notice, 8 | * this list of conditions and the following disclaimer. 9 | * 10 | * * Redistributions in binary form must reproduce the above copyright notice, 11 | * this list of conditions and the following disclaimer in the documentation 12 | * and/or other materials provided with the distribution. 13 | * 14 | * * Neither the name of this software, nor the names of its 15 | * contributors may be used to endorse or promote products derived from 16 | * this software without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | */ 30 | 31 | /** 32 | * These are some "extra" functions not available in the standard LLVM-C 33 | * bindings, but are required / good-to-have inorder to implement the 34 | * Python bindings. 35 | */ 36 | 37 | #ifndef LLVM_PY_EXTRA_H 38 | #define LLVM_PY_EXTRA_H 39 | 40 | #ifdef __cplusplus 41 | extern "C" { 42 | #endif 43 | 44 | /* Notes: 45 | * - Some returned strings must be disposed of by LLVMDisposeMessage. These are 46 | * indicated in the comments. Where it is not indicated, DO NOT call dispose. 47 | */ 48 | 49 | 50 | /* Wraps the LLVMInitializeTarget macro from Target.h */ 51 | unsigned LLVMInitNativeTarget(void); 52 | 53 | 54 | /* Wraps llvm::Module::print(). Dispose the returned string after use, via 55 | * LLVMDisposeMessage(). */ 56 | char *LLVMDumpModuleToString(LLVMModuleRef module); 57 | 58 | /* Wraps llvm::Type::print(). Dispose the returned string after use, via 59 | * LLVMDisposeMessage(). */ 60 | char *LLVMDumpTypeToString(LLVMTypeRef type); 61 | 62 | /* Wraps llvm::Value::print(). Dispose the returned string after use, via 63 | * LLVMDisposeMessage(). */ 64 | char *LLVMDumpValueToString(LLVMValueRef Val); 65 | 66 | /* Wraps llvm::IRBuilder::CreateRet(). */ 67 | LLVMValueRef LLVMBuildRetMultiple(LLVMBuilderRef bulder, LLVMValueRef *values, 68 | unsigned n_values); 69 | 70 | /* Wraps llvm::IRBuilder::CreateGetResult(). */ 71 | LLVMValueRef LLVMBuildGetResult(LLVMBuilderRef builder, LLVMValueRef value, 72 | unsigned index, const char *name); 73 | 74 | /* Wraps llvm::Value::getValueID(). */ 75 | unsigned LLVMValueGetID(LLVMValueRef value); 76 | 77 | /* Wraps llvm::Value::getNumUses(). */ 78 | unsigned LLVMValueGetNumUses(LLVMValueRef value); 79 | 80 | /* Wraps llvm::Value::use_{begin,end}. Allocates LLVMValueRef's as 81 | * required. Number of objects are returned as return value. If that is 82 | * greater than zero, the pointer given out must be freed by a 83 | * subsequent call to LLVMDisposeValueRefArray(). */ 84 | unsigned LLVMValueGetUses(LLVMValueRef value, LLVMValueRef **refs); 85 | 86 | /* Wraps llvm::Value::isUsedInBasicBlock(). */ 87 | unsigned LLVMValueIsUsedInBasicBlock(LLVMValueRef value, LLVMBasicBlockRef bb); 88 | /* See above. */ 89 | void LLVMDisposeValueRefArray(LLVMValueRef *refs); 90 | 91 | /* Wraps llvm:User::getNumOperands(). */ 92 | unsigned LLVMUserGetNumOperands(LLVMValueRef user); 93 | 94 | /* Wraps llvm:User::getOperand(). */ 95 | LLVMValueRef LLVMUserGetOperand(LLVMValueRef user, unsigned idx); 96 | 97 | /* Wraps llvm::ConstantExpr::getVICmp(). */ 98 | LLVMValueRef LLVMConstVICmp(LLVMIntPredicate predicate, LLVMValueRef lhs, 99 | LLVMValueRef rhs); 100 | 101 | /* Wraps llvm::ConstantExpr::getVFCmp(). */ 102 | LLVMValueRef LLVMConstVFCmp(LLVMRealPredicate predicate, LLVMValueRef lhs, 103 | LLVMValueRef rhs); 104 | 105 | /* Wraps llvm::IRBuilder::CreateVICmp(). */ 106 | LLVMValueRef LLVMBuildVICmp(LLVMBuilderRef builder, LLVMIntPredicate predicate, 107 | LLVMValueRef lhs, LLVMValueRef rhs, const char *name); 108 | 109 | /* Wraps llvm::IRBuilder::CreateVFCmp(). */ 110 | LLVMValueRef LLVMBuildVFCmp(LLVMBuilderRef builder, LLVMRealPredicate predicate, 111 | LLVMValueRef lhs, LLVMValueRef rhs, const char *name); 112 | 113 | /* Wraps llvm::Intrinsic::getDeclaration(). */ 114 | LLVMValueRef LLVMGetIntrinsic(LLVMModuleRef builder, int id, 115 | LLVMTypeRef *types, unsigned n_types); 116 | 117 | /* Wraps llvm::Module::getPointerSize(). */ 118 | unsigned LLVMModuleGetPointerSize(LLVMModuleRef module); 119 | 120 | /* Wraps llvm::Module::getOrInsertFunction(). */ 121 | LLVMValueRef LLVMModuleGetOrInsertFunction(LLVMModuleRef module, 122 | const char *name, LLVMTypeRef function_type); 123 | 124 | /* Wraps llvm::GlobalVariable::hasInitializer(). */ 125 | int LLVMHasInitializer(LLVMValueRef global_var); 126 | 127 | /* The following functions wrap various llvm::Instruction::isXXX() functions. 128 | * All of them take an instruction and return 0 (isXXX returned false) or 1 129 | * (isXXX returned false). */ 130 | unsigned LLVMInstIsTerminator (LLVMValueRef inst); 131 | unsigned LLVMInstIsBinaryOp (LLVMValueRef inst); 132 | unsigned LLVMInstIsShift (LLVMValueRef inst); 133 | unsigned LLVMInstIsCast (LLVMValueRef inst); 134 | unsigned LLVMInstIsLogicalShift (LLVMValueRef inst); 135 | unsigned LLVMInstIsArithmeticShift (LLVMValueRef inst); 136 | unsigned LLVMInstIsAssociative (LLVMValueRef inst); 137 | unsigned LLVMInstIsCommutative (LLVMValueRef inst); 138 | unsigned LLVMInstIsTrapping (LLVMValueRef inst); 139 | 140 | /* As above, but these are wrap methods from subclasses of Instruction. */ 141 | unsigned LLVMInstIsVolatile (LLVMValueRef inst); 142 | 143 | /* Wraps llvm::Instruction::getOpcodeName(). */ 144 | const char *LLVMInstGetOpcodeName(LLVMValueRef inst); 145 | 146 | /* Wraps llvm::Instruction::getOpcode(). */ 147 | unsigned LLVMInstGetOpcode(LLVMValueRef inst); 148 | 149 | /* Wraps llvm::CmpInst::getPredicate(). */ 150 | unsigned LLVMCmpInstGetPredicate(LLVMValueRef cmpinst); 151 | 152 | /* Wraps llvm::ParseAssemblyString(). Returns a module reference or NULL (with 153 | * `out' pointing to an error message). Dispose error message after use, via 154 | * LLVMDisposeMessage(). */ 155 | LLVMModuleRef LLVMGetModuleFromAssembly(const char *asmtxt, unsigned txten, 156 | char **out); 157 | 158 | /* Wraps llvm::ParseBitcodeFile(). Returns a module reference or NULL (with 159 | * `out' pointing to an error message). Dispose error message after use, via 160 | * LLVMDisposeMessage(). */ 161 | LLVMModuleRef LLVMGetModuleFromBitcode(const char *bc, unsigned bclen, 162 | char **out); 163 | 164 | #if HS_LLVM_VERSION < 302 165 | /* Wraps llvm::Linker::LinkModules(). Returns 0 on failure (with errmsg 166 | * filled in) and 1 on success. Dispose error message after use with 167 | * LLVMDisposeMessage(). */ 168 | unsigned LLVMLinkModules(LLVMModuleRef dest, LLVMModuleRef src, 169 | unsigned mode, char **errmsg); 170 | #endif 171 | 172 | /* Returns pointer to a heap-allocated block of `*len' bytes containing bit code 173 | * for the given module. NULL on error. */ 174 | unsigned char *LLVMGetBitcodeFromModule(LLVMModuleRef module, unsigned *len); 175 | 176 | /* Wraps llvm::ExecutionEngine::getPointerToFunction(). Returns a pointer 177 | * to the JITted function. */ 178 | void *LLVMGetPointerToFunction(LLVMExecutionEngineRef ee, LLVMValueRef fn); 179 | 180 | /* Wraps llvm::InlineFunction(). Inlines a function. C is the call 181 | * instruction, created by LLVMBuildCall. Even if it fails, the Function 182 | * containing the call is still in a proper state (not changed). */ 183 | int LLVMInlineFunction(LLVMValueRef call); 184 | 185 | #if HS_LLVM_VERSION >= 300 186 | bool LLVMAddEmitObjectPass (LLVMModuleRef modRef, const char* filename); 187 | #endif 188 | 189 | /* All passes are listed in passes-inl.h 190 | * The list is shared between extra.cpp and extra.h. 191 | * 192 | * In this file the declare_or_define_pass macro is used to expand 193 | * the passes into function declarations. 194 | */ 195 | #define declare_or_define_pass(P) \ 196 | void LLVMAdd ## P ## Pass (LLVMPassManagerRef PM); 197 | #include "passes-inl.h" 198 | #undef declare_or_define_pass 199 | 200 | #if HS_LLVM_VERSION < 302 201 | LLVMBool LLVMPrintModuleToFile(LLVMModuleRef M, const char *Filename, char **ErrorMessage); 202 | #endif 203 | 204 | #if HS_LLVM_VERSION < 303 205 | LLVMMemoryBufferRef LLVMCreateMemoryBufferWithMemoryRange( 206 | const char *InputData, 207 | size_t InputDataLength, 208 | const char *BufferName, 209 | LLVMBool RequiresNullTerminator); 210 | 211 | LLVMMemoryBufferRef LLVMCreateMemoryBufferWithMemoryRangeCopy( 212 | const char *InputData, 213 | size_t InputDataLength, 214 | const char *BufferName); 215 | #endif 216 | 217 | 218 | #ifdef __cplusplus 219 | } /* extern "C" */ 220 | #endif 221 | 222 | #endif /* LLVM_PY_EXTRA_H */ 223 | 224 | -------------------------------------------------------------------------------- /base/include/hs_llvm_config.h.in: -------------------------------------------------------------------------------- 1 | /* include/hs_llvm_config.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the header file. */ 4 | #undef HAVE_INTTYPES_H 5 | 6 | /* Define to 1 if you have the `LLVMCore' library (-lLLVMCore). */ 7 | #undef HAVE_LIBLLVMCORE 8 | 9 | /* Define to 1 if you have the header file. */ 10 | #undef HAVE_LLVM_ADT_STRINGREF_H 11 | 12 | /* Define to 1 if you have the header file. */ 13 | #undef HAVE_LLVM_C_CORE_H 14 | 15 | /* Define to 1 if you have the header file. */ 16 | #undef HAVE_LLVM_SUPPORT_DYNAMICLIBRARY_H 17 | 18 | /* Define to 1 if you have the header file. */ 19 | #undef HAVE_MEMORY_H 20 | 21 | /* Define to 1 if you have the header file. */ 22 | #undef HAVE_STDINT_H 23 | 24 | /* Define to 1 if you have the header file. */ 25 | #undef HAVE_STDLIB_H 26 | 27 | /* Define to 1 if you have the header file. */ 28 | #undef HAVE_STRINGS_H 29 | 30 | /* Define to 1 if you have the header file. */ 31 | #undef HAVE_STRING_H 32 | 33 | /* Define to 1 if you have the header file. */ 34 | #undef HAVE_SYS_STAT_H 35 | 36 | /* Define to 1 if you have the header file. */ 37 | #undef HAVE_SYS_TYPES_H 38 | 39 | /* Define to 1 if you have the header file. */ 40 | #undef HAVE_UNISTD_H 41 | 42 | /* Define to the version of LLVM, e.g. 209 for 2.9. */ 43 | #undef HS_LLVM_VERSION 44 | 45 | /* Define to the address where bug reports for this package should be sent. */ 46 | #undef PACKAGE_BUGREPORT 47 | 48 | /* Define to the full name of this package. */ 49 | #undef PACKAGE_NAME 50 | 51 | /* Define to the full name and version of this package. */ 52 | #undef PACKAGE_STRING 53 | 54 | /* Define to the one symbol short name of this package. */ 55 | #undef PACKAGE_TARNAME 56 | 57 | /* Define to the home page for this package. */ 58 | #undef PACKAGE_URL 59 | 60 | /* Define to the version of this package. */ 61 | #undef PACKAGE_VERSION 62 | 63 | /* Define to 1 if you have the ANSI C header files. */ 64 | #undef STDC_HEADERS 65 | -------------------------------------------------------------------------------- /base/include/passes-inl.h: -------------------------------------------------------------------------------- 1 | #ifdef declare_or_define_pass 2 | 3 | /* LLVM-C passes */ 4 | 5 | declare_or_define_pass( AAEval ) 6 | declare_or_define_pass( AliasAnalysisCounter ) 7 | #if HS_LLVM_VERSION < 302 8 | declare_or_define_pass( AlwaysInliner ) 9 | #endif 10 | // Name conflicts with those in LLVM proper, have a safer prefix? 11 | // declare_or_define_pass( BasicAliasAnalysis ) 12 | declare_or_define_pass( BlockPlacement ) 13 | declare_or_define_pass( BreakCriticalEdges ) 14 | declare_or_define_pass( CodeGenPrepare ) 15 | #if HS_LLVM_VERSION < 303 16 | declare_or_define_pass( DbgInfoPrinter ) 17 | #endif 18 | declare_or_define_pass( DeadCodeElimination ) 19 | declare_or_define_pass( DeadInstElimination ) 20 | declare_or_define_pass( DemoteRegisterToMemory ) 21 | declare_or_define_pass( DomOnlyPrinter ) 22 | declare_or_define_pass( DomOnlyViewer ) 23 | declare_or_define_pass( DomPrinter ) 24 | declare_or_define_pass( DomViewer ) 25 | declare_or_define_pass( EdgeProfiler ) 26 | declare_or_define_pass( GlobalsModRef ) 27 | declare_or_define_pass( InstCount ) 28 | declare_or_define_pass( InstructionNamer ) 29 | declare_or_define_pass( LazyValueInfo ) 30 | declare_or_define_pass( LCSSA ) 31 | #if HS_LLVM_VERSION < 302 32 | declare_or_define_pass( LoopDependenceAnalysis ) 33 | #endif 34 | declare_or_define_pass( LoopExtractor ) 35 | declare_or_define_pass( LoopSimplify ) 36 | declare_or_define_pass( LoopStrengthReduce ) 37 | declare_or_define_pass( LowerInvoke ) 38 | declare_or_define_pass( LowerSwitch ) 39 | declare_or_define_pass( MergeFunctions ) 40 | declare_or_define_pass( NoAA ) 41 | declare_or_define_pass( NoProfileInfo ) 42 | declare_or_define_pass( OptimalEdgeProfiler ) 43 | declare_or_define_pass( PartialInlining ) 44 | declare_or_define_pass( PostDomOnlyPrinter ) 45 | declare_or_define_pass( PostDomOnlyViewer ) 46 | declare_or_define_pass( PostDomPrinter ) 47 | declare_or_define_pass( PostDomViewer ) 48 | declare_or_define_pass( ProfileEstimator ) 49 | declare_or_define_pass( ProfileLoader ) 50 | declare_or_define_pass( ProfileVerifier ) 51 | declare_or_define_pass( ScalarEvolutionAliasAnalysis ) 52 | declare_or_define_pass( SingleLoopExtractor ) 53 | declare_or_define_pass( StripNonDebugSymbols ) 54 | #if HS_LLVM_VERSION < 300 55 | declare_or_define_pass( StructRetPromotion ) 56 | declare_or_define_pass( TailDuplication ) 57 | #endif 58 | declare_or_define_pass( UnifyFunctionExitNodes ) 59 | 60 | 61 | 62 | /* Passes declared in extra.cpp goes here */ 63 | 64 | declare_or_define_pass( Internalize2 ) 65 | 66 | #endif 67 | -------------------------------------------------------------------------------- /base/include/support.h: -------------------------------------------------------------------------------- 1 | #ifndef LLVM_HS_SUPPORT_H 2 | #define LLVM_HS_SUPPORT_H 3 | 4 | #ifdef __cplusplus 5 | extern "C" { 6 | #endif 7 | 8 | void LLVMCreateStandardFunctionPasses(LLVMPassManagerRef PM, 9 | unsigned OptimizationLevel); 10 | 11 | void LLVMCreateStandardModulePasses(LLVMPassManagerRef PM, 12 | unsigned OptimizationLevel, 13 | int OptimizeSize, 14 | int UnitAtATime, 15 | int UnrollLoops, 16 | int SimplifyLibCalls, 17 | int HaveExceptions, 18 | int DisableInlining); 19 | 20 | void LLVMDisablePrettyStackTrace(); 21 | 22 | #ifdef __cplusplus 23 | } /* extern "C" */ 24 | #endif 25 | 26 | #endif /* LLVM_HS_SUPPORT_H */ 27 | -------------------------------------------------------------------------------- /base/llvm-base.buildinfo.in: -------------------------------------------------------------------------------- 1 | cpp-options: @llvm_cppflags@ -DTARGET=@llvm_target@ -DHS_LLVM_VERSION=@llvm_num_version@ 2 | cc-options: @llvm_cflags@ -DHS_LLVM_VERSION=@llvm_num_version@ 3 | ghc-options: -pgml @CXX@ 4 | extra-libraries: @llvm_extra_libs@ stdc++ 5 | extra-lib-dirs: @llvm_extra_libdirs@ 6 | x-extra-ghci-libraries: @llvm_extra_ghci_libs@ 7 | ld-options: @llvm_ldoptions@ 8 | include-dirs: @llvm_includedir@ 9 | -------------------------------------------------------------------------------- /base/llvm-base.buildinfo.windows.in: -------------------------------------------------------------------------------- 1 | cpp-options: @llvm_cppflags@ -DHS_LLVM_VERSION=@llvm_num_version@ -DTARGET=X86 2 | cc-options: @llvm_cflags@ -DHS_LLVM_VERSION=@llvm_num_version@ 3 | ghc-options: -pgml g++ 4 | extra-libraries: @llvm_extra_libs@ stdc++ 5 | extra-lib-dirs: @llvm_extra_libdirs@ 6 | ld-options: @llvm_ldoptions@ 7 | include-dirs: @llvm_includedir@ 8 | -------------------------------------------------------------------------------- /base/llvm-base.cabal: -------------------------------------------------------------------------------- 1 | name: llvm-base 2 | version: 3.2.0.2 3 | license: BSD3 4 | license-file: LICENSE 5 | synopsis: FFI bindings to the LLVM compiler toolkit. 6 | description: 7 | FFI bindings to the LLVM compiler toolkit. 8 | . 9 | We try to stay up to date with LLVM releases. The current version 10 | of this package is compatible with at least LLVM 3.2. Please 11 | understand that the package may or may not work against older LLVM 12 | releases; we don't have the time or resources to test across 13 | multiple releases. 14 | . 15 | * New in 3.2: Builds against LLVM 3.2, new mid-level Wrapper interface and ST-based pure interface 16 | . 17 | * New in 3.0: Builds against LLVM 3.0. 18 | . 19 | * New in 0.9.1.1: Builds against LLVM 2.9. 20 | . 21 | * New in 0.9.1.0: Util.Memory for memory related intrinsics. 22 | . 23 | * New in 0.9.0.0: Adapted to LLVM 2.8 (removed support for Union types). 24 | author: Bryan O'Sullivan, Lennart Augustsson, Benjamin Saunders 25 | maintainer: Bryan O'Sullivan , Lennart Augustsson , Benjamin Saunders 26 | homepage: https://github.com/bos/llvm 27 | bug-reports: https://github.com/bos/llvm/issues 28 | stability: experimental 29 | category: Compilers/Interpreters, Code Generation 30 | tested-with: GHC == 6.12.3, GHC == 7.0.3, GHC == 7.2.2 31 | cabal-version: >= 1.6 32 | build-type: Custom 33 | 34 | extra-source-files: 35 | *.md 36 | configure.ac 37 | configure 38 | include/extra.h 39 | include/hs_llvm_config.h.in 40 | include/support.h 41 | include/passes-inl.h 42 | llvm-base.buildinfo.in 43 | llvm-base.buildinfo.windows.in 44 | tools/*.hs 45 | tools/Makefile 46 | 47 | extra-tmp-files: 48 | autom4te.cache 49 | config.log 50 | config.status 51 | configure 52 | include/hs_llvm_config.h 53 | llvm-base.buildinfo 54 | 55 | flag developer 56 | description: operate in developer mode 57 | default: False 58 | 59 | library 60 | build-depends: 61 | base >= 3 && < 5, mtl >= 2.1 && < 3 62 | 63 | ghc-options: -Wall 64 | 65 | if flag(developer) 66 | ghc-options: -Werror 67 | 68 | exposed-modules: 69 | LLVM.FFI.Analysis 70 | LLVM.FFI.BitReader 71 | LLVM.FFI.BitWriter 72 | LLVM.FFI.Core 73 | LLVM.FFI.ExecutionEngine 74 | LLVM.FFI.Support 75 | LLVM.FFI.Linker 76 | LLVM.FFI.Target 77 | LLVM.FFI.Transforms.IPO 78 | LLVM.FFI.Transforms.Scalar 79 | LLVM.FFI.Transforms.PassManagerBuilder 80 | LLVM.FFI.AssemblyReader 81 | LLVM.Target.Native 82 | 83 | LLVM.Wrapper.Core 84 | LLVM.Wrapper.BitReader 85 | LLVM.Wrapper.BitWriter 86 | LLVM.Wrapper.Analysis, 87 | LLVM.Wrapper.ExecutionEngine 88 | LLVM.Wrapper.Target 89 | LLVM.Wrapper.Linker 90 | LLVM.Wrapper.Transforms.PassManagerBuilder 91 | LLVM.ST 92 | 93 | other-modules: 94 | LLVM.Target.ARM 95 | LLVM.Target.CellSPU 96 | LLVM.Target.CppBackend 97 | LLVM.Target.MSP430 98 | LLVM.Target.Mips 99 | LLVM.Target.PowerPC 100 | LLVM.Target.Sparc 101 | LLVM.Target.X86 102 | LLVM.Target.XCore 103 | 104 | LLVM.Wrapper.Internal 105 | 106 | include-dirs: include 107 | C-Sources: 108 | cbits/extra.cpp 109 | cbits/free.c 110 | cbits/malloc.c 111 | cbits/support.cpp 112 | 113 | source-repository head 114 | type: git 115 | location: git://github.com/bos/llvm.git 116 | 117 | source-repository head 118 | type: mercurial 119 | location: https://bitbucket.org/bos/llvm/ 120 | -------------------------------------------------------------------------------- /base/tools/DiffFFI.hs: -------------------------------------------------------------------------------- 1 | module DiffFFI (main) where 2 | 3 | import Control.Monad (forM_) 4 | import Data.List (foldl') 5 | import qualified Data.Map as M 6 | import System.Environment (getArgs) 7 | import System.Exit (exitFailure) 8 | import System.IO (hPutStrLn, stderr) 9 | import Text.Regex.Posix ((=~)) 10 | 11 | import FunctionMangulation (pattern, rewriteFunction) 12 | 13 | cFunctions :: String -> M.Map String String 14 | cFunctions s = foldl' go M.empty (s =~ pattern) 15 | where go m (_:ret:name:params:_) = 16 | M.insert ("LLVM" ++ name) (rewriteFunction ret name params) m 17 | go m _ = m 18 | 19 | hsFunctions :: String -> M.Map String String 20 | hsFunctions s = foldl' go M.empty (s =~ pat) 21 | where pat = "\"([a-zA-Z0-9_]+)\"[ \t\n]+([a-zA-Z0-9_']+)" 22 | go m (_:cname:hsname:_) = M.insert cname hsname m 23 | go m _ = m 24 | 25 | main :: IO () 26 | main = do 27 | args <- getArgs 28 | case args of 29 | [cFile, hsFile] -> do 30 | c <- cFunctions `fmap` readFile cFile 31 | hs <- hsFunctions `fmap` readFile hsFile 32 | putStrLn "In C, not Haskell:" 33 | forM_ (M.toAscList $ M.difference c hs) $ \(_, hsfunc) -> 34 | putStrLn hsfunc 35 | putStrLn "In Haskell, not C:" 36 | forM_ (M.keys $ M.difference hs c) $ putStrLn . (" "++) 37 | _ -> do 38 | hPutStrLn stderr "Usage: DiffFFI cFile hsFile" 39 | exitFailure 40 | -------------------------------------------------------------------------------- /base/tools/FunctionMangler.hs: -------------------------------------------------------------------------------- 1 | module FunctionMangler (main) where 2 | 3 | import Data.List (intercalate) 4 | 5 | import FunctionMangulation (rewrite) 6 | 7 | main :: IO () 8 | main = interact (intercalate "\n\n" . concat . rewrite) >> putStr "\n" 9 | -------------------------------------------------------------------------------- /base/tools/FunctionMangulation.hs: -------------------------------------------------------------------------------- 1 | module FunctionMangulation 2 | ( 3 | pattern 4 | , rewrite 5 | , rewriteFunction 6 | ) where 7 | 8 | import Control.Monad (forM) 9 | import Data.Char (isSpace, toLower) 10 | import Data.List (intercalate, isPrefixOf, isSuffixOf) 11 | import Text.Regex.Posix ((=~), (=~~)) 12 | 13 | pattern :: String 14 | pattern = "^([A-Za-z0-9_ ]+ ?\\*?)[ \t\n]*" ++ 15 | "LLVM([A-Za-z0-9_]+)\\(([a-zA-Z0-9_*, \t\n]+)\\);" 16 | 17 | dropSpace :: String -> String 18 | dropSpace = dropWhile isSpace 19 | 20 | renameType :: String -> String 21 | renameType t | "LLVM" `isPrefixOf` t = rename' (drop 4 t) 22 | | otherwise = rename' t 23 | where rename' "int" = "CInt" 24 | rename' "unsigned" = "CUInt" 25 | rename' "long long" = "CLLong" 26 | rename' "unsigned long long" = "CULLong" 27 | rename' "void" = "()" 28 | rename' "const char *" = "CString" 29 | rename' "char *" = "CString" 30 | rename' s | "*" `isSuffixOf` s = pointer s 31 | | otherwise = strip s 32 | pointer p = case reverse p of 33 | ('*':ps) -> "(Ptr " ++ rename' (reverse ps) ++ ")" 34 | _ -> p 35 | 36 | split :: (a -> Bool) -> [a] -> [[a]] 37 | split p xs = case break p xs of 38 | (h,(_:t)) -> h : split p t 39 | (s,_) -> [s] 40 | 41 | strip :: String -> String 42 | strip = reverse . dropWhile isSpace . reverse . dropSpace 43 | 44 | dropName :: String -> String 45 | dropName s = 46 | case s =~ "^((const )?[A-Za-z0-9_]+( \\*+)?) ?[A-Za-z0-9]*$" of 47 | ((_:typ:_):_) -> typ 48 | _ -> "{- oops! -} " ++ s 49 | 50 | rewriteFunction :: String -> String -> String -> String 51 | rewriteFunction cret cname cparams = 52 | let ret = "IO " ++ renameType (strip cret) 53 | params = map renameParam . split (==',') $ cparams 54 | params' = if params == ["()"] then [] else params 55 | name = let (n:ame) = cname in toLower n : ame 56 | in foreign ++ "\"LLVM" ++ cname ++ "\" " ++ name ++ 57 | "\n :: " ++ intercalate " -> " (params' ++ [ret]) 58 | where renameParam = renameType . dropName . strip 59 | foreign = "foreign import ccall unsafe " 60 | 61 | rewrite :: Monad m => String -> m [String] 62 | rewrite s = do 63 | matches <- s =~~ pattern 64 | forM matches $ \(_:cret:cname:cparams:_) -> 65 | return (rewriteFunction cret cname cparams) 66 | -------------------------------------------------------------------------------- /base/tools/IntrinsicMangler.hs: -------------------------------------------------------------------------------- 1 | module IntrinsicMangler (main) where 2 | 3 | import Control.Monad (forM_) 4 | import qualified Data.ByteString.Char8 as C 5 | import Data.Maybe (catMaybes) 6 | import Text.Regex.Posix ((=~~)) 7 | 8 | maybeName :: C.ByteString -> Maybe C.ByteString 9 | maybeName line = do 10 | ((_:name:_):_) <- line =~~ "^[ \t]*([a-z0-9_]+),[ \t]*//[ \t]*llvm\\." 11 | return name 12 | 13 | main :: IO () 14 | main = do 15 | input <- (catMaybes . map maybeName . C.lines) `fmap` C.getContents 16 | 17 | putStrLn "-- automatically generated file - do not edit!" 18 | putStrLn "module LLVM.Core.Intrinsics (Intrinsic(..)) where" 19 | putStrLn "data Intrinsic =" 20 | putStrLn " NotIntrinsic" 21 | forM_ input $ C.putStrLn . (C.append (C.pack " | I_")) 22 | putStrLn " deriving (Eq, Ord, Enum, Show)" 23 | -------------------------------------------------------------------------------- /base/tools/Makefile: -------------------------------------------------------------------------------- 1 | ghc := ghc 2 | ghcflags := -O -Wall -Werror 3 | tools := DiffFFI FunctionMangler IntrinsicMangler 4 | 5 | all: $(tools) 6 | 7 | %: %.hs 8 | $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< 9 | 10 | clean: 11 | -rm -f *.o *.hi $(tools) *.exe 12 | -------------------------------------------------------------------------------- /base/tools/ltrace.readme: -------------------------------------------------------------------------------- 1 | Ltrace allows you to log the calls from your Haskell program 2 | into the LLVM C bindings. 3 | From this log you can reconstruct a C program 4 | that performs the same actions as your Haskell program. 5 | I needed this several times in order to create bug tickets 6 | for http://llvm.org/bugs. 7 | I hope you do not need it for this purpose, too. 8 | 9 | If you want to trace the LLVM calls of a Haskell program Main 10 | it is essential to build it 11 | with static calls from Main into Haskell-llvm 12 | (that is no -dynamic flag for ghc) 13 | but dynamic calls from Haskell-llvm to LLVM 14 | (-lLLVM-2.8rc instead of `llvm-config --libs`). 15 | You should get an executable of around 10 MB size. 16 | If you link LLVM statically into the executable, 17 | then ltrace cannot track calls to LLVM at all. 18 | Such executables are several tens of MB large. 19 | If you link dynamically to Haskell-llvm, 20 | then only calls from Main to Haskell-llvm are tracked, 21 | but not those from Haskell-llvm to LLVM. 22 | If you are lucky some calls from Main to Haskell-llvm are inlined by GHC, 23 | and then some calls go directly from Main to LLVM 24 | and are thus visible for ltrace. 25 | Such executables are usually quite small 26 | (for todays norms), about some tens KB. 27 | You do not have this fine control of compilation 28 | when compiling with Cabal. 29 | I think you must call ghc directly like in: 30 | 31 | $ ghc -lLLVM-2.8rc -package llvm -O -debug -o main src/Main.hs 32 | 33 | 34 | You can then generate a log of the LLVM calls from Main using: 35 | 36 | $ ltrace -F ltrace.config --library=/usr/local/lib/libLLVM-2.8rc.so main 37 | -------------------------------------------------------------------------------- /examples/Align.hs: -------------------------------------------------------------------------------- 1 | module Align (main) where 2 | import Data.TypeLevel(D1, D4) 3 | import Data.Word 4 | 5 | import LLVM.Core 6 | import LLVM.ExecutionEngine 7 | 8 | main :: IO () 9 | main = do 10 | -- Initialize jitter 11 | initializeNativeTarget 12 | 13 | td <- getTargetData 14 | print (littleEndian td, 15 | aBIAlignmentOfType td $ typeRef (undefined :: Word32), 16 | aBIAlignmentOfType td $ typeRef (undefined :: Word64), 17 | aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float), 18 | aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double), 19 | storeSizeOfType td $ typeRef (undefined :: Vector D4 Float), 20 | intPtrType td 21 | ) 22 | -------------------------------------------------------------------------------- /examples/Arith.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Arith where 4 | import Data.Int 5 | import Data.TypeLevel(D4) 6 | import LLVM.Core 7 | import LLVM.ExecutionEngine 8 | import LLVM.Util.Arithmetic 9 | import LLVM.Util.Foreign as F 10 | import LLVM.Util.File(writeCodeGenModule) 11 | 12 | import Foreign.Storable 13 | {- 14 | import Foreign.Ptr 15 | import Foreign.Marshal.Utils 16 | import Foreign.Marshal.Alloc as F 17 | -} 18 | 19 | mSomeFn :: forall a b . (IsConst a, Floating a, IsFloating a, CallIntrinsic a, 20 | FunctionRet a, Cmp a b 21 | ) => CodeGenModule (Function (a -> IO a)) 22 | mSomeFn = do 23 | foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y 24 | let foo' = toArithFunction foo 25 | createFunction ExternalLinkage $ arithFunction $ \ x -> do 26 | y <- set $ x^3 27 | sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y 28 | 29 | mFib :: CodeGenModule (Function (Int32 -> IO Int32)) 30 | mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) 31 | 32 | type V = Vector D4 Float 33 | 34 | mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) 35 | mVFun = do 36 | fn :: Function (V -> IO V) 37 | <- createFunction ExternalLinkage $ arithFunction $ \ x -> 38 | log x * exp x * x - 16 39 | 40 | vectorToPtr fn 41 | 42 | 43 | main :: IO () 44 | main = do 45 | -- Initialize jitter 46 | initializeNativeTarget 47 | 48 | let mSomeFn' = mSomeFn 49 | ioSomeFn <- simpleFunction mSomeFn' 50 | let someFn :: Double -> Double 51 | someFn = unsafePurify ioSomeFn 52 | 53 | writeCodeGenModule "Arith.bc" mSomeFn' 54 | 55 | print (someFn 10) 56 | print (someFn 2) 57 | 58 | writeCodeGenModule "ArithFib.bc" mFib 59 | 60 | fib <- simpleFunction mFib 61 | fib 22 >>= print 62 | 63 | {- 64 | writeCodeGenModule "VArith.bc" mVFun 65 | 66 | ioVFun <- simpleFunction mVFun 67 | let v = toVector (1,2,3,4) 68 | 69 | r <- vectorPtrWrap ioVFun v 70 | print r 71 | -} 72 | 73 | vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) 74 | vectorToPtr f = 75 | createFunction ExternalLinkage $ \ px py -> do 76 | x <- load px 77 | y <- call f x 78 | store y py 79 | ret () 80 | 81 | vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V 82 | vectorPtrWrap f v = 83 | with v $ \ aPtr -> 84 | F.alloca $ \ bPtr -> do 85 | f aPtr bPtr 86 | peek bPtr 87 | -------------------------------------------------------------------------------- /examples/Array.hs: -------------------------------------------------------------------------------- 1 | module Array where 2 | import Data.Word 3 | 4 | import LLVM.Core 5 | --import LLVM.ExecutionEngine 6 | import LLVM.Util.Loop 7 | import LLVM.Util.Optimize 8 | 9 | cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) 10 | cg = do 11 | dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do 12 | r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do 13 | ai <- mul aStride i 14 | bi <- mul bStride i 15 | ap <- getElementPtr aPtr (ai, ()) 16 | bp <- getElementPtr bPtr (bi, ()) 17 | a <- load ap 18 | b <- load bp 19 | ab <- mul a b 20 | add (s :: Value Double) ab 21 | ret r 22 | let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) 23 | 24 | -- multiply a:[n x m], b:[m x l] 25 | matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do 26 | forLoop (valueOf 0) n () $ \ ni () -> do 27 | forLoop (valueOf 0) l () $ \ li () -> do 28 | ni' <- mul ni m 29 | row <- getElementPtr aPtr (ni', ()) 30 | col <- getElementPtr bPtr (li, ()) 31 | x <- call dotProd m row (valueOf 1) col m 32 | j <- add ni' li 33 | p <- getElementPtr cPtr (j, ()) 34 | store x p 35 | return () 36 | ret () 37 | let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) 38 | 39 | let fillArray _ [] = return () 40 | fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs 41 | 42 | test <- createNamedFunction ExternalLinkage "test" $ \ x -> do 43 | a <- arrayMalloc (4 :: Word32) 44 | fillArray a $ map valueOf [1,2,3,4] 45 | b <- arrayMalloc (4 :: Word32) 46 | fillArray b [x,x,x,x] 47 | c <- arrayMalloc (4 :: Word32) 48 | _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c 49 | ret c 50 | let _ = test :: Function (Double -> IO (Ptr Double)) 51 | 52 | return test 53 | 54 | main :: IO () 55 | main = do 56 | -- Initialize jitter 57 | initializeNativeTarget 58 | m <- newModule 59 | _f <- defineModule m cg 60 | writeBitcodeToFile "Arr.bc" m 61 | _ <- optimizeModule 3 m 62 | writeBitcodeToFile "Arr-opt.bc" m 63 | -------------------------------------------------------------------------------- /examples/BrainF.hs: -------------------------------------------------------------------------------- 1 | module BrainF where 2 | -- BrainF compiler example 3 | -- 4 | -- The BrainF language has 8 commands: 5 | -- Command Equivalent C Action 6 | -- ------- ------------ ------ 7 | -- , *h=getchar(); Read a character from stdin, 255 on EOF 8 | -- . putchar(*h); Write a character to stdout 9 | -- - --*h; Decrement tape 10 | -- + ++*h; Increment tape 11 | -- < --h; Move head left 12 | -- > ++h; Move head right 13 | -- [ while(*h) { Start loop 14 | -- ] } End loop 15 | -- 16 | import Control.Monad(when) 17 | import Data.Word 18 | import Data.Int 19 | import System.Environment(getArgs) 20 | import System.Exit(exitFailure) 21 | import qualified System.IO as IO 22 | 23 | import LLVM.Core 24 | import LLVM.Util.File(writeCodeGenModule) 25 | import qualified LLVM.Util.Memory as Memory 26 | import LLVM.ExecutionEngine 27 | 28 | main :: IO () 29 | main = do 30 | -- Initialize jitter 31 | initializeNativeTarget 32 | 33 | aargs <- getArgs 34 | let (args, debug) = 35 | case aargs of 36 | "-":rargs -> (rargs, True) 37 | _ -> (aargs, False) 38 | let text = "+++++++++++++++++++++++++++++++++" ++ -- constant 33 39 | ">++++" ++ -- next cell, loop counter, constant 4 40 | "[>++++++++++" ++ -- loop, loop counter, constant 10 41 | "[" ++ -- loop 42 | "<<.+>>-" ++ -- back to 33, print, increment, forward, decrement loop counter 43 | "]<-" ++ -- back to 4, decrement loop counter 44 | "]" ++ 45 | "++++++++++." 46 | prog <- 47 | case args of 48 | [] -> return text 49 | fileName:[] -> readFile fileName 50 | _ -> 51 | IO.hPutStrLn IO.stderr "too many arguments" >> 52 | exitFailure 53 | 54 | when debug $ 55 | writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536 56 | 57 | bfprog <- simpleFunction $ brainCompile debug prog 65536 58 | when (prog == text) $ 59 | putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" 60 | bfprog 61 | 62 | brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) 63 | brainCompile _debug instrs wmemtotal = do 64 | -- LLVM functions 65 | memset <- Memory.memset 66 | getchar <- newNamedFunction ExternalLinkage "getchar" 67 | :: TFunction (IO Int32) 68 | putchar <- newNamedFunction ExternalLinkage "putchar" 69 | :: TFunction (Int32 -> IO Int32) 70 | 71 | -- Generate code, first argument is the list of commands, 72 | -- second argument is a stack of loop contexts, and the 73 | -- third argument is the current register for the head and 74 | -- the current basic block. 75 | -- A loop context is a triple of the phi node, the loop top label, 76 | -- and the loop exit label. 77 | let generate [] [] _ = 78 | return () 79 | generate [] (_:_) _ = error "Missing ]" 80 | generate (']':_) [] _ = error "Missing [" 81 | generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do 82 | -- The loop has terminated, add the phi node at the top, 83 | -- branch to the top, and set up the exit label. 84 | addPhiInputs cphi [(cur, bb)] 85 | br loop 86 | defineBasicBlock exit 87 | generate is bs (cphi, exit) 88 | 89 | generate ('[':is) bs curbb = do 90 | -- Start a new loop. 91 | loop <- newBasicBlock -- loop top 92 | body <- newBasicBlock -- body of the loop 93 | exit <- newBasicBlock -- loop exit label 94 | br loop 95 | 96 | defineBasicBlock loop 97 | cur <- phi [curbb] -- will get one more input from the loop terminator. 98 | val <- load cur -- load head byte. 99 | eqz <- cmp CmpEQ val (0::Word8) -- test if it is 0. 100 | condBr eqz exit body -- and branch accordingly. 101 | 102 | defineBasicBlock body 103 | generate is ((cur, loop, exit) : bs) (cur, body) 104 | 105 | generate (i:is) bs (curhead, bb) = do 106 | -- A simple command, with no new basic blocks. 107 | -- Just update which register the head is in. 108 | curhead' <- gen curhead i 109 | generate is bs (curhead', bb) 110 | 111 | gen cur ',' = do 112 | -- Read a character. 113 | char32 <- call getchar 114 | char8 <- trunc char32 115 | store char8 cur 116 | return cur 117 | gen cur '.' = do 118 | -- Write a character. 119 | char8 <- load cur 120 | char32 <- zext char8 121 | _ <- call putchar char32 122 | return cur 123 | gen cur '-' = do 124 | -- Decrement byte at head. 125 | val <- load cur 126 | val' <- sub val (1 :: Word8) 127 | store val' cur 128 | return cur 129 | gen cur '+' = do 130 | -- Increment byte at head. 131 | val <- load cur 132 | val' <- add val (1 :: Word8) 133 | store val' cur 134 | return cur 135 | gen cur '<' = 136 | -- Decrement head. 137 | getElementPtr cur ((-1) :: Word32, ()) 138 | gen cur '>' = 139 | -- Increment head. 140 | getElementPtr cur (1 :: Word32, ()) 141 | gen _ c = error $ "Bad character in program: " ++ show c 142 | 143 | 144 | brainf <- createFunction ExternalLinkage $ do 145 | ptr_arr <- arrayMalloc wmemtotal 146 | _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False) 147 | -- _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ()) 148 | -- Start head in the middle. 149 | curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ()) 150 | 151 | bb <- getCurrentBasicBlock 152 | generate instrs [] (curhead, bb) 153 | 154 | free ptr_arr 155 | ret () 156 | 157 | return brainf 158 | -------------------------------------------------------------------------------- /examples/CallConv.hs: -------------------------------------------------------------------------------- 1 | module CallConv where 2 | 3 | import LLVM.Core 4 | import LLVM.FFI.Core (CallingConvention(GHC)) 5 | 6 | import Data.Word (Word32) 7 | 8 | 9 | -- Our module will have these two functions. 10 | data Mod = Mod { 11 | m1 :: Function (Word32 -> IO Word32), 12 | m2 :: Function (Word32 -> Word32 -> IO Word32) 13 | } 14 | 15 | main :: IO () 16 | main = do 17 | m <- newModule 18 | _fns <- defineModule m buildMod 19 | --_ <- optimizeModule 3 m 20 | writeBitcodeToFile "CallConv.bc" m 21 | return () 22 | 23 | buildMod :: CodeGenModule Mod 24 | buildMod = do 25 | mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do 26 | r <- add x y 27 | ret r 28 | setFuncCallConv mod2 GHC 29 | mod1 <- newNamedFunction ExternalLinkage "test" 30 | defineFunction mod1 $ \ arg -> do 31 | r <- callWithConv GHC mod2 arg (valueOf 1) 32 | ret r 33 | return $ Mod mod1 mod2 34 | -------------------------------------------------------------------------------- /examples/Convert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} 2 | module Convert(Convert(..)) where 3 | import Data.Int 4 | import Data.Word 5 | import Foreign.Ptr (FunPtr) 6 | 7 | type Importer f = FunPtr f -> f 8 | 9 | class Convert f where 10 | convert :: Importer f 11 | 12 | foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float) 13 | instance Convert (IO Float) where convert = c_IOFloat 14 | 15 | foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float) 16 | instance Convert (Float -> IO Float) where convert = c_Float_IOFloat 17 | 18 | foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float) 19 | instance Convert (Float -> Float) where convert = c_Float_Float 20 | 21 | foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double) 22 | instance Convert (IO Double) where convert = c_IODouble 23 | 24 | foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double) 25 | instance Convert (Double -> IO Double) where convert = c_Double_IODouble 26 | 27 | foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double) 28 | instance Convert (Double -> Double) where convert = c_Double_Double 29 | 30 | foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32) 31 | instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32 32 | 33 | foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32) 34 | instance Convert (Word32 -> Word32) where convert = c_Word32_Word32 35 | 36 | foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32) 37 | instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32 38 | 39 | foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32) 40 | instance Convert (Int32 -> Int32) where convert = c_Int32_Int32 41 | 42 | -------------------------------------------------------------------------------- /examples/DotProd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} 2 | module DotProd where 3 | import Data.Word 4 | import Data.TypeLevel.Num(D2, D4, D8, toNum) 5 | import LLVM.Core 6 | import LLVM.ExecutionEngine 7 | import LLVM.Util.Loop 8 | import LLVM.Util.File(writeCodeGenModule) 9 | import LLVM.Util.Foreign 10 | 11 | mDotProd :: forall n a . (Pos n, 12 | IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a, 13 | FunctionRet a 14 | ) => 15 | CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) 16 | mDotProd = 17 | createFunction ExternalLinkage $ \ size aPtr bPtr -> do 18 | s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do 19 | 20 | ap <- getElementPtr aPtr (i, ()) -- index into aPtr 21 | bp <- getElementPtr bPtr (i, ()) -- index into bPtr 22 | a <- load ap -- load element from a vector 23 | b <- load bp -- load element from b vector 24 | ab <- mul a b -- multiply them 25 | add s ab -- accumulate sum 26 | 27 | r <- forLoop (valueOf (0::Word32)) (valueOf (toNum (undefined :: n))) 28 | (valueOf 0) $ \ i r -> do 29 | ri <- extractelement s i 30 | add r ri 31 | ret (r :: Value a) 32 | 33 | type R = Float 34 | type T = Vector D4 R 35 | 36 | main :: IO () 37 | main = do 38 | -- Initialize jitter 39 | initializeNativeTarget 40 | let mDotProd' = mDotProd 41 | writeCodeGenModule "DotProd.bc" mDotProd' 42 | 43 | ioDotProd <- simpleFunction mDotProd' 44 | let dotProd :: [T] -> [T] -> R 45 | dotProd a b = 46 | unsafePurify $ 47 | withArrayLen a $ \ aLen aPtr -> 48 | withArrayLen b $ \ bLen bPtr -> 49 | ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr 50 | 51 | 52 | let a = [1 .. 8] 53 | b = [4 .. 11] 54 | print $ dotProd (vectorize 0 a) (vectorize 0 b) 55 | print $ sum $ zipWith (*) a b 56 | 57 | class Vectorize n a where 58 | vectorize :: a -> [a] -> [Vector n a] 59 | 60 | {- 61 | instance (IsPrimitive a) => Vectorize D1 a where 62 | vectorize _ [] = [] 63 | vectorize x (x1:xs) = toVector x1 : vectorize x xs 64 | -} 65 | 66 | instance (IsPrimitive a) => Vectorize D2 a where 67 | vectorize _ [] = [] 68 | vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs 69 | vectorize x xs = vectorize x $ xs ++ [x] 70 | 71 | instance (IsPrimitive a) => Vectorize D4 a where 72 | vectorize _ [] = [] 73 | vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs 74 | vectorize x xs = vectorize x $ xs ++ [x] 75 | 76 | instance (IsPrimitive a) => Vectorize D8 a where 77 | vectorize _ [] = [] 78 | vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs 79 | vectorize x xs = vectorize x $ xs ++ [x] 80 | -------------------------------------------------------------------------------- /examples/Fibonacci.hs: -------------------------------------------------------------------------------- 1 | module Fibonacci where 2 | import Prelude hiding(and, or) 3 | import System.Environment(getArgs) 4 | import Control.Monad(forM_) 5 | import Data.Word 6 | 7 | import LLVM.Core 8 | import LLVM.Util.Optimize 9 | import LLVM.ExecutionEngine 10 | 11 | -- Our module will have these two functions. 12 | data Mod = Mod { 13 | mfib :: Function (Word32 -> IO Word32), 14 | mplus :: Function (Word32 -> Word32 -> IO Word32) 15 | } 16 | 17 | main :: IO () 18 | main = do 19 | args <- getArgs 20 | let args' = if null args then ["10"] else args 21 | 22 | -- Initialize jitter 23 | initializeNativeTarget 24 | -- Create a module, 25 | m <- newNamedModule "fib" 26 | -- and define its contents. 27 | fns <- defineModule m buildMod 28 | 29 | -- Show the code for the two functions, just for fun. 30 | --dumpValue $ mfib fns 31 | --dumpValue $ mplus fns 32 | -- Write the code to a file for later perusal. 33 | -- Can be disassembled with llvm-dis. 34 | writeBitcodeToFile "Fibonacci.bc" m 35 | 36 | _ <- optimizeModule 3 m 37 | writeBitcodeToFile "Fibonacci-opt.bc" m 38 | 39 | -- Generate code for mfib, and then throw away the IO in the type. 40 | -- The result is an ordinary Haskell function. 41 | iofib <- runEngineAccess $ do 42 | addModule m 43 | generateFunction $ mfib fns 44 | let fib = unsafePurify iofib 45 | 46 | -- Run fib for the arguments. 47 | forM_ args' $ \num -> do 48 | putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) 49 | return () 50 | 51 | buildMod :: CodeGenModule Mod 52 | buildMod = do 53 | -- Add two numbers in a cumbersome way. 54 | plus <- createFunction InternalLinkage $ \ x y -> do 55 | -- Create three additional basic blocks, need to be created before being referred to. 56 | l1 <- newBasicBlock 57 | l2 <- newBasicBlock 58 | l3 <- newBasicBlock 59 | 60 | -- Test if x is even/odd. 61 | a <- and x (1 :: Word32) 62 | c <- cmp CmpEQ a (0 :: Word32) 63 | condBr c l1 l2 64 | 65 | -- Do x+y if even. 66 | defineBasicBlock l1 67 | r1 <- add x y 68 | br l3 69 | 70 | -- Do y+x if odd. 71 | defineBasicBlock l2 72 | r2 <- add y x 73 | br l3 74 | 75 | defineBasicBlock l3 76 | -- Join the two execution paths with a phi instruction. 77 | r <- phi [(r1, l1), (r2, l2)] 78 | ret r 79 | 80 | -- The usual doubly recursive Fibonacci. 81 | -- Use new&define so the name fib is defined in the body for recursive calls. 82 | fib <- newNamedFunction ExternalLinkage "fib" 83 | defineFunction fib $ \ arg -> do 84 | -- Create the two basic blocks. 85 | recurse <- newBasicBlock 86 | exit <- newBasicBlock 87 | 88 | -- Test if arg > 2 89 | test <- cmp CmpGT arg (2::Word32) 90 | condBr test recurse exit 91 | 92 | -- Just return 1 if not > 2 93 | defineBasicBlock exit 94 | ret (1::Word32) 95 | 96 | -- Recurse if > 2, using the cumbersome plus to add the results. 97 | defineBasicBlock recurse 98 | x1 <- sub arg (1::Word32) 99 | fibx1 <- call fib x1 100 | x2 <- sub arg (2::Word32) 101 | fibx2 <- call fib x2 102 | r <- call plus fibx1 fibx2 103 | ret r 104 | 105 | -- Return the two functions. 106 | return $ Mod fib plus 107 | -------------------------------------------------------------------------------- /examples/HelloJIT.hs: -------------------------------------------------------------------------------- 1 | module HelloJIT (main) where 2 | 3 | import Data.Word 4 | 5 | import LLVM.Core 6 | import LLVM.ExecutionEngine 7 | 8 | bldGreet :: CodeGenModule (Function (IO ())) 9 | bldGreet = withStringNul "Hello, JIT!" (\greetz -> do 10 | puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) 11 | func <- createFunction ExternalLinkage $ do 12 | tmp <- getElementPtr0 greetz (0::Word32, ()) 13 | _ <- call puts tmp -- Throw away return value. 14 | ret () 15 | return func) 16 | 17 | main :: IO () 18 | main = do 19 | initializeNativeTarget 20 | greet <- simpleFunction bldGreet 21 | greet 22 | greet 23 | greet 24 | return () 25 | -------------------------------------------------------------------------------- /examples/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module List(main) where 4 | 5 | import LLVM.Util.Loop (Phi, phis, addPhis, ) 6 | import LLVM.ExecutionEngine (simpleFunction, ) 7 | import LLVM.Core hiding ( sizeOf ) 8 | import qualified System.IO as IO 9 | 10 | import Data.Word (Word32, ) 11 | import Data.Int (Int32, ) 12 | import Foreign.Storable (Storable, sizeOf, ) 13 | import Foreign.Marshal.Array (allocaArray, ) 14 | 15 | import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) 16 | import Foreign.Ptr (FunPtr, ) 17 | import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) 18 | 19 | 20 | {- 21 | I had to export Phi's methods in llvm-0.6.8 22 | in order to be able to implement this function. 23 | -} 24 | arrayLoop :: 25 | (Phi a, IsType b, 26 | Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) => 27 | Value i -> Value (Ptr b) -> a -> 28 | (Value (Ptr b) -> a -> CodeGenFunction r a) -> 29 | CodeGenFunction r a 30 | arrayLoop len ptr start loopBody = do 31 | top <- getCurrentBasicBlock 32 | loop <- newBasicBlock 33 | body <- newBasicBlock 34 | exit <- newBasicBlock 35 | 36 | br loop 37 | 38 | defineBasicBlock loop 39 | i <- phi [(len, top)] 40 | p <- phi [(ptr, top)] 41 | vars <- phis top start 42 | t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) 43 | condBr t body exit 44 | 45 | defineBasicBlock body 46 | 47 | vars' <- loopBody p vars 48 | i' <- sub i (valueOf 1 `asTypeOf` len) 49 | p' <- getElementPtr p (valueOf 1 :: Value Word32, ()) 50 | 51 | body' <- getCurrentBasicBlock 52 | addPhis body' vars vars' 53 | addPhiInputs i [(i', body')] 54 | addPhiInputs p [(p', body')] 55 | br loop 56 | 57 | defineBasicBlock exit 58 | return vars 59 | 60 | 61 | mList :: 62 | CodeGenModule (Function 63 | (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) 64 | mList = 65 | createFunction ExternalLinkage $ \ ref size ptr -> do 66 | next <- staticFunction nelem 67 | let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32) 68 | s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do 69 | flip store ptri =<< call next ref 70 | return y 71 | ret (s :: Value Int32) 72 | 73 | renderList :: IO () 74 | renderList = do 75 | m <- newModule 76 | _f <- defineModule m mList 77 | writeBitcodeToFile "List.bc" m 78 | 79 | fill <- simpleFunction mList 80 | stable <- newStablePtr =<< newIORef [3,5..] 81 | IO.withFile "listcontent.u32" IO.WriteMode $ \h -> 82 | let len = 100 83 | in allocaArray len $ \ ptr -> 84 | fill stable (fromIntegral len) ptr >> 85 | IO.hPutBuf h ptr (len*sizeOf(undefined::Int32)) 86 | freeStablePtr stable 87 | 88 | 89 | foreign import ccall "&nextListElement" 90 | nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) 91 | 92 | foreign export ccall 93 | nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 94 | 95 | nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 96 | nextListElement stable = 97 | do ioRef <- deRefStablePtr stable 98 | xt <- readIORef ioRef 99 | case xt of 100 | [] -> return 0 101 | (x:xs) -> writeIORef ioRef xs >> return x 102 | 103 | 104 | main :: IO () 105 | main = do 106 | -- Initialize jitter 107 | initializeNativeTarget 108 | renderList 109 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | ghc := ghc 2 | ghcflags := -Wall -optl -w 3 | # -DHAS_GETPOINTERTOGLOBAL=1 4 | examples := ModuleMaker HelloJIT Fibonacci BrainF Vector Array DotProd Arith Align Struct Varargs List CallConv 5 | 6 | all: $(examples:%=%.exe) 7 | 8 | Vector: Convert.hs 9 | 10 | %.exe: %.hs 11 | $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< 12 | 13 | %_dyn.exe: %.hs 14 | $(ghc) $(ghcflags) -dynamic --make -o $@ -main-is $(basename $<).main $< 15 | 16 | Struct.exe: ghcflags += -fcontext-stack=27 17 | Struct.exe: Struct.hs structCheck.c 18 | $(ghc) $(ghcflags) --make -o $@ -main-is Struct.main $^ 19 | 20 | Struct_dyn.exe: Struct.hs structCheck.c 21 | $(ghc) $(ghcflags) -dynamic --make -o $@ -main-is $(basename $<).main $^ 22 | 23 | %.run: %.exe 24 | ./$< 25 | 26 | run: $(examples:%=%.run) 27 | 28 | %.s: %.bc 29 | llc -f $< 30 | 31 | # This would lead to a cycle with llvm-as. 32 | # %.ll: %.bc 33 | # llvm-dis -f $< 34 | 35 | %-dis.ll: %.bc 36 | llvm-dis -o $@ -f $< 37 | 38 | %.bc: %.ll 39 | llvm-as -f $< 40 | 41 | %-opt.bc: %.bc 42 | opt -O3 < $< > $@ 43 | 44 | N=40 45 | fastfib: Fibonacci 46 | @rm -f Fib.bc Fib.s 47 | time ./Fibonacci $(N) 48 | opt -std-compile-opts Fibonacci.bc -o Fib.bc 49 | llc Fib.bc 50 | $(CC) mainfib.c Fib.s -o Fib 51 | time ./Fib $(N) 52 | @echo Have a look at Fib.s if you like to see clever code. 53 | 54 | clean: 55 | rm -f $(examples) *.o *.hi *.s *.bc Fib *.exe *.exe.manifest *~ 56 | -------------------------------------------------------------------------------- /examples/ModuleMaker.hs: -------------------------------------------------------------------------------- 1 | module ModuleMaker(main) where 2 | 3 | import LLVM.Core 4 | import Data.Int 5 | 6 | main :: IO () 7 | main = do 8 | m <- newNamedModule "test" 9 | 10 | _ <- defineModule m buildMod 11 | 12 | writeBitcodeToFile "ModuleMaker.bc" m 13 | 14 | return () 15 | 16 | buildMod :: CodeGenModule (Function (IO Int32)) 17 | buildMod = do 18 | _main <- createNamedFunction ExternalLinkage "main" $ do 19 | addResult <- iadd (valueOf (2::Int32)) (3::Int32) 20 | ret addResult 21 | 22 | return _main 23 | 24 | -------------------------------------------------------------------------------- /examples/Struct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, TypeOperators, ScopedTypeVariables #-} 2 | module Struct (main) where 3 | 4 | import Data.Word 5 | import Data.TypeLevel(d0, d1, d2, D10) 6 | 7 | import LLVM.Core 8 | import LLVM.Util.File 9 | import LLVM.ExecutionEngine 10 | 11 | foreign import ccall structCheck :: Word32 -> Ptr S -> Int 12 | 13 | -- Watch out for double! Alignment differs between platforms. 14 | -- struct S { uint32 x0; float x1; uint32 x2[10] }; 15 | type S = Struct (Word32 :& Float :& Array D10 Word32 :& ()) 16 | 17 | -- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s; 18 | mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S))) 19 | mStruct = do 20 | createFunction ExternalLinkage $ \ x -> do 21 | p :: Value (Ptr S) 22 | <- malloc 23 | p0 <- getElementPtr0 p (d0 & ()) 24 | store x (p0 :: Value (Ptr Word32)) 25 | p1 <- getElementPtr0 p (d1 & ()) 26 | store (valueOf 1.5) p1 27 | x' <- add x (1 :: Word32) 28 | p2 <- getElementPtr0 p (d2 & (5::Word32) & ()) 29 | store x' p2 30 | ret p 31 | 32 | main :: IO () 33 | main = do 34 | initializeNativeTarget 35 | writeCodeGenModule "Struct.bc" mStruct 36 | struct <- simpleFunction mStruct 37 | let a = 10 38 | p <- struct a 39 | putStrLn $ if structCheck a p /= 0 then "OK" else "failed" 40 | return () 41 | -------------------------------------------------------------------------------- /examples/Varargs.hs: -------------------------------------------------------------------------------- 1 | module Varargs (main) where 2 | 3 | import Data.Word 4 | 5 | import LLVM.Core 6 | import LLVM.ExecutionEngine 7 | 8 | bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) 9 | bldVarargs = 10 | withStringNul "Hello\n" (\fmt1 -> 11 | withStringNul "A number %d\n" (\fmt2 -> 12 | withStringNul "Two numbers %d %d\n" (\fmt3 -> do 13 | printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) 14 | func <- createFunction ExternalLinkage $ \ x -> do 15 | 16 | tmp1 <- getElementPtr0 fmt1 (0::Word32, ()) 17 | let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32) 18 | _ <- call p1 tmp1 19 | 20 | tmp2 <- getElementPtr0 fmt2 (0::Word32, ()) 21 | let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32) 22 | _ <- call p2 tmp2 x 23 | 24 | tmp3 <- getElementPtr0 fmt3 (0::Word32, ()) 25 | let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32) 26 | _ <- call p3 tmp3 x x 27 | 28 | ret () 29 | return func 30 | ))) 31 | 32 | main :: IO () 33 | main = do 34 | initializeNativeTarget 35 | varargs <- simpleFunction bldVarargs 36 | varargs 42 37 | return () 38 | -------------------------------------------------------------------------------- /examples/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Vector where 3 | 4 | import Convert 5 | 6 | import LLVM.Core 7 | import LLVM.ExecutionEngine 8 | import LLVM.Util.Optimize (optimizeModule, ) 9 | import LLVM.Util.Loop (forLoop, ) 10 | 11 | import Control.Monad (liftM2, ) 12 | import Data.TypeLevel.Num (D16, toNum, ) 13 | import Data.Word (Word32, ) 14 | 15 | -- Type of vector elements. 16 | type T = Float 17 | 18 | -- Number of vector elements. 19 | type N = D16 20 | 21 | cgvec :: CodeGenModule (Function (T -> IO T)) 22 | cgvec = do 23 | -- A global variable that vectest messes with. 24 | acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T)) 25 | 26 | -- Return the global variable. 27 | retAcc <- createNamedFunction ExternalLinkage "retacc" $ do 28 | vacc <- load acc 29 | ret vacc 30 | let _ = retAcc :: Function (IO T) -- Force the type of retAcc. 31 | 32 | -- A function that tests vector opreations. 33 | f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do 34 | 35 | let v = value (zero :: ConstValue (Vector N T)) 36 | n = toNum (undefined :: N) :: Word32 37 | 38 | -- Fill the vector with x, x+1, x+2, ... 39 | (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do 40 | x1' <- add x1 (1::T) 41 | v1' <- insertelement v1 x1 i 42 | return (x1', v1') 43 | 44 | -- Elementwise cubing of the vector. 45 | vsq <- mul v1 v1 46 | vcb <- mul vsq v1 47 | 48 | -- Sum the elements of the vector. 49 | s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do 50 | y <- extractelement vcb i 51 | s' <- add s (y :: Value T) 52 | return s' 53 | 54 | -- Update the global variable. 55 | vacc <- load acc 56 | vacc' <- add vacc s 57 | store vacc' acc 58 | 59 | ret (s :: Value T) 60 | 61 | -- liftIO $ dumpValue f 62 | return f 63 | 64 | main :: IO () 65 | main = do 66 | -- Initialize jitter 67 | initializeNativeTarget 68 | -- First run standard code. 69 | m <- newModule 70 | iovec <- defineModule m cgvec 71 | 72 | fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec 73 | let fvec = convert fptr 74 | 75 | fvec 10 >>= print 76 | 77 | vec <- runEngineAccess $ do addModule m; generateFunction iovec 78 | 79 | vec 10 >>= print 80 | 81 | -- And then optimize and run. 82 | _ <- optimizeModule 1 m 83 | 84 | funcs <- getModuleValues m 85 | print $ map fst funcs 86 | 87 | let iovec' :: Function (T -> IO T) 88 | Just iovec' = castModuleValue =<< lookup "vectest" funcs 89 | ioretacc' :: Function (IO T) 90 | Just ioretacc' = castModuleValue =<< lookup "retacc" funcs 91 | 92 | (vec', retacc') <- runEngineAccess $ do 93 | addModule m 94 | liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') 95 | 96 | dumpValue iovec' 97 | 98 | vec' 10 >>= print 99 | vec' 0 >>= print 100 | retacc' >>= print 101 | -------------------------------------------------------------------------------- /examples/mainfib.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern unsigned int fib(unsigned int); 5 | 6 | int 7 | main(int argc, char **argv) 8 | { 9 | int n = argc > 1 ? atoi(argv[1]) : 10; 10 | printf("fib %d = %d\n", n, fib(n)); 11 | exit(0); 12 | } 13 | -------------------------------------------------------------------------------- /examples/structCheck.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | struct S { uint32_t x0; float x1; uint32_t x2[10]; }; 4 | 5 | int 6 | structCheck(uint32_t a, struct S *s) 7 | { 8 | return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1; 9 | } 10 | -------------------------------------------------------------------------------- /llvm.cabal: -------------------------------------------------------------------------------- 1 | name: llvm 2 | version: 3.2.0.2 3 | license: BSD3 4 | license-file: LICENSE 5 | synopsis: Bindings to the LLVM compiler toolkit. 6 | description: 7 | High-level bindings to the LLVM compiler toolkit. 8 | . 9 | * New in 3.2.0.0: Builds against LLVM 3.2 10 | . 11 | * New in 3.0.0.0: The low-level bindings have been split into the 12 | llvm-base package. 13 | . 14 | * New in 0.9.1.1: Builds against LLVM 2.9. 15 | . 16 | * New in 0.9.1.0: Util.Memory for memory related intrinsics. 17 | . 18 | * New in 0.9.0.0: Adapted to LLVM 2.8 (removed support for Union types). 19 | author: Bryan O'Sullivan, Lennart Augustsson 20 | maintainer: Bryan O'Sullivan , 21 | Lennart Augustsson 22 | homepage: https://github.com/bos/llvm 23 | bug-reports: https://github.com/bos/llvm/issues 24 | stability: experimental 25 | category: Compilers/Interpreters, Code Generation 26 | tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2 27 | cabal-version: >= 1.10 28 | build-type: Simple 29 | 30 | extra-source-files: 31 | *.md 32 | examples/*.c 33 | examples/*.hs 34 | tests/*.hs 35 | tests/Makefile 36 | 37 | flag developer 38 | description: operate in developer mode 39 | default: False 40 | 41 | library 42 | default-language: Haskell98 43 | build-depends: 44 | base >= 3 && < 5, 45 | bytestring >= 0.9, 46 | directory, 47 | llvm-base >= 3.2.0.2 && < 4, 48 | mtl, 49 | process, 50 | type-level, 51 | containers 52 | 53 | ghc-options: -Wall 54 | 55 | if flag(developer) 56 | ghc-options: -Werror 57 | 58 | if os(darwin) 59 | ld-options: -w 60 | frameworks: vecLib 61 | cpp-options: -D__MACOS__ 62 | 63 | exposed-modules: 64 | LLVM.Core 65 | LLVM.ExecutionEngine 66 | LLVM.Util.Arithmetic 67 | LLVM.Util.File 68 | LLVM.Util.Foreign 69 | LLVM.Util.Loop 70 | LLVM.Util.Memory 71 | LLVM.Util.Optimize 72 | 73 | other-modules: 74 | LLVM.Core.CodeGen 75 | LLVM.Core.CodeGenMonad 76 | LLVM.Core.Data 77 | LLVM.Core.Instructions 78 | LLVM.Core.Type 79 | LLVM.Core.Util 80 | LLVM.Core.Vector 81 | LLVM.ExecutionEngine.Engine 82 | LLVM.ExecutionEngine.Target 83 | 84 | source-repository head 85 | type: git 86 | location: git://github.com/bos/llvm.git 87 | 88 | source-repository head 89 | type: mercurial 90 | location: https://bitbucket.org/bos/llvm/ 91 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | ghc := ghc 2 | ghcflags := -Wall -Werror 3 | tests := TestType TestValue 4 | 5 | all: $(tests:%=%.out) 6 | 7 | %.out: %.test 8 | ./$< > $@ 2>&1; s=$$?; cat $@; \ 9 | if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi 10 | 11 | .PRECIOUS: %.test 12 | %.test: %.hs 13 | $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< 14 | 15 | clean: 16 | -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) 17 | -------------------------------------------------------------------------------- /tests/TestValue.hs: -------------------------------------------------------------------------------- 1 | module TestValue (main) where 2 | 3 | import qualified LLVM.Core as Core 4 | import qualified LLVM.Core.Type as T 5 | import qualified LLVM.Core.Value as V 6 | 7 | testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) 8 | => T.Module -> String -> IO (V.Function r p) 9 | testArguments m name = do 10 | func <- Core.addFunction m name (T.function undefined undefined) 11 | V.dumpValue func 12 | let arg = V.params func 13 | V.dumpValue arg 14 | return func 15 | 16 | voidArguments :: T.Module -> IO () 17 | voidArguments m = do 18 | func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) 19 | V.dumpValue func 20 | return () 21 | 22 | type F a = V.Function a a 23 | type P a = V.Function (T.Pointer a) (T.Pointer a) 24 | type V a = V.Function (T.Vector a) (T.Vector a) 25 | 26 | arguments :: T.Module -> IO () 27 | arguments m = do 28 | voidArguments m 29 | 30 | testArguments m "int1" :: IO (F T.Int1) 31 | testArguments m "int8" :: IO (F T.Int8) 32 | testArguments m "int16" :: IO (F T.Int16) 33 | testArguments m "int32" :: IO (F T.Int32) 34 | testArguments m "int64" :: IO (F T.Int64) 35 | testArguments m "float" :: IO (F T.Float) 36 | testArguments m "double" :: IO (F T.Double) 37 | testArguments m "float128" :: IO (F T.Float128) 38 | testArguments m "x86Float80" :: IO (F T.X86Float80) 39 | testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) 40 | 41 | testArguments m "ptrInt1" :: IO (P T.Int1) 42 | testArguments m "ptrInt8" :: IO (P T.Int8) 43 | testArguments m "ptrInt16" :: IO (P T.Int16) 44 | testArguments m "ptrInt32" :: IO (P T.Int32) 45 | testArguments m "ptrInt64" :: IO (P T.Int64) 46 | testArguments m "ptrFloat" :: IO (P T.Float) 47 | testArguments m "ptrDouble" :: IO (P T.Double) 48 | testArguments m "ptrFloat128" :: IO (P T.Float128) 49 | testArguments m "ptrX86Float80" :: IO (P T.X86Float80) 50 | testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) 51 | 52 | testArguments m "vecInt1" :: IO (V T.Int1) 53 | testArguments m "vecInt8" :: IO (V T.Int8) 54 | testArguments m "vecInt16" :: IO (V T.Int16) 55 | testArguments m "vecInt32" :: IO (V T.Int32) 56 | testArguments m "vecInt64" :: IO (V T.Int64) 57 | testArguments m "vecFloat" :: IO (V T.Float) 58 | testArguments m "vecDouble" :: IO (V T.Double) 59 | testArguments m "vecFloat128" :: IO (V T.Float128) 60 | testArguments m "vecX86Float80" :: IO (V T.X86Float80) 61 | testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) 62 | 63 | return () 64 | 65 | main :: IO () 66 | main = do 67 | m <- Core.createModule "m" 68 | arguments m 69 | return () 70 | --------------------------------------------------------------------------------