llvm-3.2.0.0/0000755000000000000000000000000012142507720011012 5ustar0000000000000000llvm-3.2.0.0/PROBLEMS.md0000644000000000000000000000113612142507720012560 0ustar0000000000000000Known problems -------------- If you have solutions to any of the problems listed below, please let me know, or better yet, send a patch. Thanks! Can't use LLVM bindings from ghci --------------------------------- When I try to use the LLVM bindings in `ghci`, on Linux, loading the bindings succeeds, but trying to do anything fails: $ ghci Prelude> :m +LLVM.Core Prelude LLVM.Core> m <- createModule "foo" can't load .so/.DLL for: stdc++ (libstdc++.so: cannot open shared object file: No such file or directory) I don't know why this happens, but it looks like a `ghci` bug. llvm-3.2.0.0/Setup.lhs0000644000000000000000000000011412142507720012616 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain llvm-3.2.0.0/LICENSE0000644000000000000000000000564412142507720012030 0ustar0000000000000000====================================================================== Haskell LLVM Bindings Release License ====================================================================== University of Illinois/NCSA Open Source License Copyright (c) 2007-2009 Bryan O'Sullivan All rights reserved. Developed by: Bryan O'Sullivan http://www.serpentine.com/blog/ Lennart Augustsson Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal with the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimers. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimers in the documentation and/or other materials provided with the distribution. * Neither the names of Bryan O'Sullivan, University of Illinois at Urbana-Champaign, nor the names of its contributors may be used to endorse or promote products derived from this Software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. ====================================================================== Copyrights and Licenses for Third Party Software Distributed with Haskell LLVM Bindings: ====================================================================== The Haskell LLVM Bindings software may contain code written by third parties. Any such software will have its own individual license file in the directory in which it appears. This file will describe the copyrights, license, and restrictions which apply to that code. The disclaimer of warranty in the University of Illinois Open Source License applies to all code in the Haskell LLVM Bindings Distribution, and nothing in any of the other licenses gives permission to use the name of Bryan O'Sullivan or the University of Illinois to endorse or promote products derived from this Software. The following pieces of software have additional or alternate copyrights, licenses, and/or restrictions: Program Directory ------- --------- configure . llvm-3.2.0.0/README.md0000644000000000000000000000355012142507720012274 0ustar0000000000000000Haskell LLVM bindings --------------------- This package provides Haskell bindings for the popular [LLVM](http://llvm.org/) compiler infrastructure project. Compatibility ------------- We try to stay up to date with LLVM releases. The current version of this package is compatible with LLVM 2.9 and 2.8. Please understand that the package may or may not work against older LLVM releases; we don't have the time or resources to test across multiple releases. Configuration ------------- By default, when you run `cabal install`, the Haskell bindings will be configured to look for LLVM in `/usr/local`. If you have LLVM installed in a different location, e.g. `/usr`, you can tell the `configure` script where to find it as follows: cabal install --configure-option=--with-llvm-prefix=/usr Package status - what to expect ------------------------------- This package is still under development. The high level bindings are currently incomplete, so there are some limits on what you can do. Adding new functions is generally easy, though, so don't be afraid to get your hands dirty. The high level interface is mostly safe, but the type system cannot protect against everything that can go wrong, so take care. And, of course, there's no way to guarantee anything about the generated code. Staying in touch ---------------- There is a low-volume mailing list named [haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm). If you use the LLVM bindings, you should think about joining. If you want to contribute patches, please clone a copy of the [git repository](https://github.com/bos/llvm): git clone git://github.com/bos/llvm Patches are best submitted via the github "pull request" interface. To file a bug or a request for an enhancement, please use the [github issue tracker](https://github.com/bos/llvm/issues). llvm-3.2.0.0/llvm.cabal0000644000000000000000000000414512142507720012754 0ustar0000000000000000name: llvm version: 3.2.0.0 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit. description: High-level bindings to the LLVM compiler toolkit. . * New in 3.2.0.0: Builds against LLVM 3.2 . * New in 3.0.0.0: The low-level bindings have been split into the llvm-base package. . * New in 0.9.1.1: Builds against LLVM 2.9. . * New in 0.9.1.0: Util.Memory for memory related intrinsics. . * New in 0.9.0.0: Adapted to LLVM 2.8 (removed support for Union types). author: Bryan O'Sullivan, Lennart Augustsson maintainer: Bryan O'Sullivan , Lennart Augustsson homepage: https://github.com/bos/llvm bug-reports: https://github.com/bos/llvm/issues stability: experimental category: Compilers/Interpreters, Code Generation tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2 cabal-version: >= 1.10 build-type: Simple extra-source-files: *.md examples/*.c examples/*.hs tests/*.hs tests/Makefile flag developer description: operate in developer mode default: False library default-language: Haskell98 build-depends: base >= 3 && < 5, bytestring >= 0.9, directory, llvm-base >= 3.2.0.0 && < 4, mtl, process, type-level, containers ghc-options: -Wall if flag(developer) ghc-options: -Werror if os(darwin) ld-options: -w frameworks: vecLib cpp-options: -D__MACOS__ exposed-modules: LLVM.Core LLVM.ExecutionEngine LLVM.Util.Arithmetic LLVM.Util.File LLVM.Util.Foreign LLVM.Util.Loop LLVM.Util.Memory LLVM.Util.Optimize other-modules: LLVM.Core.CodeGen LLVM.Core.CodeGenMonad LLVM.Core.Data LLVM.Core.Instructions LLVM.Core.Type LLVM.Core.Util LLVM.Core.Vector LLVM.ExecutionEngine.Engine LLVM.ExecutionEngine.Target source-repository head type: git location: git://github.com/bos/llvm.git source-repository head type: mercurial location: https://bitbucket.org/bos/llvm/ llvm-3.2.0.0/tests/0000755000000000000000000000000012142507720012154 5ustar0000000000000000llvm-3.2.0.0/tests/Makefile0000644000000000000000000000054212142507720013615 0ustar0000000000000000ghc := ghc ghcflags := -Wall -Werror tests := TestType TestValue all: $(tests:%=%.out) %.out: %.test ./$< > $@ 2>&1; s=$$?; cat $@; \ if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi .PRECIOUS: %.test %.test: %.hs $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< clean: -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) llvm-3.2.0.0/tests/TestValue.hs0000644000000000000000000000447512142507720014436 0ustar0000000000000000module TestValue (main) where import qualified LLVM.Core as Core import qualified LLVM.Core.Type as T import qualified LLVM.Core.Value as V testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) => T.Module -> String -> IO (V.Function r p) testArguments m name = do func <- Core.addFunction m name (T.function undefined undefined) V.dumpValue func let arg = V.params func V.dumpValue arg return func voidArguments :: T.Module -> IO () voidArguments m = do func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) V.dumpValue func return () type F a = V.Function a a type P a = V.Function (T.Pointer a) (T.Pointer a) type V a = V.Function (T.Vector a) (T.Vector a) arguments :: T.Module -> IO () arguments m = do voidArguments m testArguments m "int1" :: IO (F T.Int1) testArguments m "int8" :: IO (F T.Int8) testArguments m "int16" :: IO (F T.Int16) testArguments m "int32" :: IO (F T.Int32) testArguments m "int64" :: IO (F T.Int64) testArguments m "float" :: IO (F T.Float) testArguments m "double" :: IO (F T.Double) testArguments m "float128" :: IO (F T.Float128) testArguments m "x86Float80" :: IO (F T.X86Float80) testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) testArguments m "ptrInt1" :: IO (P T.Int1) testArguments m "ptrInt8" :: IO (P T.Int8) testArguments m "ptrInt16" :: IO (P T.Int16) testArguments m "ptrInt32" :: IO (P T.Int32) testArguments m "ptrInt64" :: IO (P T.Int64) testArguments m "ptrFloat" :: IO (P T.Float) testArguments m "ptrDouble" :: IO (P T.Double) testArguments m "ptrFloat128" :: IO (P T.Float128) testArguments m "ptrX86Float80" :: IO (P T.X86Float80) testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) testArguments m "vecInt1" :: IO (V T.Int1) testArguments m "vecInt8" :: IO (V T.Int8) testArguments m "vecInt16" :: IO (V T.Int16) testArguments m "vecInt32" :: IO (V T.Int32) testArguments m "vecInt64" :: IO (V T.Int64) testArguments m "vecFloat" :: IO (V T.Float) testArguments m "vecDouble" :: IO (V T.Double) testArguments m "vecFloat128" :: IO (V T.Float128) testArguments m "vecX86Float80" :: IO (V T.X86Float80) testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) return () main :: IO () main = do m <- Core.createModule "m" arguments m return () llvm-3.2.0.0/LLVM/0000755000000000000000000000000012142507720011564 5ustar0000000000000000llvm-3.2.0.0/LLVM/Core.hs0000644000000000000000000001214412142507720013012 0ustar0000000000000000-- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level. -- It supports both stand alone code generation and JITing. -- The Haskell llvm package is a (relatively) high level interface to the LLVM. -- The high level interface makes it easy to construct LLVM code. -- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface. -- -- LLVM code is organized into modules (type 'Module'). -- Each module contains a number of global variables and functions (type 'Function'). -- Each functions has a number of basic blocks (type 'BasicBlock'). -- Each basic block has a number instructions, where each instruction produces -- a value (type 'Value'). -- -- Unlike assembly code for a real processor the assembly code for LLVM is -- in SSA (Static Single Assignment) form. This means that each instruction generates -- a new bound variable which may not be assigned again. -- A consequence of this is that where control flow joins from several execution -- paths there has to be a phi pseudo instruction if you want different variables -- to be joined into one. -- -- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock') -- follow the same pattern. First the entity has to be created using @newX@ (where @X@ -- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to -- given its definition using @defineX@. The reason for splitting the creation and -- definition is that you often need to be able to refer to an entity before giving -- it's body, e.g., in two mutually recursive functions. -- The the @newX@ and @defineX@ function can also be done at the same time by using -- @createX@. Furthermore, an explicit name can be given to an entity by the -- @newNamedX@ function; the @newX@ function just generates a fresh name. module LLVM.Core( -- * Initialize initializeNativeTarget, -- * Modules Module, newModule, newNamedModule, defineModule, destroyModule, createModule, ModuleProvider, createModuleProviderForExistingModule, PassManager, createPassManager, createFunctionPassManager, writeBitcodeToFile, readBitcodeFromFile, getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, -- * Instructions module LLVM.Core.Instructions, -- * Types classification module LLVM.Core.Type, -- * Extra types module LLVM.Core.Data, -- * Values and constants Value, ConstValue, valueOf, constOf, value, zero, allOnes, undef, createString, createStringNul, withString, withStringNul, withModule, Module(..), --constString, constStringNul, constVector, constArray, constStruct, constPackedStruct, toVector, fromVector, vector, -- * Code generation CodeGenFunction, CodeGenModule, -- * Functions Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, TFunction, liftCodeGenModule, getParams, -- * Global variable creation Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, externFunction, staticFunction, externGlobal, staticGlobal, GlobalMappings, getGlobalMappings, TGlobal, -- * Globals Linkage(..), -- * Basic blocks BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, createNamedBasicBlock, getCurrentBasicBlock, getBasicBlocks, fromLabel, toLabel, getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, -- * Misc addAttributes, Attribute(..), castVarArgs, -- * Debugging dumpValue, dumpType, annotateValueList, getValueName, setValueName, setValueName_ ) where import qualified LLVM.FFI.Core as FFI import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) import LLVM.Core.CodeGen import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule, liftCodeGenModule, GlobalMappings, getGlobalMappings) import LLVM.Core.Data import LLVM.Core.Instructions import LLVM.Core.Type import LLVM.Core.Vector import LLVM.Target.Native -- |Print a value. dumpValue :: Value a -> IO () dumpValue (Value v) = FFI.dumpValue v -- |Print a type. dumpType :: Value a -> IO () dumpType (Value v) = showTypeOf v >>= putStrLn -- |Get the name of a 'Value'. getValueName :: Value a -> IO String getValueName (Value a) = getValueNameU a -- |Set the name of a 'Value'. setValueName :: String -> Value a -> IO (Value a) setValueName str v@(Value a) = setValueNameU str a >> return v -- |Set the name of a 'Value'. setValueName_ :: String -> Value a -> IO () setValueName_ str (Value a) = setValueNameU str a -- |Convert a varargs function to a regular function. castVarArgs :: (CastVarArgs a b) => Function a -> Function b castVarArgs (Value a) = Value a -- TODO for types: -- Enforce free is only called on malloc memory. (Enforce only one free?) -- Enforce phi nodes a accessor of variables outside the bb -- Enforce bb terminator -- Enforce phi first -- -- TODO: -- Add Struct, PackedStruct types -- Get alignment from code gen llvm-3.2.0.0/LLVM/ExecutionEngine.hs0000644000000000000000000000764712142507720015227 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. module LLVM.ExecutionEngine( -- * Execution engine EngineAccess, runEngineAccess, addModuleProvider, addModule, {- runStaticConstructors, runStaticDestructors, -} getPointerToFunction, addFunctionValue, addGlobalMappings, getFreePointers, FreePointers, -- * Translation Translatable, Generic, generateFunction, generateFunctionFromRef, -- * Unsafe type conversion Unsafe, unsafePurify, -- * Simplified interface. simpleFunction, unsafeGenerateFunction, -- * Target information module LLVM.ExecutionEngine.Target ) where import System.IO.Unsafe (unsafePerformIO) import LLVM.ExecutionEngine.Engine import LLVM.FFI.Core(ValueRef) import LLVM.Core.CodeGen(Value(..)) import LLVM.Core import LLVM.ExecutionEngine.Target --import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) import Control.Monad (liftM2, ) -- |Class of LLVM function types that can be translated to the corresponding -- Haskell type. class Translatable f where translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f instance (Generic a, Translatable b) => Translatable (a -> b) where translate run args f = \ arg -> translate run (toGeneric arg : args) f instance (Generic a) => Translatable (IO a) where translate run args f = fmap fromGeneric $ run f $ reverse args -- |Generate a Haskell function from an LLVM function. -- -- Note that the function is compiled for every call (Just-In-Time compilation). -- If you want to compile the function once and call it a lot of times -- then you should better use 'getPointerToFunction'. generateFunction :: (Translatable f) => Value (Ptr f) -> EngineAccess f generateFunction (Value f) = generateFunctionFromRef f generateFunctionFromRef :: (Translatable f) => ValueRef -> EngineAccess f generateFunctionFromRef f = do run <- getRunFunction return $ translate run [] f class Unsafe a b | a -> b where unsafePurify :: a -> b -- ^Remove the IO from a function return type. This is unsafe in general. instance (Unsafe b b') => Unsafe (a->b) (a->b') where unsafePurify f = unsafePurify . f instance Unsafe (IO a) a where unsafePurify = unsafePerformIO -- |Translate a function to Haskell code. This is a simplified interface to -- the execution engine and module mechanism. -- It is based on 'generateFunction', so see there for limitations. simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f simpleFunction bld = do m <- newModule (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) prov <- createModuleProviderForExistingModule m runEngineAccess $ do addModuleProvider prov addGlobalMappings mappings generateFunction func {- m <- newModule func <- defineModule m bld -- dumpValue func prov <- createModuleProviderForExistingModule m ee <- createExecutionEngine prov pm <- createFunctionPassManager prov td <- getExecutionEngineTargetData ee addTargetData td pm addInstructionCombiningPass pm addReassociatePass pm addGVNPass pm addCFGSimplificationPass pm addPromoteMemoryToRegisterPass pm initializeFunctionPassManager pm -- print ("rc1", rc1) runFunctionPassManager pm (unValue func) -- print ("rc2", rc2) finalizeFunctionPassManager pm -- print ("rc3", rc3) -- dumpValue func return $ generateFunction ee func -} -- | Combine 'simpleFunction' and 'unsafePurify'. unsafeGenerateFunction :: (Unsafe t a, Translatable t) => CodeGenModule (Function t) -> a unsafeGenerateFunction bld = unsafePerformIO $ do fun <- simpleFunction bld return $ unsafePurify fun llvm-3.2.0.0/LLVM/ExecutionEngine/0000755000000000000000000000000012142507720014655 5ustar0000000000000000llvm-3.2.0.0/LLVM/ExecutionEngine/Target.hs0000644000000000000000000000476012142507720016446 0ustar0000000000000000{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where import Data.Typeable import Data.TypeLevel(Nat, reifyIntegral) import Foreign.C.String import System.IO.Unsafe(unsafePerformIO) import LLVM.Core.Data(WordN) import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData) import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Target as FFI type Type = FFI.TypeRef data TargetData = TargetData { aBIAlignmentOfType :: Type -> Int, aBISizeOfType :: Type -> Int, littleEndian :: Bool, callFrameAlignmentOfType :: Type -> Int, -- elementAtOffset :: Type -> Word64 -> Int, intPtrType :: Type, -- offsetOfElements :: Int -> Word64, pointerSize :: Int, -- preferredAlignmentOfGlobal :: Value a -> Int, preferredAlignmentOfType :: Type -> Int, sizeOfTypeInBits :: Type -> Int, storeSizeOfType :: Type -> Int } deriving (Typeable) withIntPtrType :: (forall n . (Nat n) => WordN n -> a) -> a withIntPtrType f = reifyIntegral sz (\ n -> f (g n)) where g :: n -> WordN n g _ = error "withIntPtrType: argument used" sz = pointerSize $ unsafePerformIO getTargetData -- Gets the target data for the JIT target. getEngineTargetDataRef :: IO FFI.TargetDataRef getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData -- Normally the TargetDataRef never changes, so the operation -- are really pure functions. makeTargetData :: FFI.TargetDataRef -> TargetData makeTargetData r = TargetData { aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r, aBISizeOfType = fromIntegral . FFI.aBISizeOfType r, littleEndian = FFI.byteOrder r /= 0, callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r, intPtrType = FFI.intPtrType r, pointerSize = fromIntegral $ FFI.pointerSize r, preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r, sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r, storeSizeOfType = fromIntegral . FFI.storeSizeOfType r } getTargetData :: IO TargetData getTargetData = fmap makeTargetData getEngineTargetDataRef targetDataFromString :: String -> TargetData targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData llvm-3.2.0.0/LLVM/ExecutionEngine/Engine.hs0000644000000000000000000002716712142507720016433 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module LLVM.ExecutionEngine.Engine( EngineAccess, runEngineAccess, {- ExecutionEngine, -} createExecutionEngine, addModuleProvider, addModule, {- runStaticConstructors, runStaticDestructors, -} getExecutionEngineTargetData, getPointerToFunction, addFunctionValue, addGlobalMappings, getFreePointers, FreePointers, runFunction, getRunFunction, GenericValue, Generic(..) ) where import Control.Monad.State import Control.Applicative (Applicative, ) import Control.Concurrent.MVar import Data.Typeable import Data.Int import Data.Word import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (withArrayLen) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import Foreign.Marshal.Utils (fromBool) import Foreign.C.String (peekCString) import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr) import LLVM.Core.CodeGen(Value(..), Function) import LLVM.Core.CodeGenMonad(GlobalMappings(..)) import Foreign.Storable (peek) import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) import System.IO.Unsafe (unsafePerformIO) import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule) import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) import qualified LLVM.Core.Util as U import LLVM.Core.Type(IsFirstClass, typeRef) {- -- |The type of the JITer. newtype ExecutionEngine = ExecutionEngine { fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine } withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) -> IO a withExecutionEngine = withForeignPtr . fromExecutionEngine -- |Create an execution engine for a module provider. -- Warning, do not call this function more than once. createExecutionEngine :: ModuleProvider -> IO ExecutionEngine createExecutionEngine prov = withModuleProvider prov $ \provPtr -> alloca $ \eePtr -> alloca $ \errPtr -> do ret <- FFI.createExecutionEngine eePtr provPtr errPtr if ret == 1 then do err <- peek errPtr errStr <- peekCString err free err ioError . userError $ errStr else do ptr <- peek eePtr liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () addModuleProvider ee prov = withExecutionEngine ee $ \ eePtr -> withModuleProvider prov $ \ provPtr -> FFI.addModuleProvider eePtr provPtr runStaticConstructors :: ExecutionEngine -> IO () runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors runStaticDestructors :: ExecutionEngine -> IO () runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f) getPointerToFunction ee (Value f) = withExecutionEngine ee $ \ eePtr -> FFI.getPointerToGlobal eePtr f -} -- This global variable holds the one and only execution engine. -- It may be missing, but it never dies. -- XXX We could provide a destructor, what about functions obtained by runFunction? {-# NOINLINE theEngine #-} theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine)) theEngine = unsafePerformIO $ newMVar Nothing createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine) createExecutionEngine prov = withModuleProvider prov $ \provPtr -> alloca $ \eePtr -> alloca $ \errPtr -> do ret <- FFI.createExecutionEngine eePtr provPtr errPtr if ret == 1 then do err <- peek errPtr errStr <- peekCString err free err ioError . userError $ errStr else peek eePtr getTheEngine :: IO (Ptr FFI.ExecutionEngine) getTheEngine = do mee <- takeMVar theEngine case mee of Just ee -> do putMVar theEngine mee; return ee Nothing -> do m <- createModule "__empty__" mp <- createModuleProviderForExistingModule m ee <- createExecutionEngine mp putMVar theEngine (Just ee) return ee data EAState = EAState { ea_engine :: Ptr FFI.ExecutionEngine, ea_providers :: [ModuleProvider] } deriving (Show, Typeable) newtype EngineAccess a = EA (StateT EAState IO a) deriving (Functor, Applicative, Monad, MonadState EAState, MonadIO) -- |The LLVM execution engine is encapsulated so it cannot be accessed directly. -- The reason is that (currently) there must only ever be one engine, -- so access to it is wrapped in a monad. runEngineAccess :: EngineAccess a -> IO a runEngineAccess (EA body) = do eePtr <- getTheEngine let ea = EAState { ea_engine = eePtr, ea_providers = [] } (a, _ea') <- runStateT body ea -- XXX should remove module providers again return a addModuleProvider :: ModuleProvider -> EngineAccess () addModuleProvider prov = do ea <- get put ea{ ea_providers = prov : ea_providers ea } liftIO $ withModuleProvider prov $ \ provPtr -> FFI.addModuleProvider (ea_engine ea) provPtr getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef getExecutionEngineTargetData = do eePtr <- gets ea_engine liftIO $ FFI.getExecutionEngineTargetData eePtr {- | In contrast to 'generateFunction' this compiles a function once. Thus it is faster for many calls to the same function. See @examples\/Vector.hs@. If the function calls back into Haskell code, you also have to set the function addresses using 'addFunctionValue' or 'addGlobalMappings'. -} getPointerToFunction :: Function f -> EngineAccess (FunPtr f) getPointerToFunction (Value f) = do eePtr <- gets ea_engine liftIO $ FFI.getPointerToGlobal eePtr f {- | Tell LLVM the address of an external function if it cannot resolve a name automatically. Alternatively you may declare the function with 'staticFunction' instead of 'externFunction'. -} addFunctionValue :: Function f -> FunPtr f -> EngineAccess () addFunctionValue (Value g) f = addFunctionValueCore g (castFunPtrToPtr f) {- | Pass a list of global mappings to LLVM that can be obtained from 'LLVM.Core.getGlobalMappings'. -} addGlobalMappings :: GlobalMappings -> EngineAccess () addGlobalMappings (GlobalMappings gms) = mapM_ (uncurry addFunctionValueCore) gms addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () addFunctionValueCore g f = do eePtr <- gets ea_engine liftIO $ FFI.addGlobalMapping eePtr g f addModule :: Module -> EngineAccess () addModule m = do mp <- liftIO $ createModuleProviderForExistingModule m addModuleProvider mp -- | Get all the information needed to free a function. -- Freeing code might have to be done from a (C) finalizer, so it has to done from C. -- The function c_freeFunctionObject take these pointers as arguments and frees the function. type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef) getFreePointers :: Function f -> EngineAccess FreePointers getFreePointers (Value f) = do ea <- get liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp -> return (ea_engine ea, mpp, f) -------------------------------------- newtype GenericValue = GenericValue { fromGenericValue :: ForeignPtr FFI.GenericValue } withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a withGenericValue = withForeignPtr . fromGenericValue createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue createGenericValueWith f = do ptr <- f liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a withAll ps a = go [] ps where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs go ptrs _ = withArrayLen (reverse ptrs) a runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue runFunction func args = do eePtr <- gets ea_engine liftIO $ withAll args $ \argLen argPtr -> createGenericValueWith $ FFI.runFunction eePtr func (fromIntegral argLen) argPtr getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) getRunFunction = do eePtr <- gets ea_engine return $ \ func args -> withAll args $ \argLen argPtr -> createGenericValueWith $ FFI.runFunction eePtr func (fromIntegral argLen) argPtr class Generic a where toGeneric :: a -> GenericValue fromGeneric :: GenericValue -> a instance Generic () where toGeneric _ = error "toGeneric ()" fromGeneric _ = () toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed) fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a fromGenericInt signed val = unsafePerformIO $ withGenericValue val $ \ref -> return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) --instance Generic Bool where -- toGeneric = toGenericInt False . fromBool -- fromGeneric = toBool . fromGenericInt False instance Generic Int8 where toGeneric = toGenericInt True fromGeneric = fromGenericInt True instance Generic Int16 where toGeneric = toGenericInt True fromGeneric = fromGenericInt True instance Generic Int32 where toGeneric = toGenericInt True fromGeneric = fromGenericInt True {- instance Generic Int where toGeneric = toGenericInt True fromGeneric = fromGenericInt True -} instance Generic Int64 where toGeneric = toGenericInt True fromGeneric = fromGenericInt True instance Generic Word8 where toGeneric = toGenericInt False fromGeneric = fromGenericInt False instance Generic Word16 where toGeneric = toGenericInt False fromGeneric = fromGenericInt False instance Generic Word32 where toGeneric = toGenericInt False fromGeneric = fromGenericInt False instance Generic Word64 where toGeneric = toGenericInt False fromGeneric = fromGenericInt False toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue toGenericReal val = unsafePerformIO $ createGenericValueWith $ FFI.createGenericValueOfFloat (typeRef val) (realToFrac val) fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a fromGenericReal val = unsafePerformIO $ withGenericValue val $ \ ref -> return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref instance Generic Float where toGeneric = toGenericReal fromGeneric = fromGenericReal instance Generic Double where toGeneric = toGenericReal fromGeneric = fromGenericReal instance Generic (Ptr a) where toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer instance Generic (StablePtr a) where toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer llvm-3.2.0.0/LLVM/Util/0000755000000000000000000000000012142507720012501 5ustar0000000000000000llvm-3.2.0.0/LLVM/Util/Optimize.hs0000644000000000000000000001145712142507720014645 0ustar0000000000000000{- LLVM does not export its functions @createStandardFunctionPasses@ and @createStandardModulePasses@ via its C interface and interfacing to C-C++ wrappers is not very portable. Thus we reimplement these functions from @opt.cpp@ and @StandardPasses.h@ in Haskell. However this way we risk inconsistencies between 'optimizeModule' and the @opt@ shell command. -} module LLVM.Util.Optimize(optimizeModule) where import LLVM.Core.Util(Module, withModule) import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Support as FFI import LLVM.FFI.Transforms.Scalar import Control.Exception (bracket) {- | Result tells whether the module was modified by any of the passes. -} optimizeModule :: Int -> Module -> IO Bool optimizeModule optLevel mdl = withModule mdl $ \ m -> {- Core.Util.createPassManager would provide a finalizer for us, but I think it is better here to immediately dispose the manager when we need it no longer. -} bracket FFI.createPassManager FFI.disposePassManager $ \ passes -> {- Note on LLVM-2.6 to 2.8 (at least): As far as I understand, if we do not set target data, then the optimizer will only perform machine independent optimizations. If we set target data (e.g. an empty layout string obtained from a module without 'target data' specification.) we risk that the optimizer switches to a wrong layout (e.g. to 64 bit pointers on a 32 bit machine for empty layout string) and thus generates corrupt code. Currently it seems to be safer to disable machine dependent optimization completely. http://llvm.org/bugs/show_bug.cgi?id=6394 -- Pass the module target data to the pass manager. target <- FFI.getDataLayout m >>= createTargetData addTargetData target passes -} {- opt.cpp does not use a FunctionPassManager for function optimization, but a module PassManager. Thus we do it the same way. I assume that we would need a FunctionPassManager only if we wanted to apply individual optimizations to functions. fPasses <- FFI.createFunctionPassManager mp -} bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do -- add module target data? -- tools/opt/opt.cpp: AddStandardCompilePasses addVerifierPass passes addOptimizationPasses passes fPasses optLevel {- if we wanted to do so, we could loop through all functions and optimize them. initializeFunctionPassManager fPasses runFunctionPassManager fPasses fcn -} functionsModified <- FFI.runPassManager fPasses m moduleModified <- FFI.runPassManager passes m return $ moduleModified || functionsModified -- tools/opt/opt.cpp: AddOptimizationPasses addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () addOptimizationPasses passes fPasses optLevel = do createStandardFunctionPasses fPasses optLevel createStandardModulePasses passes optLevel True True (optLevel > 1) True True True createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () createStandardFunctionPasses fPasses optLevel = FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) -- llvm/Support/StandardPasses.h: createStandardModulePasses createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) (f (not inliningPass)) where f True = 1 f _ = 0 {- ToDo: Function that adds passes according to a list of opt-options. This would simplify to get consistent behaviour between opt and optimizeModule. -adce addAggressiveDCEPass -deadargelim addDeadArgEliminationPass -deadtypeelim addDeadTypeEliminationPass -dse addDeadStoreEliminationPass -functionattrs addFunctionAttrsPass -globalopt addGlobalOptimizerPass -indvars addIndVarSimplifyPass -instcombine addInstructionCombiningPass -ipsccp addIPSCCPPass -jump-threading addJumpThreadingPass -licm addLICMPass -loop-deletion addLoopDeletionPass -loop-rotate addLoopRotatePass -memcpyopt addMemCpyOptPass -prune-eh addPruneEHPass -reassociate addReassociatePass -scalarrepl addScalarReplAggregatesPass -sccp addSCCPPass -simplifycfg addCFGSimplificationPass -simplify-libcalls addSimplifyLibCallsPass -strip-dead-prototypes addStripDeadPrototypesPass -tailcallelim addTailCallEliminationPass -verify addVerifierPass -} llvm-3.2.0.0/LLVM/Util/File.hs0000644000000000000000000000246412142507720013722 0ustar0000000000000000module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where import System.Cmd(system) import LLVM.Core import LLVM.ExecutionEngine writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () writeCodeGenModule name f = do m <- newModule _ <- defineModule m f writeBitcodeToFile name m optimize :: FilePath -> IO () optimize name = do _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name return () optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t) optimizeFunction = fmap snd . optimizeFunction' optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t) optimizeFunction' mdl = do m <- newModule mf <- defineModule m mdl fName <- getValueName mf let name = "__tmp__" ++ fName ++ ".bc" writeBitcodeToFile name m optimize name m' <- readBitcodeFromFile name funcs <- getModuleValues m' -- removeFile name let Just mf' = castModuleValue =<< lookup fName funcs return (m', mf') optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t optimizeFunctionCG mdl = do (m', mf') <- optimizeFunction' mdl rf <- runEngineAccess $ do addModule m' generateFunction mf' return rf llvm-3.2.0.0/LLVM/Util/Memory.hs0000644000000000000000000000376412142507720014317 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module LLVM.Util.Memory ( memcpy, memmove, memset, IsLengthType, ) where import LLVM.Core import Data.Word (Word8, Word32, Word64, ) class IsFirstClass len => IsLengthType len where instance IsLengthType Word32 where instance IsLengthType Word64 where memcpyFunc :: forall len. IsLengthType len => TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) memcpyFunc = newNamedFunction ExternalLinkage $ "llvm.memcpy.p0i8.p0i8." ++ typeName (undefined :: len) memcpy :: IsLengthType len => CodeGenModule (Value (Ptr Word8) -> Value (Ptr Word8) -> Value len -> Value Word32 -> Value Bool -> CodeGenFunction r ()) memcpy = fmap (\f dest src len align volatile -> fmap (const()) $ call f dest src len align volatile) memcpyFunc memmoveFunc :: forall len. IsLengthType len => TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) memmoveFunc = newNamedFunction ExternalLinkage $ "llvm.memmove.p0i8.p0i8." ++ typeName (undefined :: len) memmove :: IsLengthType len => CodeGenModule (Value (Ptr Word8) -> Value (Ptr Word8) -> Value len -> Value Word32 -> Value Bool -> CodeGenFunction r ()) memmove = fmap (\f dest src len align volatile -> fmap (const()) $ call f dest src len align volatile) memmoveFunc memsetFunc :: forall len. IsLengthType len => TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ()) memsetFunc = newNamedFunction ExternalLinkage $ "llvm.memset.p0i8." ++ typeName (undefined :: len) memset :: IsLengthType len => CodeGenModule (Value (Ptr Word8) -> Value Word8 -> Value len -> Value Word32 -> Value Bool -> CodeGenFunction r ()) memset = fmap (\f dest val len align volatile -> fmap (const()) $ call f dest val len align volatile) memsetFunc llvm-3.2.0.0/LLVM/Util/Loop.hs0000644000000000000000000000627412142507720013757 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeOperators, FlexibleContexts #-} module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where import Data.TypeLevel hiding (Bool) import LLVM.Core class Phi a where phis :: BasicBlock -> a -> CodeGenFunction r a addPhis :: BasicBlock -> a -> a -> CodeGenFunction r () {- infixr 1 :* -- XXX should use HList if it was packaged in a nice way. data a :* b = a :* b deriving (Eq, Ord, Show, Read) instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where phis bb (a :* b) = do a' <- phi [(a, bb)] b' <- phis bb b return (a' :* b') addPhis bb (a :* b) (a' :* b') = do addPhiInputs a [(a', bb)] addPhis bb b b' -} instance Phi () where phis _ _ = return () addPhis _ _ _ = return () instance (IsFirstClass a) => Phi (Value a) where phis bb a = do a' <- phi [(a, bb)] return a' addPhis bb a a' = do addPhiInputs a [(a', bb)] instance (Phi a, Phi b) => Phi (a, b) where phis bb (a, b) = do a' <- phis bb a b' <- phis bb b return (a', b') addPhis bb (a, b) (a', b') = do addPhis bb a a' addPhis bb b b' instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where phis bb (a, b, c) = do a' <- phis bb a b' <- phis bb b c' <- phis bb c return (a', b', c') addPhis bb (a, b, c) (a', b', c') = do addPhis bb a a' addPhis bb b b' addPhis bb c c' -- Loop the index variable from low to high. The state in the loop starts as start, and is modified -- by incr in each iteration. forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) => Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a forLoop low high start incr = do top <- getCurrentBasicBlock loop <- newBasicBlock body <- newBasicBlock exit <- newBasicBlock br loop defineBasicBlock loop i <- phi [(low, top)] vars <- phis top start t <- cmp CmpNE i high condBr t body exit defineBasicBlock body vars' <- incr i vars i' <- add i (valueOf 1 :: Value i) body' <- getCurrentBasicBlock addPhis body' vars vars' addPhiInputs i [(i', body')] br loop defineBasicBlock exit return vars -------------------------------------- mapVector :: forall a b n r . (Pos n, IsPrimitive b) => (Value a -> CodeGenFunction r (Value b)) -> Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) mapVector f v = forLoop (valueOf 0) (valueOf (toNum (undefined :: n))) (value undef) $ \ i w -> do x <- extractelement v i y <- f x insertelement w y i mapVector2 :: forall a b c n r . (Pos n, IsPrimitive c) => (Value a -> Value b -> CodeGenFunction r (Value c)) -> Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) mapVector2 f v1 v2 = forLoop (valueOf 0) (valueOf (toNum (undefined :: n))) (value undef) $ \ i w -> do x <- extractelement v1 i y <- extractelement v2 i z <- f x y insertelement w z i llvm-3.2.0.0/LLVM/Util/Foreign.hs0000644000000000000000000000162412142507720014431 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- These are replacements for the broken equivalents in Foreign.*. -- The functions in Foreign.* do not obey the required alignment. module LLVM.Util.Foreign where import Foreign.Ptr(alignPtr, Ptr) import Foreign.Storable(Storable(poke, sizeOf, alignment)) import Foreign.Marshal.Alloc(allocaBytes) import Foreign.Marshal.Array(allocaArray, pokeArray) with :: Storable a => a -> (Ptr a -> IO b) -> IO b with x act = alloca $ \ p -> do poke p x act p alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b alloca act = allocaBytes (2 * sizeOf (undefined :: a)) $ \ p -> act $ alignPtr p (alignment (undefined :: a)) withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b withArrayLen xs act = let l = length xs in allocaArray (l+1) $ \ p -> do let p' = alignPtr p (alignment (head xs)) pokeArray p' xs act l p' llvm-3.2.0.0/LLVM/Util/Arithmetic.hs0000644000000000000000000003106512142507720015133 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} {-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies #-} module LLVM.Util.Arithmetic( TValue, Cmp(..), (%==), (%/=), (%<), (%<=), (%>), (%>=), (%&&), (%||), (?), (??), retrn, set, ArithFunction, arithFunction, UnwrapArgs, toArithFunction, recursiveFunction, CallIntrinsic, ) where import Data.Word import Data.Int import qualified Data.TypeLevel.Num as TypeNum import qualified LLVM.Core as LLVM import LLVM.Core hiding (cmp, ) import LLVM.Util.Loop(mapVector, mapVector2) -- |Synonym for @CodeGenFunction r (Value a)@. type TValue r a = CodeGenFunction r (Value a) {-# DEPRECATED cmp "use LLVM.Core.cmp instead" #-} class (CmpRet a b) => Cmp a b | a -> b where cmp :: IntPredicate -> Value a -> Value a -> TValue r b instance Cmp Bool Bool where cmp = icmp instance Cmp Word8 Bool where cmp = icmp instance Cmp Word16 Bool where cmp = icmp instance Cmp Word32 Bool where cmp = icmp instance Cmp Word64 Bool where cmp = icmp instance Cmp Int8 Bool where cmp = icmp . adjSigned instance Cmp Int16 Bool where cmp = icmp . adjSigned instance Cmp Int32 Bool where cmp = icmp . adjSigned instance Cmp Int64 Bool where cmp = icmp . adjSigned instance Cmp Float Bool where cmp = fcmp . adjFloat instance Cmp Double Bool where cmp = fcmp . adjFloat instance Cmp FP128 Bool where cmp = fcmp . adjFloat {- instance (Pos n) => Cmp (Vector n Bool) (Vector n Bool) where cmp = icmp instance (Pos n) => Cmp (Vector n Word8) (Vector n Bool) where cmp = icmp instance (Pos n) => Cmp (Vector n Word16) (Vector n Bool) where cmp = icmp instance (Pos n) => Cmp (Vector n Word32) (Vector n Bool) where cmp = icmp instance (Pos n) => Cmp (Vector n Word64) (Vector n Bool) where cmp = icmp instance (Pos n) => Cmp (Vector n Int8) (Vector n Bool) where cmp = icmp . adjSigned instance (Pos n) => Cmp (Vector n Int16) (Vector n Bool) where cmp = icmp . adjSigned instance (Pos n) => Cmp (Vector n Int32) (Vector n Bool) where cmp = icmp . adjSigned instance (Pos n) => Cmp (Vector n Int64) (Vector n Bool) where cmp = icmp . adjSigned instance (Pos n) => Cmp (Vector n Float) (Vector n Bool) where cmp = fcmp . adjFloat instance (Pos n) => Cmp (Vector n Double) (Vector n Bool) where cmp = fcmp . adjFloat instance (Pos n) => Cmp (Vector n FP128) (Vector n Bool) where cmp = fcmp . adjFloat -} instance (Pos n) => Cmp (Vector n Float) (Vector n Bool) where cmp op = mapVector2 (fcmp (adjFloat op)) instance (Pos n) => Cmp (Vector n Word32) (Vector n Bool) where cmp op = mapVector2 (cmp op) adjSigned :: IntPredicate -> IntPredicate adjSigned IntUGT = IntSGT adjSigned IntUGE = IntSGE adjSigned IntULT = IntSLT adjSigned IntULE = IntSLE adjSigned p = p adjFloat :: IntPredicate -> FPPredicate adjFloat IntEQ = FPOEQ adjFloat IntNE = FPONE adjFloat IntUGT = FPOGT adjFloat IntUGE = FPOGE adjFloat IntULT = FPOLT adjFloat IntULE = FPOLE adjFloat _ = error "adjFloat" infix 4 %==, %/=, %<, %<=, %>=, %> -- |Comparison functions. (%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a b) => TValue r a -> TValue r a -> TValue r b (%==) = binop $ LLVM.cmp CmpEQ (%/=) = binop $ LLVM.cmp CmpNE (%>) = binop $ LLVM.cmp CmpGT (%>=) = binop $ LLVM.cmp CmpGE (%<) = binop $ LLVM.cmp CmpLT (%<=) = binop $ LLVM.cmp CmpLE infixr 3 %&& infixr 2 %|| -- |Lazy and. (%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool a %&& b = a ? (b, return (valueOf False)) -- |Lazy or. (%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool a %|| b = a ? (return (valueOf True), b) infix 0 ? -- |Conditional, returns first element of the pair when condition is true, otherwise second. (?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a c ? (t, f) = do lt <- newBasicBlock lf <- newBasicBlock lj <- newBasicBlock c' <- c condBr c' lt lf defineBasicBlock lt rt <- t lt' <- getCurrentBasicBlock br lj defineBasicBlock lf rf <- f lf' <- getCurrentBasicBlock br lj defineBasicBlock lj phi [(rt, lt'), (rf, lf')] infix 0 ?? (??) :: (IsFirstClass a, CmpRet a b) => TValue r b -> (TValue r a, TValue r a) -> TValue r a c ?? (t, f) = do c' <- c t' <- t f' <- f select c' t' f' -- | Return a value from an 'arithFunction'. retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () retrn x = x >>= ret -- | Use @x <- set $ ...@ to make a binding. set :: TValue r a -> (CodeGenFunction r (TValue r a)) set x = do x' <- x; return (return x') instance (Show (TValue r a)) instance (Eq (TValue r a)) instance (Ord (TValue r a)) instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Num (TValue r a) where (+) = binop add (-) = binop sub (*) = binop mul negate = (>>= neg) abs x = x %< 0 ?? (-x, x) signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) fromInteger = return . valueOf . fromInteger instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Enum (TValue r a) where succ x = x + 1 pred x = x - 1 fromEnum _ = error "CodeGenFunction Value: fromEnum" toEnum = fromIntegral instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (TValue r a) where toRational _ = error "CodeGenFunction Value: toRational" instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where quot = binop idiv rem = binop irem quotRem x y = (quot x y, rem x y) toInteger _ = error "CodeGenFunction Value: toInteger" instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where (/) = binop fdiv fromRational = return . valueOf . fromRational instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where properFraction _ = error "CodeGenFunction Value: properFraction" instance (Cmp a b, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where pi = return $ valueOf pi sqrt = callIntrinsic1 "sqrt" sin = callIntrinsic1 "sin" cos = callIntrinsic1 "cos" (**) = callIntrinsic2 "pow" exp = callIntrinsic1 "exp" log = callIntrinsic1 "log" asin _ = error "LLVM missing intrinsic: asin" acos _ = error "LLVM missing intrinsic: acos" atan _ = error "LLVM missing intrinsic: atan" sinh x = (exp x - exp (-x)) / 2 cosh x = (exp x + exp (-x)) / 2 asinh x = log (x + sqrt (x*x + 1)) acosh x = log (x + sqrt (x*x - 1)) atanh x = (log (1 + x) - log (1 - x)) / 2 instance (Cmp a b, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where floatRadix _ = floatRadix (undefined :: a) floatDigits _ = floatDigits (undefined :: a) floatRange _ = floatRange (undefined :: a) decodeFloat _ = error "CodeGenFunction Value: decodeFloat" encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat" exponent _ = 0 scaleFloat 0 x = x scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat" isNaN _ = error "CodeGenFunction Value: isNaN" isInfinite _ = error "CodeGenFunction Value: isInfinite" isDenormalized _ = error "CodeGenFunction Value: isDenormalized" isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero" isIEEE _ = isIEEE (undefined :: a) binop :: (Value a -> Value b -> TValue r c) -> TValue r a -> TValue r b -> TValue r c binop op x y = do x' <- x y' <- y op x' y' {- If we add the ReadNone attribute, then LLVM-2.8 complains: llvm/examples$ Arith_dyn.exe Attribute readnone only applies to the function! %2 = call readnone double @llvm.sin.f64(double %0) Attribute readnone only applies to the function! %3 = call readnone double @llvm.exp.f64(double %2) Broken module found, compilation aborted! Stack dump: 0. Running pass 'Function Pass Manager' on module '_module'. 1. Running pass 'Module Verifier' on function '@_fun1' Aborted -} addReadNone :: Value a -> CodeGenFunction r (Value a) addReadNone x = do -- addAttributes x 0 [ReadNoneAttribute] return x callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) => String -> Value a -> TValue r b callIntrinsicP1 fn x = do op :: Function (a -> IO b) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a)) {- You can add these attributes, but the verifier pass in the optimizer checks whether they match the attributes that are declared for that intrinsic. If we omit adding attributes then the right attributes are added automatically. addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute] -} call op x >>= addReadNone callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) => String -> Value a -> Value b -> TValue r c callIntrinsicP2 fn x y = do op :: Function (a -> b -> IO c) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a)) call op x y >>= addReadNone ------------------------------------------- class ArithFunction a b | a -> b, b -> a where arithFunction' :: a -> b instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where arithFunction' x = x >>= ret instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where arithFunction' f = arithFunction' . f . return -- |Unlift a function with @TValue@ to have @Value@ arguments. arithFunction :: ArithFunction a b => a -> b arithFunction = arithFunction' ------------------------------------------- class UncurryN a b | a -> b, b -> a where uncurryN :: a -> b curryN :: b -> a instance UncurryN (CodeGenFunction r a) (() -> CodeGenFunction r a) where uncurryN i = \ () -> i curryN f = f () instance (UncurryN t (b -> c)) => UncurryN (a -> t) ((a, b) -> c) where uncurryN f = \ (a, b) -> uncurryN (f a) b curryN f = \ a -> curryN (\ b -> f (a, b)) class LiftTuple r a b | a -> b, b -> a where liftTuple :: a -> CodeGenFunction r b instance LiftTuple r () () where liftTuple = return instance (LiftTuple r b b') => LiftTuple r (CodeGenFunction r a, b) (a, b') where liftTuple (a, b) = do a' <- a; b' <- liftTuple b; return (a', b') class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where unwrapArgs :: a2 -> a instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => UnwrapArgs a a1 b1 b a2 r where unwrapArgs f = curryN $ \ x -> do x' <- liftTuple x; uncurryN f x' -- |Lift a function from having @Value@ arguments to having @TValue@ arguments. toArithFunction :: (CallArgs f g r, UnwrapArgs a a1 b1 b g r) => Function f -> a toArithFunction f = unwrapArgs (call f) ------------------------------------------- -- |Define a recursive 'arithFunction', gets passed itself as the first argument. recursiveFunction :: (CallArgs a g r0, UnwrapArgs a11 a1 b1 b g r0, FunctionArgs a a2 r1, ArithFunction a3 a2, IsFunction a) => (a11 -> a3) -> CodeGenModule (Function a) recursiveFunction af = do f <- newFunction ExternalLinkage let f' = toArithFunction f defineFunction f $ arithFunction (af f') return f ------------------------------------------- class CallIntrinsic a where callIntrinsic1' :: String -> Value a -> TValue r a callIntrinsic2' :: String -> Value a -> Value a -> TValue r a instance CallIntrinsic Float where callIntrinsic1' = callIntrinsicP1 callIntrinsic2' = callIntrinsicP2 instance CallIntrinsic Double where callIntrinsic1' = callIntrinsicP1 callIntrinsic2' = callIntrinsicP2 {- I think such a special case for certain systems would be better handled as in LLVM.Extra.Extension. (lemming) -} macOS :: Bool #if defined(__MACOS__) macOS = True #else macOS = False #endif instance (Pos n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where callIntrinsic1' s x = if macOS && TypeNum.toInt (undefined :: n) == 4 && elem s ["sqrt", "log", "exp", "sin", "cos", "tan"] then do op <- externFunction ("v" ++ s ++ "f") call op x >>= addReadNone else mapVector (callIntrinsic1' s) x callIntrinsic2' s = mapVector2 (callIntrinsic2' s) callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x' callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a callIntrinsic2 s = binop (callIntrinsic2' s) llvm-3.2.0.0/LLVM/Core/0000755000000000000000000000000012142507720012454 5ustar0000000000000000llvm-3.2.0.0/LLVM/Core/CodeGen.hs0000644000000000000000000005054512142507720014325 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, Rank2Types #-} module LLVM.Core.CodeGen( -- * Module creation newModule, newNamedModule, defineModule, createModule, getModuleValues, ModuleValue, castModuleValue, -- * Globals Linkage(..), Visibility(..), -- * Function creation Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, addAttributes, FFI.Attribute(..), externFunction, staticFunction, FunctionArgs, FunctionRet, TFunction, -- * Global variable creation Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, externGlobal, staticGlobal, -- * Values Value(..), ConstValue(..), IsConst(..), valueOf, value, zero, allOnes, undef, createString, createStringNul, withString, withStringNul, constVector, constArray, constStruct, constPackedStruct, -- * Basic blocks BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, createNamedBasicBlock, getCurrentBasicBlock, fromLabel, toLabel, -- * Misc withCurrentBuilder ) where import Data.Typeable import Control.Monad(liftM, when) import Data.Int import Data.Word import Foreign.StablePtr (StablePtr, castStablePtrToPtr) import Foreign.Ptr(minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr) import Foreign.Storable(sizeOf) import Data.TypeLevel hiding (Bool, Eq, (+), (==)) import LLVM.Core.CodeGenMonad import qualified LLVM.FFI.Core as FFI import LLVM.FFI.Core(Linkage(..), Visibility(..)) import qualified LLVM.Core.Util as U import LLVM.Core.Type import LLVM.Core.Data -------------------------------------- -- | Create a new module. newModule :: IO U.Module newModule = newNamedModule "_module" -- XXX should generate a name -- | Create a new explicitely named module. newNamedModule :: String -- ^ module name -> IO U.Module newNamedModule = U.createModule -- | Give the body for a module. defineModule :: U.Module -- ^ module that is defined -> CodeGenModule a -- ^ module body -> IO a defineModule = runCodeGenModule -- | Create a new module with the given body. createModule :: CodeGenModule a -- ^ module body -> IO a createModule cgm = newModule >>= \ m -> defineModule m cgm -------------------------------------- newtype ModuleValue = ModuleValue FFI.ValueRef deriving (Show, Typeable) getModuleValues :: U.Module -> IO [(String, ModuleValue)] getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a) castModuleValue (ModuleValue f) = if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing -------------------------------------- newtype Value a = Value { unValue :: FFI.ValueRef } deriving (Show, Typeable) newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef } deriving (Show, Typeable) -- XXX merge with IsArithmetic? class IsConst a where constOf :: a -> ConstValue a instance IsConst Bool where constOf = constEnum (typeRef True) --instance IsConst Char where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode instance IsConst Word8 where constOf = constI instance IsConst Word16 where constOf = constI instance IsConst Word32 where constOf = constI instance IsConst Word64 where constOf = constI instance IsConst Int8 where constOf = constI instance IsConst Int16 where constOf = constI instance IsConst Int32 where constOf = constI instance IsConst Int64 where constOf = constI instance IsConst Float where constOf = constF instance IsConst Double where constOf = constF --instance IsConst FP128 where constOf = constF constOfPtr :: (IsType a) => a -> Ptr b -> ConstValue a constOfPtr proto p = let ip = p `minusPtr` nullPtr inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto) in if sizeOf p == 4 then inttoptrC $ constOf (fromIntegral ip :: Word32) else if sizeOf p == 8 then inttoptrC $ constOf (fromIntegral ip :: Word64) else error "constOf Ptr: pointer size not 4 or 8" -- This instance doesn't belong here, but mutually recursive modules are painful. instance (IsType a) => IsConst (Ptr a) where constOf p = constOfPtr p p instance IsConst (StablePtr a) where constOf p = constOfPtr p (castStablePtrToPtr p) instance (IsPrimitive a, IsConst a, Pos n) => IsConst (Vector n a) where constOf (Vector xs) = constVector (map constOf xs) instance (IsConst a, IsSized a s, Nat n) => IsConst (Array n a) where constOf (Array xs) = constArray (map constOf xs) instance (IsConstFields a) => IsConst (Struct a) where constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False instance (IsConstFields a) => IsConst (PackedStruct a) where constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True class IsConstFields a where constFieldsOf :: a -> [FFI.ValueRef] instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as instance IsConstFields () where constFieldsOf _ = [] constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) False constI :: (IsInteger a, Integral a) => a -> ConstValue a constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (isSigned i) constF :: (IsFloating a, Real a) => a -> ConstValue a constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i) valueOf :: (IsConst a) => a -> Value a valueOf = value . constOf value :: ConstValue a -> Value a value (ConstValue a) = Value a zero :: forall a . (IsType a) => ConstValue a zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) allOnes :: forall a . (IsInteger a) => ConstValue a allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) undef :: forall a . (IsType a) => ConstValue a undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a) {- createString :: String -> ConstValue (DynamicArray Word8) createString = ConstValue . U.constString constStringNul :: String -> ConstValue (DynamicArray Word8) constStringNul = ConstValue . U.constStringNul -} -------------------------------------- type FunctionRef = FFI.ValueRef -- |A function is simply a pointer to the function. type Function a = Value (Ptr a) -- | Create a new named function. newNamedFunction :: forall a . (IsFunction a) => Linkage -> String -- ^ Function name -> CodeGenModule (Function a) newNamedFunction linkage name = do modul <- getModule let typ = typeRef (undefined :: a) liftIO $ liftM Value $ U.addFunction modul linkage name typ -- | Create a new function. Use 'newNamedFunction' to create a function with external linkage, since -- it needs a known name. newFunction :: forall a . (IsFunction a) => Linkage -> CodeGenModule (Function a) newFunction linkage = genMSym "fun" >>= newNamedFunction linkage -- | Define a function body. The basic block returned by the function is the function entry point. defineFunction :: forall f g r . (FunctionArgs f g r) => Function f -- ^ Function to define (created by 'newFunction'). -> g -- ^ Function body. -> CodeGenModule () defineFunction (Value fn) body = do bld <- liftIO $ U.createBuilder let body' = do l <- newBasicBlock defineBasicBlock l applyArgs fn body :: CodeGenFunction r () runCodeGenFunction bld fn body' return () -- | Create a new function with the given body. createFunction :: (IsFunction f, FunctionArgs f g r) => Linkage -> g -- ^ Function body. -> CodeGenModule (Function f) createFunction linkage body = do f <- newFunction linkage defineFunction f body return f -- | Create a new function with the given body. createNamedFunction :: (IsFunction f, FunctionArgs f g r) => Linkage -> String -> g -- ^ Function body. -> CodeGenModule (Function f) createNamedFunction linkage name body = do f <- newNamedFunction linkage name defineFunction f body return f -- | Set the calling convention of a function. By default it is the -- C calling convention. setFuncCallConv :: Function a -> FFI.CallingConvention -> CodeGenModule () setFuncCallConv (Value f) cc = do liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc) return () -- | Add attributes to a value. Beware, what attributes are allowed depends on -- what kind of value it is. addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r () addAttributes (Value f) i as = do liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as) -- Convert a function of type f = t1->t2->...-> IO r to -- g = Value t1 -> Value t2 -> ... CodeGenFunction r () class FunctionArgs f g r | f -> g r, g r -> f where apArgs :: Int -> FunctionRef -> g -> FA r applyArgs :: (FunctionArgs f g r) => FunctionRef -> g -> FA r applyArgs = apArgs 0 instance (FunctionArgs b b' r) => FunctionArgs (a -> b) (Value a -> b') r where apArgs n f g = apArgs (n+1) f (g $ Value $ U.getParam f n) -- XXX instances for all IsFirstClass functions, -- because Haskell can't deal with the context and the FD type FA a = CodeGenFunction a () instance FunctionArgs (IO Float) (FA Float) Float where apArgs _ _ g = g instance FunctionArgs (IO Double) (FA Double) Double where apArgs _ _ g = g instance FunctionArgs (IO FP128) (FA FP128) FP128 where apArgs _ _ g = g instance (Pos n) => FunctionArgs (IO (IntN n)) (FA (IntN n)) (IntN n) where apArgs _ _ g = g instance (Pos n) => FunctionArgs (IO (WordN n)) (FA (WordN n)) (WordN n) where apArgs _ _ g = g instance FunctionArgs (IO Bool) (FA Bool) Bool where apArgs _ _ g = g instance FunctionArgs (IO Int8) (FA Int8) Int8 where apArgs _ _ g = g instance FunctionArgs (IO Int16) (FA Int16) Int16 where apArgs _ _ g = g instance FunctionArgs (IO Int32) (FA Int32) Int32 where apArgs _ _ g = g instance FunctionArgs (IO Int64) (FA Int64) Int64 where apArgs _ _ g = g instance FunctionArgs (IO Word8) (FA Word8) Word8 where apArgs _ _ g = g instance FunctionArgs (IO Word16) (FA Word16) Word16 where apArgs _ _ g = g instance FunctionArgs (IO Word32) (FA Word32) Word32 where apArgs _ _ g = g instance FunctionArgs (IO Word64) (FA Word64) Word64 where apArgs _ _ g = g instance FunctionArgs (IO ()) (FA ()) () where apArgs _ _ g = g instance (Pos n, IsPrimitive a) => FunctionArgs (IO (Vector n a)) (FA (Vector n a)) (Vector n a) where apArgs _ _ g = g instance StructFields as => FunctionArgs (IO (Struct as)) (FA (Struct as)) (Struct as) where apArgs _ _ g = g instance (IsType a) => FunctionArgs (IO (Ptr a)) (FA (Ptr a)) (Ptr a) where apArgs _ _ g = g instance FunctionArgs (IO (StablePtr a)) (FA (StablePtr a)) (StablePtr a) where apArgs _ _ g = g -- |This class is just to simplify contexts. class (FunctionArgs (IO a) (CodeGenFunction a ()) a) => FunctionRet a instance (FunctionArgs (IO a) (CodeGenFunction a ()) a) => FunctionRet a -------------------------------------- -- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. newtype BasicBlock = BasicBlock FFI.BasicBlockRef deriving (Show, Typeable) createBasicBlock :: CodeGenFunction r BasicBlock createBasicBlock = do b <- newBasicBlock defineBasicBlock b return b createNamedBasicBlock :: String -> CodeGenFunction r BasicBlock createNamedBasicBlock name = do b <- newNamedBasicBlock name defineBasicBlock b return b newBasicBlock :: CodeGenFunction r BasicBlock newBasicBlock = genFSym >>= newNamedBasicBlock newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock newNamedBasicBlock name = do fn <- getFunction liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name defineBasicBlock :: BasicBlock -> CodeGenFunction r () defineBasicBlock (BasicBlock l) = do bld <- getBuilder liftIO $ U.positionAtEnd bld l getCurrentBasicBlock :: CodeGenFunction r BasicBlock getCurrentBasicBlock = do bld <- getBuilder liftIO $ liftM BasicBlock $ U.getInsertBlock bld toLabel :: BasicBlock -> Value Label toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr) fromLabel :: Value Label -> BasicBlock fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr) -------------------------------------- --- XXX: the functions in this section (and addGlobalMapping) don't actually use any -- Function state so should really be in the CodeGenModule monad -- | Create a reference to an external function while code generating for a function. -- If LLVM cannot resolve its name, then you may try 'staticFunction'. externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a) externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage -- | As 'externFunction', but for 'Global's rather than 'Function's externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a) externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a) externCore name act = do es <- getExterns case lookup name es of Just f -> return $ Value f Nothing -> do f <- liftCodeGenModule $ act name putExterns ((name, f) : es) return $ Value f {- | Make an external C function with a fixed address callable from LLVM code. This callback function can also be a Haskell function, that was imported like > foreign import ccall "&nextElement" > nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) See @examples\/List.hs@. When you only use 'externFunction', then LLVM cannot resolve the name. (However, I do not know why.) Thus 'staticFunction' manages a list of static functions. This list is automatically installed by 'ExecutionEngine.simpleFunction' and can be manually obtained by 'getGlobalMappings' and installed by 'ExecutionEngine.addGlobalMappings'. \"Installing\" means calling LLVM's @addGlobalMapping@ according to . -} staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) staticFunction func = liftCodeGenModule $ do val <- newNamedFunction ExternalLinkage "" addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func) return val -- | As 'staticFunction', but for 'Global's rather than 'Function's staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a) staticGlobal isConst gbl = liftCodeGenModule $ do val <- newNamedGlobal isConst ExternalLinkage "" addGlobalMapping (unValue (val :: Global a)) (castPtr gbl) return val -------------------------------------- withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a withCurrentBuilder body = do bld <- getBuilder liftIO $ U.withBuilder bld body -------------------------------------- -- Mark all block terminating instructions. Not used yet. --data Terminate = Terminate -------------------------------------- type Global a = Value (Ptr a) -- | Create a new named global variable. newNamedGlobal :: forall a . (IsType a) => Bool -- ^Constant? -> Linkage -- ^Visibility -> String -- ^Name -> TGlobal a newNamedGlobal isConst linkage name = do modul <- getModule let typ = typeRef (undefined :: a) liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ when isConst $ FFI.setGlobalConstant g True return g -- | Create a new global variable. newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage -- | Give a global variable a (constant) value. defineGlobal :: Global a -> ConstValue a -> CodeGenModule () defineGlobal (Value g) (ConstValue v) = liftIO $ FFI.setInitializer g v -- | Create and define a global variable. createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a createGlobal isConst linkage con = do g <- newGlobal isConst linkage defineGlobal g con return g -- | Create and define a named global variable. createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a createNamedGlobal isConst linkage name con = do g <- newNamedGlobal isConst linkage name defineGlobal g con return g type TFunction a = CodeGenModule (Function a) type TGlobal a = CodeGenModule (Global a) -- Special string creators {-# DEPRECATED createString "use withString instead" #-} createString :: String -> TGlobal (Array n Word8) createString s = let (cstr, n) = U.constString s in string n cstr {-# DEPRECATED createStringNul "use withStringNul instead" #-} createStringNul :: String -> TGlobal (Array n Word8) createStringNul s = let (cstr, n) = U.constStringNul s in string n cstr class WithString a where withString :: String -> (forall n . Nat n => Global (Array n Word8) -> a) -> a withStringNul :: String -> (forall n . Nat n => Global (Array n Word8) -> a) -> a instance WithString (CodeGenModule a) where withString s act = let (cstr, n) = U.constString s in reifyIntegral n (\tn -> do arr <- string n cstr act (fixArraySize tn arr)) withStringNul s act = let (cstr, n) = U.constStringNul s in reifyIntegral n (\tn -> do arr <- string n cstr act (fixArraySize tn arr)) instance WithString (CodeGenFunction r b) where withString s act = let (cstr, n) = U.constString s in reifyIntegral n (\tn -> do arr <- liftCodeGenModule $ string n cstr act (fixArraySize tn arr)) withStringNul s act = let (cstr, n) = U.constStringNul s in reifyIntegral n (\tn -> do arr <- liftCodeGenModule $ string n cstr act (fixArraySize tn arr)) fixArraySize :: n -> Global (Array n a) -> Global (Array n a) fixArraySize _ = id string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8) string n s = do modul <- getModule name <- genMSym "str" let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n) liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ FFI.setGlobalConstant g True FFI.setInitializer g s return g -------------------------------------- -- |Make a constant vector. Replicates or truncates the list to get length /n/. constVector :: forall a n . (Pos n) => [ConstValue a] -> ConstValue (Vector n a) constVector xs = ConstValue $ U.constVector (toNum (undefined :: n)) [ v | ConstValue v <- xs ] -- |Make a constant array. Replicates or truncates the list to get length /n/. constArray :: forall a n s . (IsSized a s, Nat n) => [ConstValue a] -> ConstValue (Array n a) constArray xs = ConstValue $ U.constArray (typeRef (undefined :: a)) (toNum (undefined :: n)) [ v | ConstValue v <- xs ] -- |Make a constant struct. constStruct :: (IsConstStruct c a) => c -> ConstValue (Struct a) constStruct struct = ConstValue $ U.constStruct (constValueFieldsOf struct) False -- |Make a constant packed struct. constPackedStruct :: (IsConstStruct c a) => c -> ConstValue (PackedStruct a) constPackedStruct struct = ConstValue $ U.constStruct (constValueFieldsOf struct) True class IsConstStruct c a | a -> c, c -> a where constValueFieldsOf :: c -> [FFI.ValueRef] instance (IsConst a, IsConstStruct cs as) => IsConstStruct (ConstValue a, cs) (a, as) where constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as instance IsConstStruct () () where constValueFieldsOf _ = [] llvm-3.2.0.0/LLVM/Core/Vector.hs0000644000000000000000000001173512142507720014261 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables #-} module LLVM.Core.Vector(MkVector(..), vector, ) where import Data.Function import Data.TypeLevel hiding (Eq, (+), (==), (-), (*), succ, pred, div, mod, divMod, logBase) import LLVM.Core.Type import LLVM.Core.Data import LLVM.ExecutionEngine.Target import Foreign.Ptr(castPtr) import Foreign.Storable(Storable(..)) import Foreign.Marshal.Array(peekArray, pokeArray) import System.IO.Unsafe(unsafePerformIO) -- XXX Should these really be here? class (Pos n, IsPrimitive a) => MkVector va n a | va -> n a, n a -> va where toVector :: va -> Vector n a fromVector :: Vector n a -> va {- instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where toVector a = Vector [a] -} instance (IsPrimitive a) => MkVector (a, a) D2 a where toVector (a1, a2) = Vector [a1, a2] fromVector (Vector [a1, a2]) = (a1, a2) fromVector _ = error "fromVector: impossible" instance (IsPrimitive a) => MkVector (a, a, a, a) D4 a where toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4] fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4) fromVector _ = error "fromVector: impossible" instance (IsPrimitive a) => MkVector (a, a, a, a, a, a, a, a) D8 a where toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8] fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8) fromVector _ = error "fromVector: impossible" instance (Storable a, Pos n, IsPrimitive a) => Storable (Vector n a) where sizeOf a = storeSizeOfType ourTargetData (typeRef a) alignment a = aBIAlignmentOfType ourTargetData (typeRef a) peek p = fmap Vector $ peekArray (toNum (undefined :: n)) (castPtr p :: Ptr a) poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs -- XXX The JITer target data. This isn't really right. ourTargetData :: TargetData ourTargetData = unsafePerformIO getTargetData -------------------------------------- unVector :: Vector n a -> [a] unVector (Vector xs) = xs -- |Make a constant vector. Replicates or truncates the list to get length /n/. -- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'. vector :: forall a n. (Pos n) => [a] -> Vector n a vector xs = Vector (take (toNum (undefined :: n)) (cycle xs)) binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys) unop :: (a -> b) -> Vector n a -> Vector n b unop op = Vector . map op . unVector instance (Eq a, Pos n) => Eq (Vector n a) where (==) = (==) `on` unVector instance (Ord a, Pos n) => Ord (Vector n a) where compare = compare `on` unVector instance (Num a, Pos n) => Num (Vector n a) where (+) = binop (+) (-) = binop (-) (*) = binop (*) negate = unop negate abs = unop abs signum = unop signum fromInteger = Vector . replicate (toNum (undefined :: n)) . fromInteger instance (Enum a, Pos n) => Enum (Vector n a) where succ = unop succ pred = unop pred fromEnum = error "Vector fromEnum" toEnum = Vector . map toEnum . replicate (toNum (undefined :: n)) instance (Real a, Pos n) => Real (Vector n a) where toRational = error "Vector toRational" instance (Integral a, Pos n) => Integral (Vector n a) where quot = binop quot rem = binop rem div = binop div mod = binop mod quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys toInteger = error "Vector toInteger" instance (Fractional a, Pos n) => Fractional (Vector n a) where (/) = binop (/) fromRational = Vector . replicate (toNum (undefined :: n)) . fromRational instance (RealFrac a, Pos n) => RealFrac (Vector n a) where properFraction = error "Vector properFraction" instance (Floating a, Pos n) => Floating (Vector n a) where pi = Vector $ replicate (toNum (undefined :: n)) pi sqrt = unop sqrt log = unop log logBase = binop logBase (**) = binop (**) exp = unop exp sin = unop sin cos = unop cos tan = unop tan asin = unop asin acos = unop acos atan = unop atan sinh = unop sinh cosh = unop cosh tanh = unop tanh asinh = unop asinh acosh = unop acosh atanh = unop atanh instance (RealFloat a, Pos n) => RealFloat (Vector n a) where floatRadix = floatRadix . head . unVector floatDigits = floatDigits . head . unVector floatRange = floatRange . head . unVector decodeFloat = error "Vector decodeFloat" encodeFloat = error "Vector encodeFloat" exponent _ = 0 scaleFloat 0 x = x scaleFloat _ _ = error "Vector scaleFloat" isNaN = error "Vector isNaN" isInfinite = error "Vector isInfinite" isDenormalized = error "Vector isDenormalized" isNegativeZero = error "Vector isNegativeZero" isIEEE = isIEEE . head . unVector llvm-3.2.0.0/LLVM/Core/Data.hs0000644000000000000000000000240112142507720013656 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls, DeriveDataTypeable #-} module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where import Data.Typeable import Foreign.Ptr(Ptr) -- TODO: -- Make instances IntN, WordN to actually do the right thing. -- Make FP128 do the right thing -- Make Array functions. -- |Variable sized signed integer. -- The /n/ parameter should belong to @PosI@. newtype IntN n = IntN Integer deriving (Show, Typeable) -- |Variable sized unsigned integer. -- The /n/ parameter should belong to @PosI@. newtype WordN n = WordN Integer deriving (Show, Typeable) -- |128 bit floating point. newtype FP128 = FP128 Rational deriving (Show, Typeable) -- |Fixed sized arrays, the array size is encoded in the /n/ parameter. newtype Array n a = Array [a] deriving (Show, Typeable) -- |Fixed sized vector, the array size is encoded in the /n/ parameter. newtype Vector n a = Vector [a] deriving (Show, Typeable) -- |Label type, produced by a basic block. data Label deriving (Typeable) -- |Struct types; a list (nested tuple) of component types. newtype Struct a = Struct a deriving (Show, Typeable) newtype PackedStruct a = PackedStruct a deriving (Show, Typeable) llvm-3.2.0.0/LLVM/Core/CodeGenMonad.hs0000644000000000000000000000723012142507720015275 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module LLVM.Core.CodeGenMonad( -- * Module code generation CodeGenModule, runCodeGenModule, genMSym, getModule, GlobalMappings(..), addGlobalMapping, getGlobalMappings, -- * Function code generation CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, -- * Reexport liftIO ) where import Data.Typeable import Control.Monad.State import Control.Applicative (Applicative, ) import Foreign.Ptr (Ptr, ) import LLVM.Core.Util(Module, Builder, Function) -------------------------------------- data CGMState = CGMState { cgm_module :: Module, cgm_externs :: [(String, Function)], cgm_global_mappings :: [(Function, Ptr ())], cgm_next :: !Int } deriving (Show, Typeable) newtype CodeGenModule a = CGM (StateT CGMState IO a) deriving (Functor, Applicative, Monad, MonadState CGMState, MonadIO, Typeable) genMSym :: String -> CodeGenModule String genMSym prefix = do s <- get let n = cgm_next s put (s { cgm_next = n + 1 }) return $ "_" ++ prefix ++ show n getModule :: CodeGenModule Module getModule = gets cgm_module runCodeGenModule :: Module -> CodeGenModule a -> IO a runCodeGenModule m (CGM body) = do let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] } evalStateT body cgm -------------------------------------- data CGFState r = CGFState { cgf_module :: CGMState, cgf_builder :: Builder, cgf_function :: Function, cgf_next :: !Int } deriving (Show, Typeable) newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) deriving (Functor, Applicative, Monad, MonadState (CGFState r), MonadIO, Typeable) genFSym :: CodeGenFunction a String genFSym = do s <- get let n = cgf_next s put (s { cgf_next = n + 1 }) return $ "_L" ++ show n getFunction :: CodeGenFunction a Function getFunction = gets cgf_function getBuilder :: CodeGenFunction a Builder getBuilder = gets cgf_builder getFunctionModule :: CodeGenFunction a Module getFunctionModule = gets (cgm_module . cgf_module) getExterns :: CodeGenFunction a [(String, Function)] getExterns = gets (cgm_externs . cgf_module) putExterns :: [(String, Function)] -> CodeGenFunction a () putExterns es = do cgf <- get let cgm' = (cgf_module cgf) { cgm_externs = es } put (cgf { cgf_module = cgm' }) addGlobalMapping :: Function -> Ptr () -> CodeGenModule () addGlobalMapping value func = modify $ \cgm -> cgm { cgm_global_mappings = (value,func) : cgm_global_mappings cgm } newtype GlobalMappings = GlobalMappings [(Function, Ptr ())] {- | Get a list created by calls to 'staticFunction' that must be passed to the execution engine via 'LLVM.ExecutionEngine.addGlobalMappings'. -} getGlobalMappings :: CodeGenModule GlobalMappings getGlobalMappings = gets (GlobalMappings . cgm_global_mappings) runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a runCodeGenFunction bld fn (CGF body) = do cgm <- get let cgf = CGFState { cgf_module = cgm, cgf_builder = bld, cgf_function = fn, cgf_next = 1 } (a, cgf') <- liftIO $ runStateT body cgf put (cgf_module cgf') return a -------------------------------------- -- | Allows you to define part of a module while in the middle of defining a function. liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a liftCodeGenModule (CGM act) = do cgf <- get (a, cgm') <- liftIO $ runStateT act (cgf_module cgf) put (cgf { cgf_module = cgm' }) return a llvm-3.2.0.0/LLVM/Core/Util.hs0000644000000000000000000004422712142507720013736 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, DeriveDataTypeable #-} module LLVM.Core.Util( -- * Module handling Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile, getModuleValues, getFunctions, getGlobalVariables, valueHasType, -- * Module provider handling ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, -- * Pass manager handling PassManager(..), withPassManager, createPassManager, createFunctionPassManager, runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, -- * Instruction builder Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock, -- * Basic blocks BasicBlock, appendBasicBlock, getBasicBlocks, -- * Functions Function, addFunction, getParam, getParams, -- * Structs structType, -- * Globals addGlobal, constString, constStringNul, constVector, constArray, constStruct, -- * Instructions makeCall, makeInvoke, makeCallWithCc, makeInvokeWithCc, withValue, getInstructions, getOperands, -- * Uses and Users hasUsers, getUsers, getUses, getUser, isChildOf, getDep, -- * Misc CString, withArrayLen, withEmptyCString, functionType, buildEmptyPhi, addPhiIns, showTypeOf, getValueNameU, setValueNameU, getObjList, annotateValueList, isConstant, -- * Transformation passes addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, addTargetData ) where import Data.Typeable import Data.List(intercalate) import Control.Monad(liftM, filterM, when) import Foreign.C.String (withCString, withCStringLen, CString, peekCString) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (Storable(..)) import System.IO.Unsafe (unsafePerformIO) import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Target as FFI import qualified LLVM.FFI.BitWriter as FFI import qualified LLVM.FFI.BitReader as FFI import qualified LLVM.FFI.Transforms.Scalar as FFI type Type = FFI.TypeRef -- unsafePerformIO just to wrap the non-effecting withArrayLen call functionType :: Bool -> Type -> [Type] -> Type functionType varargs retType paramTypes = unsafePerformIO $ withArrayLen paramTypes $ \ len ptr -> return $ FFI.functionType retType ptr (fromIntegral len) varargs -- unsafePerformIO just to wrap the non-effecting withArrayLen call structType :: [Type] -> Bool -> Type structType types packed = unsafePerformIO $ withArrayLen types $ \ len ptr -> return $ FFI.structType ptr (fromIntegral len) packed -------------------------------------- -- Handle modules -- Don't use a finalizer for the module, but instead provide an -- explicit destructor. This is because handing a module to -- a module provider changes ownership of the module to the provider, -- and we don't want to free it by mistake. -- | Type of top level modules. newtype Module = Module { fromModule :: FFI.ModuleRef } deriving (Show, Typeable) withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a withModule modul f = f (fromModule modul) createModule :: String -> IO Module createModule name = withCString name $ \ namePtr -> do liftM Module $ FFI.moduleCreateWithName namePtr -- | Free all storage related to a module. *Note*, this is a dangerous call, since referring -- to the module after this call is an error. The reason for the explicit call to free -- the module instead of an automatic lifetime management is that modules have a -- somewhat complicated ownership. Handing a module to a module provider changes -- the ownership of the module, and the module provider will free the module when necessary. destroyModule :: Module -> IO () destroyModule = FFI.disposeModule . fromModule -- |Write a module to a file. writeBitcodeToFile :: String -> Module -> IO () writeBitcodeToFile name mdl = withCString name $ \ namePtr -> withModule mdl $ \ mdlPtr -> do rc <- FFI.writeBitcodeToFile mdlPtr namePtr when (rc /= False) $ ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc return () -- |Read a module from a file. readBitcodeFromFile :: String -> IO Module readBitcodeFromFile name = withCString name $ \ namePtr -> alloca $ \ bufPtr -> alloca $ \ modPtr -> alloca $ \ errStr -> do rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr if rrc /= False then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg else do buf <- peek bufPtr prc <- FFI.parseBitcode buf modPtr errStr if prc /= False then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg else do ptr <- peek modPtr return $ Module ptr {- liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr -} getModuleValues :: Module -> IO [(String, Value)] getModuleValues mdl = do fs <- getFunctions mdl gs <- getGlobalVariables mdl return (fs ++ gs) getFunctions :: Module -> IO [(String, Value)] getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList getGlobalVariables :: Module -> IO [(String, Value)] getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList -- This is safe because we just ask for the type of a value. valueHasType :: Value -> Type -> Bool valueHasType v t = unsafePerformIO $ do vt <- FFI.typeOf v return $ vt == t -- LLVM uses hash consing for types, so pointer equality works. showTypeOf :: Value -> IO String showTypeOf v = FFI.typeOf v >>= showType' showType' :: Type -> IO String showType' p = do pk <- FFI.getTypeKind p case pk of FFI.VoidTypeKind -> return "()" FFI.HalfTypeKind -> return "Half" FFI.FloatTypeKind -> return "Float" FFI.DoubleTypeKind -> return "Double" FFI.X86_FP80TypeKind -> return "X86_FP80" FFI.FP128TypeKind -> return "FP128" FFI.PPC_FP128TypeKind -> return "PPC_FP128" FFI.X86_MMXTypeKind -> return "X86_MMX" FFI.MetadataTypeKind -> return "Metadata" FFI.LabelTypeKind -> return "Label" FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")" FFI.FunctionTypeKind -> do r <- FFI.getReturnType p c <- FFI.countParamTypes p let n = fromIntegral c as <- allocaArray n $ \ args -> do FFI.getParamTypes p args peekArray n args ts <- mapM showType' (as ++ [r]) return $ "(" ++ intercalate " -> " ts ++ ")" FFI.StructTypeKind -> return "(Struct ...)" FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")" FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")" FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" -------------------------------------- -- Handle module providers -- | A module provider is used by the code generator to get access to a module. newtype ModuleProvider = ModuleProvider { fromModuleProvider :: ForeignPtr FFI.ModuleProvider } deriving (Show, Typeable) withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) -> IO a withModuleProvider = withForeignPtr . fromModuleProvider -- | Turn a module into a module provider. createModuleProviderForExistingModule :: Module -> IO ModuleProvider createModuleProviderForExistingModule modul = withModule modul $ \modulPtr -> do ptr <- FFI.createModuleProviderForExistingModule modulPtr -- MPs given to the EE get taken over, so we should not GC them. liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr -------------------------------------- -- Handle instruction builders newtype Builder = Builder { fromBuilder :: ForeignPtr FFI.Builder } deriving (Show, Typeable) withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a withBuilder = withForeignPtr . fromBuilder createBuilder :: IO Builder createBuilder = do ptr <- FFI.createBuilder liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO () positionAtEnd bld bblk = withBuilder bld $ \ bldPtr -> FFI.positionAtEnd bldPtr bblk getInsertBlock :: Builder -> IO FFI.BasicBlockRef getInsertBlock bld = withBuilder bld $ \ bldPtr -> FFI.getInsertBlock bldPtr -------------------------------------- type BasicBlock = FFI.BasicBlockRef appendBasicBlock :: Function -> String -> IO BasicBlock appendBasicBlock func name = withCString name $ \ namePtr -> FFI.appendBasicBlock func namePtr getBasicBlocks :: Value -> IO [(String, Value)] getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList -------------------------------------- type Function = FFI.ValueRef addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function addFunction modul linkage name typ = withModule modul $ \ modulPtr -> withCString name $ \ namePtr -> do f <- FFI.addFunction modulPtr namePtr typ FFI.setLinkage f (FFI.fromLinkage linkage) return f getParam :: Function -> Int -> Value getParam f = FFI.getParam f . fromIntegral getParams :: Value -> IO [(String, Value)] getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList -------------------------------------- addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value addGlobal modul linkage name typ = withModule modul $ \ modulPtr -> withCString name $ \ namePtr -> do v <- FFI.addGlobal modulPtr typ namePtr FFI.setLinkage v (FFI.fromLinkage linkage) return v -- unsafePerformIO is safe because it's only used for the withCStringLen conversion constStringInternal :: Bool -> String -> (Value, Int) constStringInternal nulTerm s = unsafePerformIO $ withCStringLen s $ \(sPtr, sLen) -> return (FFI.constString sPtr (fromIntegral sLen) (not nulTerm), sLen) constString :: String -> (Value, Int) constString = constStringInternal False constStringNul :: String -> (Value, Int) constStringNul str = let (cstr, n) = constStringInternal True str in (cstr, n+1) -------------------------------------- type Value = FFI.ValueRef withValue :: Value -> (Value -> IO a) -> IO a withValue v f = f v makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value makeCall = makeCallWithCc FFI.C makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value makeCallWithCc cc func bldPtr args = do {- print "makeCall" FFI.dumpValue func mapM_ FFI.dumpValue args print "----------------------" -} withArrayLen args $ \ argLen argPtr -> withEmptyCString $ \cstr -> do i <- FFI.buildCall bldPtr func argPtr (fromIntegral argLen) cstr FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) return i makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> [Value] -> IO Value makeInvoke = makeInvokeWithCc FFI.C makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> [Value] -> IO Value makeInvokeWithCc cc norm expt func bldPtr args = withArrayLen args $ \ argLen argPtr -> withEmptyCString $ \cstr -> do i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) return i getInstructions :: Value -> IO [(String, Value)] getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList getOperands :: Value -> IO [(String, Value)] getOperands ii = geto ii >>= annotateValueList where geto i = do num <- FFI.getNumOperands i let oloop instr number total = if number >= total then return [] else do o <- FFI.getOperand instr number os <- oloop instr (number + 1) total return (o : os) oloop i 0 num -------------------------------------- buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value buildEmptyPhi bldPtr typ = do withEmptyCString $ FFI.buildPhi bldPtr typ withEmptyCString :: (CString -> IO a) -> IO a withEmptyCString = withCString "" addPhiIns :: Value -> [(Value, BasicBlock)] -> IO () addPhiIns inst incoming = do let (vals, bblks) = unzip incoming withArrayLen vals $ \ count valPtr -> withArray bblks $ \ bblkPtr -> FFI.addIncoming inst valPtr bblkPtr (fromIntegral count) -------------------------------------- -- | Manage compile passes. newtype PassManager = PassManager { fromPassManager :: ForeignPtr FFI.PassManager } deriving (Show, Typeable) withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a) -> IO a withPassManager = withForeignPtr . fromPassManager -- | Create a pass manager. createPassManager :: IO PassManager createPassManager = do ptr <- FFI.createPassManager liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr -- | Create a pass manager for a module. createFunctionPassManager :: ModuleProvider -> IO PassManager createFunctionPassManager modul = withModuleProvider modul $ \modulPtr -> do ptr <- FFI.createFunctionPassManager modulPtr liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr -- | Add a control flow graph simplification pass to the manager. addCFGSimplificationPass :: PassManager -> IO () addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass -- | Add a constant propagation pass to the manager. addConstantPropagationPass :: PassManager -> IO () addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass addDemoteMemoryToRegisterPass :: PassManager -> IO () addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass -- | Add a global value numbering pass to the manager. addGVNPass :: PassManager -> IO () addGVNPass pm = withPassManager pm FFI.addGVNPass addInstructionCombiningPass :: PassManager -> IO () addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass addPromoteMemoryToRegisterPass :: PassManager -> IO () addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass addReassociatePass :: PassManager -> IO () addReassociatePass pm = withPassManager pm FFI.addReassociatePass addTargetData :: FFI.TargetDataRef -> PassManager -> IO () addTargetData td pm = withPassManager pm $ FFI.addTargetData td runFunctionPassManager :: PassManager -> Function -> IO Bool runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn initializeFunctionPassManager :: PassManager -> IO Bool initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager finalizeFunctionPassManager :: PassManager -> IO Bool finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager -------------------------------------- -- The unsafePerformIO is just for the non-effecting withArrayLen constVector :: Int -> [Value] -> Value constVector n xs = unsafePerformIO $ do let xs' = take n (cycle xs) withArrayLen xs' $ \ len ptr -> return $ FFI.constVector ptr (fromIntegral len) -- The unsafePerformIO is just for the non-effecting withArrayLen constArray :: Type -> Int -> [Value] -> Value constArray t n xs = unsafePerformIO $ do let xs' = take n (cycle xs) withArrayLen xs' $ \ len ptr -> return $ FFI.constArray t ptr (fromIntegral len) -- The unsafePerformIO is just for the non-effecting withArrayLen constStruct :: [Value] -> Bool -> Value constStruct xs packed = unsafePerformIO $ do withArrayLen xs $ \ len ptr -> return $ FFI.constStruct ptr (fromIntegral len) packed -------------------------------------- getValueNameU :: Value -> IO String getValueNameU a = do -- sometimes void values need explicit names too cs <- FFI.getValueName a str <- peekCString cs if str == "" then return (show a) else return str setValueNameU :: String -> Value -> IO () setValueNameU str a = do withCString str $ \ strPtr -> FFI.setValueName a strPtr getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a)) -> (Ptr a -> IO (Ptr a)) -> t1 -> t getObjList withF firstF nextF obj = do withF obj $ \ objPtr -> do ofst <- firstF objPtr let oloop p = if p == nullPtr then return [] else do n <- nextF p ps <- oloop n return (p : ps) oloop ofst annotateValueList :: [Value] -> IO [(String, Value)] annotateValueList vs = do names <- mapM getValueNameU vs return $ zip names vs isConstant :: Value -> IO Bool isConstant = FFI.isConstant isIntrinsic :: Value -> IO Bool isIntrinsic v = do if FFI.getIntrinsicID v == 0 then return True else return False -------------------------------------- type Use = FFI.UseRef hasUsers :: Value -> IO Bool hasUsers v = do nU <- FFI.getNumUses v if nU == 0 then return False else return True getUses :: Value -> IO [Use] getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse getUsers :: [Use] -> IO [(String, Value)] getUsers us = mapM FFI.getUser us >>= annotateValueList getUser :: Use -> IO Value getUser = FFI.getUser isChildOf :: BasicBlock -> Value -> IO Bool isChildOf bb v = do bb2 <- FFI.getInstructionParent v if bb == bb2 then return True else return False getDep :: Use -> IO (String, String) getDep u = do producer <- FFI.getUsedValue u >>= getValueNameU consumer <- FFI.getUser u >>= getValueNameU return (producer, consumer) llvm-3.2.0.0/LLVM/Core/Type.hs0000644000000000000000000003754712142507720013751 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, IncoherentInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, TypeSynonymInstances, UndecidableInstances #-} -- |The LLVM type system is captured with a number of Haskell type classes. -- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type. -- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for -- those types that are LLVM first class types (passable as arguments etc). -- All valid LLVM types belong to the 'IsType' class. module LLVM.Core.Type( -- * Type classifier IsType(..), -- * StructFields classifier StructFields, -- ** Special type classifiers Nat, Pos, IsArithmetic(arithmeticType), ArithmeticType(IntegerType,FloatingType), IsInteger, IsIntegerOrPointer, IsFloating, IsPrimitive, IsFirstClass, IsSized, IsFunction, -- ** Others NumberOfElements, UnknownSize, -- needed for arrays of structs -- ** Structs (:&), (&), -- ** Type tests TypeDesc(..), isFloating, isSigned, typeRef, typeName, typeDesc2, VarArgs, CastVarArgs, ) where import Data.Data import Data.List(intercalate) import Data.Int import Data.Word import Data.TypeLevel hiding (Bool, Eq) import Foreign.StablePtr (StablePtr, ) import LLVM.Core.Util(functionType, structType) import LLVM.Core.Data import qualified LLVM.FFI.Core as FFI #include "MachDeps.h" -- TODO: -- Move IntN, WordN to a special module that implements those types -- properly in Haskell. -- Also more Array and Vector to a Haskell module to implement them. -- Add Label? -- Add structures (using tuples, maybe nested). -- |The 'IsType' class classifies all types that have an LLVM representation. class IsType a where typeDesc :: a -> TypeDesc typeRef :: (IsType a) => a -> FFI.TypeRef -- ^The argument is never evaluated typeRef = code . typeDesc where code TDFloat = FFI.floatType code TDDouble = FFI.doubleType code TDFP128 = FFI.fp128Type code TDVoid = FFI.voidType code (TDInt _ n) = FFI.integerType (fromInteger n) code (TDArray n a) = FFI.arrayType (code a) (fromInteger n) code (TDVector n a) = FFI.vectorType (code a) (fromInteger n) code (TDPtr a) = FFI.pointerType (code a) 0 code (TDFunction va as b) = functionType va (code b) (map code as) code TDLabel = FFI.labelType code (TDStruct ts packed) = structType (map code ts) packed code TDInvalidType = error "typeRef TDInvalidType" typeName :: (IsType a) => a -> String typeName = code . typeDesc where code TDFloat = "f32" code TDDouble = "f64" code TDFP128 = "f128" code TDVoid = "void" code (TDInt _ n) = "i" ++ show n code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]" code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">" code (TDPtr a) = code a ++ "*" code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" code TDLabel = "label" code (TDStruct as packed) = (if packed then "<{" else "{") ++ intercalate "," (map code as) ++ (if packed then "}>" else "}") code TDInvalidType = error "typeName TDInvalidType" typeDesc2 :: FFI.TypeRef -> IO TypeDesc typeDesc2 t = do tk <- FFI.getTypeKind t case tk of FFI.VoidTypeKind -> return TDVoid FFI.FloatTypeKind -> return TDFloat FFI.DoubleTypeKind -> return TDDouble -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80" FFI.FP128TypeKind -> return TDFP128 -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128" FFI.LabelTypeKind -> return TDLabel FFI.IntegerTypeKind -> do n <- FFI.getIntTypeWidth t return $ TDInt False (fromIntegral n) -- FIXME: FFI.FunctionTypeKind -- FIXME: FFI.StructTypeKind -> return "(Struct ...)" FFI.ArrayTypeKind -> do n <- FFI.getArrayLength t et <- FFI.getElementType t etd <- typeDesc2 et return $ TDArray (fromIntegral n) etd FFI.PointerTypeKind -> do et <- FFI.getElementType t etd <- typeDesc2 et return $ TDPtr etd -- FIXME: FFI.OpaqueTypeKind -> return "Opaque" FFI.VectorTypeKind -> do n <- FFI.getVectorSize t et <- FFI.getElementType t etd <- typeDesc2 et return $ TDVector (fromIntegral n) etd -- FIXME: LLVMMetadataTypeKind, /**< Metadata */ -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */ _ -> return TDInvalidType -- |Type descriptor, used to convey type information through the LLVM API. data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer | TDArray Integer TypeDesc | TDVector Integer TypeDesc | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel | TDStruct [TypeDesc] Bool | TDInvalidType deriving (Eq, Ord, Show, Typeable, Data) -- XXX isFloating and typeName could be extracted from typeRef -- Usage: -- superclass of IsConst -- add, sub, mul, neg context -- used to get type name to call intrinsic -- |Arithmetic types, i.e., integral and floating types. class IsFirstClass a => IsArithmetic a where arithmeticType :: ArithmeticType a data ArithmeticType a = IntegerType | FloatingType instance Functor ArithmeticType where fmap _ IntegerType = IntegerType fmap _ FloatingType = FloatingType -- Usage: -- constI, allOnes -- many instructions. XXX some need vector -- used to find signedness in Arithmetic -- |Integral types. class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a -- Usage: -- icmp -- |Integral or pointer type. class IsIntegerOrPointer a isSigned :: (IsInteger a) => a -> Bool isSigned = is . typeDesc where is (TDInt s _) = s is (TDVector _ a) = is a is _ = error "isSigned got impossible input" -- Usage: -- constF -- many instructions -- |Floating types. class IsArithmetic a => IsFloating a isFloating :: (IsArithmetic a) => a -> Bool isFloating = is . typeDesc where is TDFloat = True is TDDouble = True is TDFP128 = True is (TDVector _ a) = is a is _ = False -- Usage: -- Precondition for Vector -- |Primitive types. class (NumberOfElements D1 a) => IsPrimitive a -- |Number of elements for instructions that handle both primitive and vector types class (IsType a) => NumberOfElements n a | a -> n -- Usage: -- Precondition for function args and result. -- Used by some instructions, like ret and phi. -- XXX IsSized as precondition? -- |First class types, i.e., the types that can be passed as arguments, etc. class IsType a => IsFirstClass a -- Usage: -- Context for Array being a type -- thus, allocation instructions -- |Types with a fixed size. class (IsType a, Pos s) => IsSized a s | a -> s -- |Function type. class (IsType a) => IsFunction a where funcType :: [TypeDesc] -> a -> TypeDesc -- Only make instances for types that make sense in Haskell -- (i.e., some floating types are excluded). -- Floating point types. instance IsType Float where typeDesc _ = TDFloat instance IsType Double where typeDesc _ = TDDouble instance IsType FP128 where typeDesc _ = TDFP128 -- Void type instance IsType () where typeDesc _ = TDVoid -- Label type instance IsType Label where typeDesc _ = TDLabel -- Variable size integer types instance (Pos n) => IsType (IntN n) where typeDesc _ = TDInt True (toNum (undefined :: n)) instance (Pos n) => IsType (WordN n) where typeDesc _ = TDInt False (toNum (undefined :: n)) -- Fixed size integer types. instance IsType Bool where typeDesc _ = TDInt False 1 instance IsType Word8 where typeDesc _ = TDInt False 8 instance IsType Word16 where typeDesc _ = TDInt False 16 instance IsType Word32 where typeDesc _ = TDInt False 32 instance IsType Word64 where typeDesc _ = TDInt False 64 instance IsType Int8 where typeDesc _ = TDInt True 8 instance IsType Int16 where typeDesc _ = TDInt True 16 instance IsType Int32 where typeDesc _ = TDInt True 32 instance IsType Int64 where typeDesc _ = TDInt True 64 -- Sequence types instance (Nat n, IsSized a s) => IsType (Array n a) where typeDesc _ = TDArray (toNum (undefined :: n)) (typeDesc (undefined :: a)) instance (Pos n, IsPrimitive a) => IsType (Vector n a) where typeDesc _ = TDVector (toNum (undefined :: n)) (typeDesc (undefined :: a)) -- Pointer type. instance (IsType a) => IsType (Ptr a) where typeDesc _ = TDPtr (typeDesc (undefined :: a)) instance IsType (StablePtr a) where typeDesc _ = TDPtr (typeDesc (undefined :: Int8)) {- typeDesc _ = TDPtr TDVoid List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed. -} -- Functions. instance (IsFirstClass a, IsFunction b) => IsType (a->b) where typeDesc = funcType [] -- Function base type, always IO. instance (IsFirstClass a) => IsType (IO a) where typeDesc = funcType [] -- Struct types, basically a list of component types. instance (StructFields a) => IsType (Struct a) where typeDesc ~(Struct a) = TDStruct (fieldTypes a) False instance (StructFields a) => IsType (PackedStruct a) where typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True -- Use a nested tuples for struct fields. class StructFields as where fieldTypes :: as -> [TypeDesc] instance (IsSized a sa, StructFields as) => StructFields (a :& as) where fieldTypes ~(a, as) = typeDesc a : fieldTypes as instance StructFields () where fieldTypes _ = [] -- An alias for pairs to make structs look nicer infixr :& type (:&) a as = (a, as) infixr & (&) :: a -> as -> a :& as a & as = (a, as) --- Instances to classify types instance IsArithmetic Float where arithmeticType = FloatingType instance IsArithmetic Double where arithmeticType = FloatingType instance IsArithmetic FP128 where arithmeticType = FloatingType instance (Pos n) => IsArithmetic (IntN n) where arithmeticType = IntegerType instance (Pos n) => IsArithmetic (WordN n) where arithmeticType = IntegerType instance IsArithmetic Bool where arithmeticType = IntegerType instance IsArithmetic Int8 where arithmeticType = IntegerType instance IsArithmetic Int16 where arithmeticType = IntegerType instance IsArithmetic Int32 where arithmeticType = IntegerType instance IsArithmetic Int64 where arithmeticType = IntegerType instance IsArithmetic Word8 where arithmeticType = IntegerType instance IsArithmetic Word16 where arithmeticType = IntegerType instance IsArithmetic Word32 where arithmeticType = IntegerType instance IsArithmetic Word64 where arithmeticType = IntegerType instance (Pos n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a) where arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType instance IsFloating Float instance IsFloating Double instance IsFloating FP128 instance (Pos n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) instance (Pos n) => IsInteger (IntN n) instance (Pos n) => IsInteger (WordN n) instance IsInteger Bool instance IsInteger Int8 instance IsInteger Int16 instance IsInteger Int32 instance IsInteger Int64 instance IsInteger Word8 instance IsInteger Word16 instance IsInteger Word32 instance IsInteger Word64 instance (Pos n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a) instance (Pos n) => IsIntegerOrPointer (IntN n) instance (Pos n) => IsIntegerOrPointer (WordN n) instance IsIntegerOrPointer Bool instance IsIntegerOrPointer Int8 instance IsIntegerOrPointer Int16 instance IsIntegerOrPointer Int32 instance IsIntegerOrPointer Int64 instance IsIntegerOrPointer Word8 instance IsIntegerOrPointer Word16 instance IsIntegerOrPointer Word32 instance IsIntegerOrPointer Word64 instance (Pos n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a) instance (IsType a) => IsIntegerOrPointer (Ptr a) instance IsFirstClass Float instance IsFirstClass Double instance IsFirstClass FP128 instance (Pos n) => IsFirstClass (IntN n) instance (Pos n) => IsFirstClass (WordN n) instance IsFirstClass Bool instance IsFirstClass Int8 instance IsFirstClass Int16 instance IsFirstClass Int32 instance IsFirstClass Int64 instance IsFirstClass Word8 instance IsFirstClass Word16 instance IsFirstClass Word32 instance IsFirstClass Word64 instance (Pos n, IsPrimitive a) => IsFirstClass (Vector n a) instance (Nat n, IsType a, IsSized a s) => IsFirstClass (Array n a) instance (IsType a) => IsFirstClass (Ptr a) instance IsFirstClass (StablePtr a) instance IsFirstClass Label instance IsFirstClass () -- XXX This isn't right, but () can be returned instance (StructFields as) => IsFirstClass (Struct as) instance IsSized Float D32 instance IsSized Double D64 instance IsSized FP128 D128 instance (Pos n) => IsSized (IntN n) n instance (Pos n) => IsSized (WordN n) n instance IsSized Bool D1 instance IsSized Int8 D8 instance IsSized Int16 D16 instance IsSized Int32 D32 instance IsSized Int64 D64 instance IsSized Word8 D8 instance IsSized Word16 D16 instance IsSized Word32 D32 instance IsSized Word64 D64 instance (Nat n, IsSized a s, Mul n s ns, Pos ns) => IsSized (Array n a) ns instance (Pos n, IsPrimitive a, IsSized a s, Mul n s ns, Pos ns) => IsSized (Vector n a) ns instance (IsType a) => IsSized (Ptr a) PtrSize instance IsSized (StablePtr a) PtrSize -- instance IsSized Label PtrSize -- labels are not quite first classed -- We cannot compute the sizes statically :( instance (StructFields as) => IsSized (Struct as) UnknownSize instance (StructFields as) => IsSized (PackedStruct as) UnknownSize type UnknownSize = D99 -- XXX this is wrong! #if WORD_SIZE_IN_BITS == 32 type PtrSize = D32 #elif WORD_SIZE_IN_BITS == 64 type PtrSize = D64 #else #error cannot determine type of PtrSize #endif instance IsPrimitive Float instance IsPrimitive Double instance IsPrimitive FP128 instance (Pos n) => IsPrimitive (IntN n) instance (Pos n) => IsPrimitive (WordN n) instance IsPrimitive Bool instance IsPrimitive Int8 instance IsPrimitive Int16 instance IsPrimitive Int32 instance IsPrimitive Int64 instance IsPrimitive Word8 instance IsPrimitive Word16 instance IsPrimitive Word32 instance IsPrimitive Word64 instance IsPrimitive Label instance IsPrimitive () instance NumberOfElements D1 Float instance NumberOfElements D1 Double instance NumberOfElements D1 FP128 instance (Pos n) => NumberOfElements D1 (IntN n) instance (Pos n) => NumberOfElements D1 (WordN n) instance NumberOfElements D1 Bool instance NumberOfElements D1 Int8 instance NumberOfElements D1 Int16 instance NumberOfElements D1 Int32 instance NumberOfElements D1 Int64 instance NumberOfElements D1 Word8 instance NumberOfElements D1 Word16 instance NumberOfElements D1 Word32 instance NumberOfElements D1 Word64 instance NumberOfElements D1 Label instance NumberOfElements D1 () instance (Pos n, IsPrimitive a) => NumberOfElements n (Vector n a) -- Functions. instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b) instance (IsFirstClass a) => IsFunction (IO a) where funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a)) instance (IsFirstClass a) => IsFunction (VarArgs a) where funcType ts _ = TDFunction True (reverse ts) (typeDesc (undefined :: a)) -- |The 'VarArgs' type is a placeholder for the real 'IO' type that -- can be obtained with 'castVarArgs'. data VarArgs a deriving (Typeable) instance IsType (VarArgs a) where typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly" -- |Define what vararg types are permissible. class CastVarArgs a b instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c) instance CastVarArgs (VarArgs a) (IO a) instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c) -- XXX Structures not implemented. Tuples is probably an easy way. llvm-3.2.0.0/LLVM/Core/Instructions.hs0000644000000000000000000013257312142507720015527 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts, TypeOperators, DeriveDataTypeable, ForeignFunctionInterface #-} module LLVM.Core.Instructions( -- * ADT representation of IR BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc, -- * Terminator instructions ret, condBr, br, switch, invoke, invokeWithConv, -- Removed in LLVM_3.0 -- unwind, unreachable, -- * Arithmetic binary operations -- | Arithmetic operations with the normal semantics. -- The u instractions are unsigned, the s instructions are signed. add, sub, mul, neg, iadd, isub, imul, ineg, fadd, fsub, fmul, fneg, idiv, irem, udiv, sdiv, fdiv, urem, srem, frem, -- * Logical binary operations -- |Logical instructions with the normal semantics. shl, lshr, ashr, and, or, xor, inv, -- * Vector operations extractelement, insertelement, shufflevector, -- * Aggregate operation extractvalue, insertvalue, -- * Memory access malloc, arrayMalloc, alloca, arrayAlloca, free, load, store, getElementPtr, getElementPtr0, unsafeGetElementPtr, -- * Conversions trunc, zext, sext, fptrunc, fpext, fptoui, fptosi, fptoint, uitofp, sitofp, inttofp, ptrtoint, inttoptr, bitcast, bitcastUnify, -- * Comparison CmpPredicate(..), IntPredicate(..), FPPredicate(..), CmpRet(..), cmp, pcmp, icmp, fcmp, select, -- * Other phi, addPhiInputs, call, callWithConv, sizeOf, alignOf, -- * Classes and types Terminate, Ret, CallArgs, ABinOp, CmpOp, FunctionArgs, FunctionRet, IsConst, AllocArg, GetElementPtr, IsIndexArg, GetValue ) where import Prelude hiding (and, or) import Data.Typeable import Control.Monad(liftM) import Data.Int import Data.Word import Data.Map(fromList, (!)) import Foreign.Ptr (FunPtr, ) import Foreign.C(CUInt) import Data.TypeLevel((:<:), (:>:), (:==:), (:*), D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, d1, toNum, Succ) import qualified LLVM.FFI.Core as FFI import LLVM.FFI.Core ( IntPredicate(..) , toIntPredicate , fromIntPredicate , FPPredicate(..) , toFPPredicate , fromFPPredicate ) import LLVM.Core.Data import LLVM.Core.Type import LLVM.Core.CodeGenMonad import LLVM.Core.CodeGen import qualified LLVM.Core.Util as U -- TODO: -- Add vector version of arithmetic -- Add rest of instructions -- Use Terminate to ensure bb termination (how?) -- more intrinsics are needed to, e.g., create an empty vector data ArgDesc = AV String | AI Int | AL String | AE instance Show ArgDesc where -- show (AV s) = "V_" ++ s -- show (AI i) = "I_" ++ show i -- show (AL l) = "L_" ++ l show (AV s) = s show (AI i) = show i show (AL l) = l show AE = "voidarg?" data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor deriving Show -- FIXME: complete definitions for unimplemented instructions data InstrDesc = -- terminators IDRet TypeDesc ArgDesc | IDRetVoid | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc | IDSwitch [(ArgDesc, ArgDesc)] | IDIndirectBr | IDInvoke | IDUnwind | IDUnreachable -- binary operators (including bitwise) | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc -- memory access and addressing | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc | IDGetElementPtr TypeDesc [ArgDesc] -- conversion | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc | IDSItoFP TypeDesc TypeDesc ArgDesc | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc | IDBitcast TypeDesc TypeDesc ArgDesc -- other | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc] | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg -- vector operators | IDExtractElement | IDInsertElement | IDShuffleVector -- aggregate operators | IDExtractValue | IDInsertValue -- invalid | IDInvalidOp deriving Show -- TODO: overflow support for binary operations (add/sub/mul) getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc) getInstrDesc v = do valueName <- U.getValueNameU v opcode <- FFI.instGetOpcode v t <- FFI.typeOf v >>= typeDesc2 -- FIXME: sizeof() does not work for types! --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral tsize <- return 1 os <- U.getOperands v >>= mapM getArgDesc os0 <- if length os > 0 then return $ os !! 0 else return AE os1 <- if length os > 1 then return $ os !! 1 else return AE t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41) then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2 else return TDVoid) p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0 let instr = (if opcode >= 8 && opcode <= 25 -- binary arithmetic then IDBinOp (getBinOp opcode) t os0 os1 else if opcode >= 30 && opcode <= 41 -- conversion then (getConvOp opcode) t2 t os0 else case opcode of { 1 -> if null os then IDRetVoid else IDRet t os0; 2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1; 3 -> IDSwitch $ toPairs os; -- TODO (can skip for now) -- 4 -> IndirectBr ; 5 -> Invoke ; 6 -> IDUnwind; 7 -> IDUnreachable; 26 -> IDAlloca (getPtrType t) tsize (getImmInt os0); 27 -> IDLoad t os0; 28 -> IDStore t os0 os1; 29 -> IDGetElementPtr t os; 42 -> IDICmp (toIntPredicate p) os0 os1; 43 -> IDFCmp (toFPPredicate p) os0 os1; 44 -> IDPhi t $ toPairs os; -- FIXME: getelementptr arguments are not handled 45 -> IDCall t (last os) (init os); 46 -> IDSelect t os0 os1; -- TODO (can skip for now) -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ; -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ; -- 53 -> ExtractValue ; 54 -> InsertValue ; _ -> IDInvalidOp }) return (valueName, instr) --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub), (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv), (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem), (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd), (24, BOOr), (25, BOXor)] ! o getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI), (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc), (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs)) stride _ [] = [] stride n (x:xs) = x : stride n (drop (n-1) xs) getPtrType (TDPtr t) = t getPtrType _ = TDVoid getImmInt (AI i) = i getImmInt _ = 0 -- TODO: fix for non-int constants getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc getArgDesc (vname, v) = do isC <- U.isConstant v t <- FFI.typeOf v >>= typeDesc2 if isC then case t of TDInt _ _ -> do cV <- FFI.constIntGetSExtValue v return $ AI $ fromIntegral cV _ -> return AE else case t of TDLabel -> return $ AL vname _ -> return $ AV vname -------------------------------------- type Terminate = () terminate :: Terminate terminate = () -------------------------------------- -- |Acceptable arguments to the 'ret' instruction. class Ret a r where ret' :: a -> CodeGenFunction r Terminate -- | Return from the current function with the given value. Use () as the return value for what would be a void function is C. ret :: (Ret a r) => a -> CodeGenFunction r Terminate ret = ret' instance (IsFirstClass a, IsConst a) => Ret a a where ret' = ret . valueOf instance Ret (Value a) a where ret' (Value a) = do withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a return terminate instance Ret () () where ret' _ = do withCurrentBuilder_ $ FFI.buildRetVoid return terminate withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r () withCurrentBuilder_ p = withCurrentBuilder p >> return () -------------------------------------- -- | Branch to the first basic block if the boolean is true, otherwise to the second basic block. condBr :: Value Bool -- ^ Boolean to branch upon. -> BasicBlock -- ^ Target for true. -> BasicBlock -- ^ Target for false. -> CodeGenFunction r Terminate condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2 return terminate -------------------------------------- -- | Unconditionally branch to the given basic block. br :: BasicBlock -- ^ Branch target. -> CodeGenFunction r Terminate br (BasicBlock t) = do withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t return terminate -------------------------------------- -- | Branch table instruction. switch :: (IsInteger a) => Value a -- ^ Value to branch upon. -> BasicBlock -- ^ Default branch target. -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets. -> CodeGenFunction r Terminate switch (Value val) (BasicBlock dflt) arms = do withCurrentBuilder_ $ \ bldPtr -> do inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms) sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ] return terminate -------------------------------------- -- Removed in LLVM_3.0 -- |Unwind the call stack until a function call performed with 'invoke' is reached. -- I.e., throw a non-local exception. -- unwind :: CodeGenFunction r Terminate -- unwind = do -- withCurrentBuilder_ FFI.buildUnwind -- return terminate -- |Inform the code generator that this code can never be reached. unreachable :: CodeGenFunction r Terminate unreachable = do withCurrentBuilder_ FFI.buildUnreachable return terminate -------------------------------------- type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef withArithmeticType :: (IsArithmetic c) => (ArithmeticType c -> a -> CodeGenFunction r (v c)) -> (a -> CodeGenFunction r (v c)) withArithmeticType f = f arithmeticType -- |Acceptable arguments to arithmetic binary instructions. class ABinOp a b c | a b -> c where abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r c add :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) add = curry $ withArithmeticType $ \typ -> uncurry $ case typ of IntegerType -> abinop FFI.constAdd FFI.buildAdd FloatingType -> abinop FFI.constFAdd FFI.buildFAdd sub :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) sub = curry $ withArithmeticType $ \typ -> uncurry $ case typ of IntegerType -> abinop FFI.constSub FFI.buildSub FloatingType -> abinop FFI.constFSub FFI.buildFSub mul :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) mul = curry $ withArithmeticType $ \typ -> uncurry $ case typ of IntegerType -> abinop FFI.constMul FFI.buildMul FloatingType -> abinop FFI.constFMul FFI.buildFMul iadd :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) iadd = abinop FFI.constAdd FFI.buildAdd isub :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) isub = abinop FFI.constSub FFI.buildSub imul :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) imul = abinop FFI.constMul FFI.buildMul -- | signed or unsigned integer division depending on the type idiv :: forall a b c r v. (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) idiv = if isSigned (undefined :: c) then abinop FFI.constSDiv FFI.buildSDiv else abinop FFI.constUDiv FFI.buildUDiv -- | signed or unsigned remainder depending on the type irem :: forall a b c r v. (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) irem = if isSigned (undefined :: c) then abinop FFI.constSRem FFI.buildSRem else abinop FFI.constURem FFI.buildURem {-# DEPRECATED udiv "use idiv instead" #-} {-# DEPRECATED sdiv "use idiv instead" #-} {-# DEPRECATED urem "use irem instead" #-} {-# DEPRECATED srem "use irem instead" #-} udiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) udiv = abinop FFI.constUDiv FFI.buildUDiv sdiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) sdiv = abinop FFI.constSDiv FFI.buildSDiv urem :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) urem = abinop FFI.constURem FFI.buildURem srem :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) srem = abinop FFI.constSRem FFI.buildSRem fadd :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) fadd = abinop FFI.constFAdd FFI.buildFAdd fsub :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) fsub = abinop FFI.constFSub FFI.buildFSub fmul :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) fmul = abinop FFI.constFMul FFI.buildFMul -- | Floating point division. fdiv :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) fdiv = abinop FFI.constFDiv FFI.buildFDiv -- | Floating point remainder. frem :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) frem = abinop FFI.constFRem FFI.buildFRem shl :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) shl = abinop FFI.constShl FFI.buildShl lshr :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) lshr = abinop FFI.constLShr FFI.buildLShr ashr :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) ashr = abinop FFI.constAShr FFI.buildAShr and :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) and = abinop FFI.constAnd FFI.buildAnd or :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) or = abinop FFI.constOr FFI.buildOr xor :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) xor = abinop FFI.constXor FFI.buildXor instance ABinOp (Value a) (Value a) (Value a) where abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2 instance ABinOp (ConstValue a) (Value a) (Value a) where abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2 instance ABinOp (Value a) (ConstValue a) (Value a) where abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2 instance ABinOp (ConstValue a) (ConstValue a) (ConstValue a) where abinop cop _ (ConstValue a1) (ConstValue a2) = return $ ConstValue $ cop a1 a2 instance (IsConst a) => ABinOp (Value a) a (Value a) where abinop cop op a1 a2 = abinop cop op a1 (constOf a2) instance (IsConst a) => ABinOp a (Value a) (Value a) where abinop cop op a1 a2 = abinop cop op (constOf a1) a2 --instance (IsConst a) => ABinOp a a (ConstValue a) where -- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2) buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) buildBinOp op a1 a2 = liftM Value $ withCurrentBuilder $ \ bld -> U.withEmptyCString $ op bld a1 a2 type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a) buildUnOp op a = liftM Value $ withCurrentBuilder $ \ bld -> U.withEmptyCString $ op bld a neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a) neg = withArithmeticType $ \typ -> case typ of IntegerType -> \(Value x) -> buildUnOp FFI.buildNeg x FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a) ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) ineg (Value x) = buildUnOp FFI.buildNeg x fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a) fneg = fsub (value zero :: Value a) {- fneg (Value x) = buildUnOp FFI.buildFNeg x -} inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) inv (Value x) = buildUnOp FFI.buildNot x -------------------------------------- -- | Get a value from a vector. extractelement :: (Pos n) => Value (Vector n a) -- ^ Vector -> Value Word32 -- ^ Index into the vector -> CodeGenFunction r (Value a) extractelement (Value vec) (Value i) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i -- | Insert a value into a vector, nondestructive. insertelement :: (Pos n) => Value (Vector n a) -- ^ Vector -> Value a -- ^ Value to insert -> Value Word32 -- ^ Index into the vector -> CodeGenFunction r (Value (Vector n a)) insertelement (Value vec) (Value e) (Value i) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i -- | Permute vector. shufflevector :: (Pos n, Pos m) => Value (Vector n a) -> Value (Vector n a) -> ConstValue (Vector m Word32) -> CodeGenFunction r (Value (Vector m a)) shufflevector (Value a) (Value b) (ConstValue mask) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask -- |Acceptable arguments to 'extractvalue' and 'insertvalue'. class GetValue agg ix el | agg ix -> el where getIx :: agg -> ix -> CUInt instance (GetField as i a, Nat i) => GetValue (Struct as) i a where getIx _ n = toNum n instance (IsFirstClass a, Nat n) => GetValue (Array n a) Word32 a where getIx _ n = fromIntegral n instance (IsFirstClass a, Nat n) => GetValue (Array n a) Word64 a where getIx _ n = fromIntegral n instance (IsFirstClass a, Nat n, Nat (i1:*i0), (i1:*i0) :<: n) => GetValue (Array n a) (i1:*i0) a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D0 :<: n) => GetValue (Array n a) D0 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D1 :<: n) => GetValue (Array n a) D1 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D2 :<: n) => GetValue (Array n a) D2 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D3 :<: n) => GetValue (Array n a) D3 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D4 :<: n) => GetValue (Array n a) D4 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D5 :<: n) => GetValue (Array n a) D5 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D6 :<: n) => GetValue (Array n a) D6 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D7 :<: n) => GetValue (Array n a) D7 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D8 :<: n) => GetValue (Array n a) D8 a where getIx _ n = toNum n instance (IsFirstClass a, Nat n, D9 :<: n) => GetValue (Array n a) D9 a where getIx _ n = toNum n -- | Get a value from an aggregate. extractvalue :: forall r agg i a. GetValue agg i a => Value agg -- ^ Aggregate -> i -- ^ Index into the aggregate -> CodeGenFunction r (Value a) extractvalue (Value agg) i = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i) -- | Insert a value into an aggregate, nondestructive. insertvalue :: forall r agg i a. GetValue agg i a => Value agg -- ^ Aggregate -> Value a -- ^ Value to insert -> i -- ^ Index into the aggregate -> CodeGenFunction r (Value agg) insertvalue (Value agg) (Value e) i = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i) -------------------------------------- -- XXX should allows constants -- | Truncate a value to a shorter bit width. trunc :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b, IsSized a sa, IsSized b sb, sa :>: sb) => Value a -> CodeGenFunction r (Value b) trunc = convert FFI.buildTrunc -- | Zero extend a value to a wider width. zext :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b, IsSized a sa, IsSized b sb, sa :<: sb) => Value a -> CodeGenFunction r (Value b) zext = convert FFI.buildZExt -- | Sign extend a value to wider width. sext :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b, IsSized a sa, IsSized b sb, sa :<: sb) => Value a -> CodeGenFunction r (Value b) sext = convert FFI.buildSExt -- | Truncate a floating point value. fptrunc :: (IsFloating a, IsFloating b, IsPrimitive a, IsPrimitive b, IsSized a sa, IsSized b sb, sa :>: sb) => Value a -> CodeGenFunction r (Value b) fptrunc = convert FFI.buildFPTrunc -- | Extend a floating point value. fpext :: (IsFloating a, IsFloating b, IsPrimitive a, IsPrimitive b, IsSized a sa, IsSized b sb, sa :<: sb) => Value a -> CodeGenFunction r (Value b) fpext = convert FFI.buildFPExt {-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-} -- | Convert a floating point value to an unsigned integer. fptoui :: (IsFloating a, IsInteger b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) fptoui = convert FFI.buildFPToUI {-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-} -- | Convert a floating point value to a signed integer. fptosi :: (IsFloating a, IsInteger b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) fptosi = convert FFI.buildFPToSI -- | Convert a floating point value to an integer. -- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. fptoint :: forall r n a b. (IsFloating a, IsInteger b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) fptoint = if isSigned (undefined :: b) then convert FFI.buildFPToSI else convert FFI.buildFPToUI {-# DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" #-} -- | Convert an unsigned integer to a floating point value. uitofp :: (IsInteger a, IsFloating b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) uitofp = convert FFI.buildUIToFP {-# DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" #-} -- | Convert a signed integer to a floating point value. sitofp :: (IsInteger a, IsFloating b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) sitofp = convert FFI.buildSIToFP -- | Convert an integer to a floating point value. -- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. inttofp :: forall r n a b. (IsInteger a, IsFloating b, NumberOfElements n a, NumberOfElements n b) => Value a -> CodeGenFunction r (Value b) inttofp = if isSigned (undefined :: a) then convert FFI.buildSIToFP else convert FFI.buildUIToFP -- | Convert a pointer to an integer. ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b) ptrtoint = convert FFI.buildPtrToInt -- | Convert an integer to a pointer. inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b)) inttoptr = convert FFI.buildIntToPtr -- | Convert between to values of the same size by just copying the bit pattern. bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a sa, IsSized b sb, sa :==: sb) => Value a -> CodeGenFunction r (Value b) bitcast = convert FFI.buildBitCast -- | Same as bitcast but instead of the '(:==:)' type class it uses type unification. -- This way, properties like reflexivity, symmetry and transitivity -- are obvious to the Haskell compiler. bitcastUnify :: (IsFirstClass a, IsFirstClass b, IsSized a s, IsSized b s) => Value a -> CodeGenFunction r (Value b) bitcastUnify = convert FFI.buildBitCast type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b) convert conv (Value a) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b)) -------------------------------------- data CmpPredicate = CmpEQ -- ^ equal | CmpNE -- ^ not equal | CmpGT -- ^ greater than | CmpGE -- ^ greater or equal | CmpLT -- ^ less than | CmpLE -- ^ less or equal deriving (Eq, Ord, Enum, Show, Typeable) uintFromCmpPredicate :: CmpPredicate -> IntPredicate uintFromCmpPredicate p = case p of CmpEQ -> IntEQ CmpNE -> IntNE CmpGT -> IntUGT CmpGE -> IntUGE CmpLT -> IntULT CmpLE -> IntULE sintFromCmpPredicate :: CmpPredicate -> IntPredicate sintFromCmpPredicate p = case p of CmpEQ -> IntEQ CmpNE -> IntNE CmpGT -> IntSGT CmpGE -> IntSGE CmpLT -> IntSLT CmpLE -> IntSLE fpFromCmpPredicate :: CmpPredicate -> FPPredicate fpFromCmpPredicate p = case p of CmpEQ -> FPOEQ CmpNE -> FPONE CmpGT -> FPOGT CmpGE -> FPOGE CmpLT -> FPOLT CmpLE -> FPOLE -- |Acceptable operands to comparison instructions. class CmpOp a b c d | a b -> c where cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value d) instance CmpOp (Value a) (Value a) a d where cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 instance (IsConst a) => CmpOp a (Value a) a d where cmpop op a1 a2 = cmpop op (valueOf a1) a2 instance (IsConst a) => CmpOp (Value a) a a d where cmpop op a1 a2 = cmpop op a1 (valueOf a2) class CmpRet c d | c -> d where cmpBld :: c -> CmpPredicate -> FFIBinOp instance CmpRet Float Bool where cmpBld _ = fcmpBld instance CmpRet Double Bool where cmpBld _ = fcmpBld instance CmpRet FP128 Bool where cmpBld _ = fcmpBld instance CmpRet Bool Bool where cmpBld _ = ucmpBld instance CmpRet Word8 Bool where cmpBld _ = ucmpBld instance CmpRet Word16 Bool where cmpBld _ = ucmpBld instance CmpRet Word32 Bool where cmpBld _ = ucmpBld instance CmpRet Word64 Bool where cmpBld _ = ucmpBld instance CmpRet Int8 Bool where cmpBld _ = scmpBld instance CmpRet Int16 Bool where cmpBld _ = scmpBld instance CmpRet Int32 Bool where cmpBld _ = scmpBld instance CmpRet Int64 Bool where cmpBld _ = scmpBld instance CmpRet (Ptr a) Bool where cmpBld _ = ucmpBld instance (CmpRet a b, IsPrimitive a, Pos n) => CmpRet (Vector n a) (Vector n b) where cmpBld _ = cmpBld (undefined :: a) {- | Compare values of ordered types and choose predicates according to the compared types. Floating point numbers are compared in \"ordered\" mode, that is @NaN@ operands yields 'False' as result. Pointers are compared unsigned. These choices are consistent with comparison in plain Haskell. -} cmp :: forall a b c d r. (CmpOp a b c d, CmpRet c d) => CmpPredicate -> a -> b -> CodeGenFunction r (Value d) cmp p = cmpop (cmpBld (undefined :: c) p) ucmpBld :: CmpPredicate -> FFIBinOp ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)) scmpBld :: CmpPredicate -> FFIBinOp scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)) fcmpBld :: CmpPredicate -> FFIBinOp fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p)) _ucmp :: (IsInteger c, CmpOp a b c d, CmpRet c d) => CmpPredicate -> a -> b -> CodeGenFunction r (Value d) _ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))) _scmp :: (IsInteger c, CmpOp a b c d, CmpRet c d) => CmpPredicate -> a -> b -> CodeGenFunction r (Value d) _scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))) pcmp :: (CmpOp a b (Ptr c) d, CmpRet (Ptr c) d) => IntPredicate -> a -> b -> CodeGenFunction r (Value d) pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) {-# DEPRECATED icmp "use cmp or pcmp instead" #-} -- | Compare integers. icmp :: (IsIntegerOrPointer c, CmpOp a b c d, CmpRet c d) => IntPredicate -> a -> b -> CodeGenFunction r (Value d) icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) -- | Compare floating point values. fcmp :: (IsFloating c, CmpOp a b c d, CmpRet c d) => FPPredicate -> a -> b -> CodeGenFunction r (Value d) fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p)) -------------------------------------- -- XXX could do const song and dance -- | Select between two values depending on a boolean. select :: (IsFirstClass a, CmpRet a b) => Value b -> Value a -> Value a -> CodeGenFunction r (Value a) select (Value cnd) (Value thn) (Value els) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildSelect bldPtr cnd thn els -------------------------------------- type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef -- |Acceptable arguments to 'call'. class CallArgs f g r | g -> r f, f r -> g where doCall :: Caller -> [FFI.ValueRef] -> f -> g instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where doCall mkCall args f (Value arg) = doCall mkCall (arg : args) (f (undefined :: a)) --instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where -- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a)) instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where doCall = doCallDef doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a) doCallDef mkCall args _ = withCurrentBuilder $ \ bld -> liftM Value $ mkCall bld (reverse args) -- | Call a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments -- it takes depends on the type of /f/. call :: (CallArgs f g r) => Function f -> g call (Value f) = doCall (U.makeCall f) [] (undefined :: f) -- | Call a function with exception handling. invoke :: (CallArgs f g r) => BasicBlock -- ^Normal return point. -> BasicBlock -- ^Exception return point. -> Function f -- ^Function to call. -> g invoke (BasicBlock norm) (BasicBlock expt) (Value f) = doCall (U.makeInvoke norm expt f) [] (undefined :: f) -- | Call a function with the given arguments. The 'call' instruction -- is variadic, i.e., the number of arguments it takes depends on the -- type of /f/. -- This also sets the calling convention of the call to the function. -- As LLVM itself defines, if the calling conventions of the calling -- /instruction/ and the function being /called/ are different, undefined -- behavior results. callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g callWithConv cc (Value f) = doCall (U.makeCallWithCc cc f) [] (undefined :: f) -- | Call a function with exception handling. -- This also sets the calling convention of the call to the function. -- As LLVM itself defines, if the calling conventions of the calling -- /instruction/ and the function being /called/ are different, undefined -- behavior results. invokeWithConv :: (CallArgs f g r) => FFI.CallingConvention -- ^Calling convention -> BasicBlock -- ^Normal return point. -> BasicBlock -- ^Exception return point. -> Function f -- ^Function to call. -> g invokeWithConv cc (BasicBlock norm) (BasicBlock expt) (Value f) = doCall (U.makeInvokeWithCc cc norm expt f) [] (undefined :: f) -------------------------------------- -- XXX could do const song and dance -- |Join several variables (virtual registers) from different basic blocks into one. -- All of the variables in the list are joined. See also 'addPhiInputs'. phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a) phi incoming = liftM Value $ withCurrentBuilder $ \ bldPtr -> do inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a)) U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] return inst -- |Add additional inputs to an existing phi node. -- The reason for this instruction is that sometimes the structure of the code -- makes it impossible to have all variables in scope at the point where you need the phi node. addPhiInputs :: forall a r . (IsFirstClass a) => Value a -- ^Must be a variable from a call to 'phi'. -> [(Value a, BasicBlock)] -- ^Variables to add. -> CodeGenFunction r () addPhiInputs (Value inst) incoming = liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] -------------------------------------- -- | Acceptable argument to array memory allocation. class AllocArg a where getAllocArg :: a -> Value Word32 instance AllocArg (Value Word32) where getAllocArg = id instance AllocArg (ConstValue Word32) where getAllocArg = value instance AllocArg Word32 where getAllocArg = valueOf -- could be moved to Util.Memory -- FFI.buildMalloc deprecated since LLVM-2.7 -- XXX What's the type returned by malloc -- | Allocate heap memory. malloc :: forall a r s . (IsSized a s) => CodeGenFunction r (Value (Ptr a)) malloc = arrayMalloc (1::Word32) {- I use a pointer type as size parameter of 'malloc'. This way I hope that the parameter has always the correct size (32 or 64 bit). A side effect is that we can convert the result of 'getelementptr' using 'bitcast', that does not suffer from the slow assembly problem. (bug #8281) -} foreign import ccall "&aligned_malloc_sizeptr" alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)) foreign import ccall "&aligned_free" alignedFree :: FunPtr (Ptr Word8 -> IO ()) {- There is a bug in LLVM-2.7 and LLVM-2.8 (http://llvm.org/bugs/show_bug.cgi?id=8281) that causes huge assembly times for expressions like ptrtoint(getelementptr(zero,..)). If you break those expressions into two statements at separate lines, everything is fine. But the C interface is too clever, and rewrites two separate statements into a functional expression on a single line. Such code is generated whenever you call buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf. One possible way is to write a getelementptr expression containing a nullptr in a way that hides the constant nature of nullptr. ptr <- alloca store (value zero) ptr z <- load ptr size <- bitcastUnify =<< getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ()) However, I found that bitcast on pointers causes no problems. Thus I switched to using pointers for size quantities. This still allows for optimizations involving pointers. -} -- XXX What's the type returned by arrayMalloc? -- | Allocate heap (array) memory. arrayMalloc :: forall a n r s . (IsSized a n, AllocArg s) => s -> CodeGenFunction r (Value (Ptr a)) -- XXX arrayMalloc s = do func <- staticFunction alignedMalloc -- func <- externFunction "malloc" size <- sizeOfArray (undefined :: a) (getAllocArg s) alignment <- alignOf (undefined :: a) bitcastUnify =<< call (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))) size alignment -- XXX What's the type returned by malloc -- | Allocate stack memory. alloca :: forall a r s . (IsSized a s) => CodeGenFunction r (Value (Ptr a)) alloca = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a)) -- XXX What's the type returned by arrayAlloca? -- | Allocate stack (array) memory. arrayAlloca :: forall a n r s . (IsSized a n, AllocArg s) => s -> CodeGenFunction r (Value (Ptr a)) arrayAlloca s = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v) -- FFI.buildFree deprecated since LLVM-2.7 -- XXX What's the type of free? -- | Free heap memory. free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () free ptr = do func <- staticFunction alignedFree -- func <- externFunction "free" _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcastUnify ptr return () -- | If we want to export that, then we should have a Size type -- This is the official implementation, -- but it suffers from the ptrtoint(gep) bug. sizeOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value Word64) sizeOf a = liftIO $ liftM Value $ FFI.sizeOf (typeRef a) _alignOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value Word64) _alignOf a = liftIO $ liftM Value $ FFI.alignOf (typeRef a) -- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281. -- see ConstantExpr::getSizeOf sizeOfArray :: forall a r s . (IsSized a s) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8)) sizeOfArray _ len = bitcastUnify =<< getElementPtr (value zero :: Value (Ptr a)) (len, ()) -- see ConstantExpr::getAlignOf alignOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value (Ptr Word8)) alignOf _ = bitcastUnify =<< getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ()) -- | Load a value from memory. load :: Value (Ptr a) -- ^ Address to load from. -> CodeGenFunction r (Value a) load (Value p) = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildLoad bldPtr p -- | Store a value in memory store :: Value a -- ^ Value to store. -> Value (Ptr a) -- ^ Address to store to. -> CodeGenFunction r () store (Value v) (Value p) = do withCurrentBuilder_ $ \ bldPtr -> FFI.buildStore bldPtr v p return () {- -- XXX type is wrong -- | Address arithmetic. See LLVM description. -- (The type isn't as accurate as it should be.) getElementPtr :: (IsInteger i) => Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b)) getElementPtr (Value ptr) ixs = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr -> U.withEmptyCString $ FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) -} -- |Acceptable arguments to 'getElementPointer'. class GetElementPtr optr ixs nptr | optr ixs -> nptr {-, ixs nptr -> optr, nptr optr -> ixs-} where getIxList :: optr -> ixs -> [FFI.ValueRef] -- |Acceptable single index to 'getElementPointer'. class IsIndexArg a where getArg :: a -> FFI.ValueRef instance IsIndexArg (Value Word32) where getArg (Value v) = v instance IsIndexArg (Value Word64) where getArg (Value v) = v instance IsIndexArg (Value Int32) where getArg (Value v) = v instance IsIndexArg (Value Int64) where getArg (Value v) = v instance IsIndexArg (ConstValue Word32) where getArg = unConst instance IsIndexArg (ConstValue Word64) where getArg = unConst instance IsIndexArg (ConstValue Int32) where getArg = unConst instance IsIndexArg (ConstValue Int64) where getArg = unConst instance IsIndexArg Word32 where getArg = unConst . constOf instance IsIndexArg Word64 where getArg = unConst . constOf instance IsIndexArg Int32 where getArg = unConst . constOf instance IsIndexArg Int64 where getArg = unConst . constOf unConst :: ConstValue a -> FFI.ValueRef unConst (ConstValue v) = v -- End of indexing instance GetElementPtr a () a where getIxList _ () = [] -- Index in Array instance (GetElementPtr o i n, IsIndexArg a, Nat k) => GetElementPtr (Array k o) (a, i) n where getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i -- Index in Vector instance (GetElementPtr o i n, IsIndexArg a, Pos k) => GetElementPtr (Vector k o) (a, i) n where getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i -- Index in Struct and PackedStruct. -- The index has to be a type level integer to statically determine the record field type instance (GetElementPtr o i n, GetField fs a o, Nat a) => GetElementPtr (Struct fs) (a, i) n where getIxList _ (v, i) = unConst (constOf (toNum v :: Word32)) : getIxList (undefined :: o) i instance (GetElementPtr o i n, GetField fs a o, Nat a) => GetElementPtr (PackedStruct fs) (a, i) n where getIxList _ (v, i) = unConst (constOf (toNum v :: Word32)) : getIxList (undefined :: o) i class GetField as i a | as i -> a instance GetField (a, as) D0 a instance (GetField as i b, Succ i i') => GetField (a, as) i' b -- | Address arithmetic. See LLVM description. -- The index is a nested tuple of the form @(i1,(i2,( ... ())))@. -- (This is without a doubt the most confusing LLVM instruction, but the types help.) getElementPtr :: forall a o i n r . (GetElementPtr o i n, IsIndexArg a) => Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr n)) getElementPtr val (a, ixs) = let ixl = getArg a : getIxList (undefined :: o) ixs in getElementPtrFromValues val ixl -- | Like getElementPtr, but with an initial index that is 0. -- This is useful since any pointer first need to be indexed off the pointer, and then into -- its actual value. This first indexing is often with 0. getElementPtr0 :: (GetElementPtr o i n) => Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr n)) getElementPtr0 p i = getElementPtr p (0::Word32, i) -- | Call getelementptr directly with a list of indexes. -- This is should be used only if the runtime type is not yet known. -- If the indexes and return type are incorrect this function may segfault -- in LLVMBuildGEP, or assert if debug assertions are enabled. unsafeGetElementPtr :: forall o i n r . IsIndexArg i => Value (Ptr o) -> [i] -> CodeGenFunction r (Value (Ptr n)) unsafeGetElementPtr val i = let ixl = map getArg i in getElementPtrFromValues val ixl -- | Internal function for emitting a GEP getElementPtrFromValues :: forall o n r . Value (Ptr o) -> [FFI.ValueRef] -> CodeGenFunction r (Value n) getElementPtrFromValues (Value ptr) ixl = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withArrayLen ixl $ \ idxLen idxPtr -> U.withEmptyCString $ FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) -------------------------------------- {- instance (IsConst a) => Show (ConstValue a) -- XXX instance (IsConst a) => Eq (ConstValue a) {- instance (IsConst a) => Eq (ConstValue a) where ConstValue x == ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y) ConstValue x /= ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y) instance (IsConst a) => Ord (ConstValue a) where ConstValue x < ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y) ConstValue x <= ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y) ConstValue x > ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y) ConstValue x >= ConstValue y = if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y) else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y) -} instance (Num a, IsConst a) => Num (ConstValue a) where ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y) ConstValue x - ConstValue y = ConstValue (FFI.constSub x y) ConstValue x * ConstValue y = ConstValue (FFI.constMul x y) negate (ConstValue x) = ConstValue (FFI.constNeg x) fromInteger x = constOf (fromInteger x :: a) -} llvm-3.2.0.0/examples/0000755000000000000000000000000012142507720012630 5ustar0000000000000000llvm-3.2.0.0/examples/Arith.hs0000644000000000000000000000424512142507720014240 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE ScopedTypeVariables #-} module Arith where import Data.Int import Data.TypeLevel(D4) import LLVM.Core import LLVM.ExecutionEngine import LLVM.Util.Arithmetic import LLVM.Util.Foreign as F import LLVM.Util.File(writeCodeGenModule) import Foreign.Storable {- import Foreign.Ptr import Foreign.Marshal.Utils import Foreign.Marshal.Alloc as F -} mSomeFn :: forall a b . (IsConst a, Floating a, IsFloating a, CallIntrinsic a, FunctionRet a, Cmp a b ) => CodeGenModule (Function (a -> IO a)) mSomeFn = do foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y let foo' = toArithFunction foo createFunction ExternalLinkage $ arithFunction $ \ x -> do y <- set $ x^3 sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y mFib :: CodeGenModule (Function (Int32 -> IO Int32)) mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) type V = Vector D4 Float mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) mVFun = do fn :: Function (V -> IO V) <- createFunction ExternalLinkage $ arithFunction $ \ x -> log x * exp x * x - 16 vectorToPtr fn main :: IO () main = do -- Initialize jitter initializeNativeTarget let mSomeFn' = mSomeFn ioSomeFn <- simpleFunction mSomeFn' let someFn :: Double -> Double someFn = unsafePurify ioSomeFn writeCodeGenModule "Arith.bc" mSomeFn' print (someFn 10) print (someFn 2) writeCodeGenModule "ArithFib.bc" mFib fib <- simpleFunction mFib fib 22 >>= print {- writeCodeGenModule "VArith.bc" mVFun ioVFun <- simpleFunction mVFun let v = toVector (1,2,3,4) r <- vectorPtrWrap ioVFun v print r -} vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) vectorToPtr f = createFunction ExternalLinkage $ \ px py -> do x <- load px y <- call f x store y py ret () vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V vectorPtrWrap f v = with v $ \ aPtr -> F.alloca $ \ bPtr -> do f aPtr bPtr peek bPtr llvm-3.2.0.0/examples/CallConv.hs0000644000000000000000000000142712142507720014671 0ustar0000000000000000module CallConv where import LLVM.Core import LLVM.FFI.Core (CallingConvention(GHC)) import Data.Word (Word32) -- Our module will have these two functions. data Mod = Mod { m1 :: Function (Word32 -> IO Word32), m2 :: Function (Word32 -> Word32 -> IO Word32) } main :: IO () main = do m <- newModule _fns <- defineModule m buildMod --_ <- optimizeModule 3 m writeBitcodeToFile "CallConv.bc" m return () buildMod :: CodeGenModule Mod buildMod = do mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do r <- add x y ret r setFuncCallConv mod2 GHC mod1 <- newNamedFunction ExternalLinkage "test" defineFunction mod1 $ \ arg -> do r <- callWithConv GHC mod2 arg (valueOf 1) ret r return $ Mod mod1 mod2 llvm-3.2.0.0/examples/Vector.hs0000644000000000000000000000506512142507720014434 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} module Vector where import Convert import LLVM.Core import LLVM.ExecutionEngine import LLVM.Util.Optimize (optimizeModule, ) import LLVM.Util.Loop (forLoop, ) import Control.Monad (liftM2, ) import Data.TypeLevel.Num (D16, toNum, ) import Data.Word (Word32, ) -- Type of vector elements. type T = Float -- Number of vector elements. type N = D16 cgvec :: CodeGenModule (Function (T -> IO T)) cgvec = do -- A global variable that vectest messes with. acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T)) -- Return the global variable. retAcc <- createNamedFunction ExternalLinkage "retacc" $ do vacc <- load acc ret vacc let _ = retAcc :: Function (IO T) -- Force the type of retAcc. -- A function that tests vector opreations. f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do let v = value (zero :: ConstValue (Vector N T)) n = toNum (undefined :: N) :: Word32 -- Fill the vector with x, x+1, x+2, ... (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do x1' <- add x1 (1::T) v1' <- insertelement v1 x1 i return (x1', v1') -- Elementwise cubing of the vector. vsq <- mul v1 v1 vcb <- mul vsq v1 -- Sum the elements of the vector. s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do y <- extractelement vcb i s' <- add s (y :: Value T) return s' -- Update the global variable. vacc <- load acc vacc' <- add vacc s store vacc' acc ret (s :: Value T) -- liftIO $ dumpValue f return f main :: IO () main = do -- Initialize jitter initializeNativeTarget -- First run standard code. m <- newModule iovec <- defineModule m cgvec fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec let fvec = convert fptr fvec 10 >>= print vec <- runEngineAccess $ do addModule m; generateFunction iovec vec 10 >>= print -- And then optimize and run. _ <- optimizeModule 1 m funcs <- getModuleValues m print $ map fst funcs let iovec' :: Function (T -> IO T) Just iovec' = castModuleValue =<< lookup "vectest" funcs ioretacc' :: Function (IO T) Just ioretacc' = castModuleValue =<< lookup "retacc" funcs (vec', retacc') <- runEngineAccess $ do addModule m liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') dumpValue iovec' vec' 10 >>= print vec' 0 >>= print retacc' >>= print llvm-3.2.0.0/examples/DotProd.hs0000644000000000000000000000523612142507720014545 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} module DotProd where import Data.Word import Data.TypeLevel.Num(D2, D4, D8, toNum) import LLVM.Core import LLVM.ExecutionEngine import LLVM.Util.Loop import LLVM.Util.File(writeCodeGenModule) import LLVM.Util.Foreign mDotProd :: forall n a . (Pos n, IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a, FunctionRet a ) => CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) mDotProd = createFunction ExternalLinkage $ \ size aPtr bPtr -> do s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do ap <- getElementPtr aPtr (i, ()) -- index into aPtr bp <- getElementPtr bPtr (i, ()) -- index into bPtr a <- load ap -- load element from a vector b <- load bp -- load element from b vector ab <- mul a b -- multiply them add s ab -- accumulate sum r <- forLoop (valueOf (0::Word32)) (valueOf (toNum (undefined :: n))) (valueOf 0) $ \ i r -> do ri <- extractelement s i add r ri ret (r :: Value a) type R = Float type T = Vector D4 R main :: IO () main = do -- Initialize jitter initializeNativeTarget let mDotProd' = mDotProd writeCodeGenModule "DotProd.bc" mDotProd' ioDotProd <- simpleFunction mDotProd' let dotProd :: [T] -> [T] -> R dotProd a b = unsafePurify $ withArrayLen a $ \ aLen aPtr -> withArrayLen b $ \ bLen bPtr -> ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr let a = [1 .. 8] b = [4 .. 11] print $ dotProd (vectorize 0 a) (vectorize 0 b) print $ sum $ zipWith (*) a b class Vectorize n a where vectorize :: a -> [a] -> [Vector n a] {- instance (IsPrimitive a) => Vectorize D1 a where vectorize _ [] = [] vectorize x (x1:xs) = toVector x1 : vectorize x xs -} instance (IsPrimitive a) => Vectorize D2 a where vectorize _ [] = [] vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs vectorize x xs = vectorize x $ xs ++ [x] instance (IsPrimitive a) => Vectorize D4 a where vectorize _ [] = [] vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs vectorize x xs = vectorize x $ xs ++ [x] instance (IsPrimitive a) => Vectorize D8 a where vectorize _ [] = [] vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs vectorize x xs = vectorize x $ xs ++ [x] llvm-3.2.0.0/examples/mainfib.c0000644000000000000000000000031612142507720014401 0ustar0000000000000000#include #include extern unsigned int fib(unsigned int); int main(int argc, char **argv) { int n = argc > 1 ? atoi(argv[1]) : 10; printf("fib %d = %d\n", n, fib(n)); exit(0); } llvm-3.2.0.0/examples/Convert.hs0000644000000000000000000000326512142507720014612 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} module Convert(Convert(..)) where import Data.Int import Data.Word import Foreign.Ptr (FunPtr) type Importer f = FunPtr f -> f class Convert f where convert :: Importer f foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float) instance Convert (IO Float) where convert = c_IOFloat foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float) instance Convert (Float -> IO Float) where convert = c_Float_IOFloat foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float) instance Convert (Float -> Float) where convert = c_Float_Float foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double) instance Convert (IO Double) where convert = c_IODouble foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double) instance Convert (Double -> IO Double) where convert = c_Double_IODouble foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double) instance Convert (Double -> Double) where convert = c_Double_Double foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32) instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32 foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32) instance Convert (Word32 -> Word32) where convert = c_Word32_Word32 foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32) instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32 foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32) instance Convert (Int32 -> Int32) where convert = c_Int32_Int32 llvm-3.2.0.0/examples/BrainF.hs0000644000000000000000000001306512142507720014332 0ustar0000000000000000module BrainF where -- BrainF compiler example -- -- The BrainF language has 8 commands: -- Command Equivalent C Action -- ------- ------------ ------ -- , *h=getchar(); Read a character from stdin, 255 on EOF -- . putchar(*h); Write a character to stdout -- - --*h; Decrement tape -- + ++*h; Increment tape -- < --h; Move head left -- > ++h; Move head right -- [ while(*h) { Start loop -- ] } End loop -- import Control.Monad(when) import Data.Word import Data.Int import System.Environment(getArgs) import System.Exit(exitFailure) import qualified System.IO as IO import LLVM.Core import LLVM.Util.File(writeCodeGenModule) import qualified LLVM.Util.Memory as Memory import LLVM.ExecutionEngine main :: IO () main = do -- Initialize jitter initializeNativeTarget aargs <- getArgs let (args, debug) = case aargs of "-":rargs -> (rargs, True) _ -> (aargs, False) let text = "+++++++++++++++++++++++++++++++++" ++ -- constant 33 ">++++" ++ -- next cell, loop counter, constant 4 "[>++++++++++" ++ -- loop, loop counter, constant 10 "[" ++ -- loop "<<.+>>-" ++ -- back to 33, print, increment, forward, decrement loop counter "]<-" ++ -- back to 4, decrement loop counter "]" ++ "++++++++++." prog <- case args of [] -> return text fileName:[] -> readFile fileName _ -> IO.hPutStrLn IO.stderr "too many arguments" >> exitFailure when debug $ writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536 bfprog <- simpleFunction $ brainCompile debug prog 65536 when (prog == text) $ putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" bfprog brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) brainCompile _debug instrs wmemtotal = do -- LLVM functions memset <- Memory.memset getchar <- newNamedFunction ExternalLinkage "getchar" :: TFunction (IO Int32) putchar <- newNamedFunction ExternalLinkage "putchar" :: TFunction (Int32 -> IO Int32) -- Generate code, first argument is the list of commands, -- second argument is a stack of loop contexts, and the -- third argument is the current register for the head and -- the current basic block. -- A loop context is a triple of the phi node, the loop top label, -- and the loop exit label. let generate [] [] _ = return () generate [] (_:_) _ = error "Missing ]" generate (']':_) [] _ = error "Missing [" generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do -- The loop has terminated, add the phi node at the top, -- branch to the top, and set up the exit label. addPhiInputs cphi [(cur, bb)] br loop defineBasicBlock exit generate is bs (cphi, exit) generate ('[':is) bs curbb = do -- Start a new loop. loop <- newBasicBlock -- loop top body <- newBasicBlock -- body of the loop exit <- newBasicBlock -- loop exit label br loop defineBasicBlock loop cur <- phi [curbb] -- will get one more input from the loop terminator. val <- load cur -- load head byte. eqz <- cmp CmpEQ val (0::Word8) -- test if it is 0. condBr eqz exit body -- and branch accordingly. defineBasicBlock body generate is ((cur, loop, exit) : bs) (cur, body) generate (i:is) bs (curhead, bb) = do -- A simple command, with no new basic blocks. -- Just update which register the head is in. curhead' <- gen curhead i generate is bs (curhead', bb) gen cur ',' = do -- Read a character. char32 <- call getchar char8 <- trunc char32 store char8 cur return cur gen cur '.' = do -- Write a character. char8 <- load cur char32 <- zext char8 _ <- call putchar char32 return cur gen cur '-' = do -- Decrement byte at head. val <- load cur val' <- sub val (1 :: Word8) store val' cur return cur gen cur '+' = do -- Increment byte at head. val <- load cur val' <- add val (1 :: Word8) store val' cur return cur gen cur '<' = -- Decrement head. getElementPtr cur ((-1) :: Word32, ()) gen cur '>' = -- Increment head. getElementPtr cur (1 :: Word32, ()) gen _ c = error $ "Bad character in program: " ++ show c brainf <- createFunction ExternalLinkage $ do ptr_arr <- arrayMalloc wmemtotal _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False) -- _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ()) -- Start head in the middle. curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ()) bb <- getCurrentBasicBlock generate instrs [] (curhead, bb) free ptr_arr ret () return brainf llvm-3.2.0.0/examples/Align.hs0000644000000000000000000000114612142507720014220 0ustar0000000000000000module Align (main) where import Data.TypeLevel(D1, D4) import Data.Word import LLVM.Core import LLVM.ExecutionEngine main :: IO () main = do -- Initialize jitter initializeNativeTarget td <- getTargetData print (littleEndian td, aBIAlignmentOfType td $ typeRef (undefined :: Word32), aBIAlignmentOfType td $ typeRef (undefined :: Word64), aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float), aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double), storeSizeOfType td $ typeRef (undefined :: Vector D4 Float), intPtrType td ) llvm-3.2.0.0/examples/Struct.hs0000644000000000000000000000227712142507720014460 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, TypeOperators, ScopedTypeVariables #-} module Struct (main) where import Data.Word import Data.TypeLevel(d0, d1, d2, D10) import LLVM.Core import LLVM.Util.File import LLVM.ExecutionEngine foreign import ccall structCheck :: Word32 -> Ptr S -> Int -- Watch out for double! Alignment differs between platforms. -- struct S { uint32 x0; float x1; uint32 x2[10] }; type S = Struct (Word32 :& Float :& Array D10 Word32 :& ()) -- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s; mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S))) mStruct = do createFunction ExternalLinkage $ \ x -> do p :: Value (Ptr S) <- malloc p0 <- getElementPtr0 p (d0 & ()) store x (p0 :: Value (Ptr Word32)) p1 <- getElementPtr0 p (d1 & ()) store (valueOf 1.5) p1 x' <- add x (1 :: Word32) p2 <- getElementPtr0 p (d2 & (5::Word32) & ()) store x' p2 ret p main :: IO () main = do initializeNativeTarget writeCodeGenModule "Struct.bc" mStruct struct <- simpleFunction mStruct let a = 10 p <- struct a putStrLn $ if structCheck a p /= 0 then "OK" else "failed" return () llvm-3.2.0.0/examples/structCheck.c0000644000000000000000000000026112142507720015255 0ustar0000000000000000#include struct S { uint32_t x0; float x1; uint32_t x2[10]; }; int structCheck(uint32_t a, struct S *s) { return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1; } llvm-3.2.0.0/examples/Varargs.hs0000644000000000000000000000212412142507720014570 0ustar0000000000000000module Varargs (main) where import Data.Word import LLVM.Core import LLVM.ExecutionEngine bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) bldVarargs = withStringNul "Hello\n" (\fmt1 -> withStringNul "A number %d\n" (\fmt2 -> withStringNul "Two numbers %d %d\n" (\fmt3 -> do printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) func <- createFunction ExternalLinkage $ \ x -> do tmp1 <- getElementPtr0 fmt1 (0::Word32, ()) let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32) _ <- call p1 tmp1 tmp2 <- getElementPtr0 fmt2 (0::Word32, ()) let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32) _ <- call p2 tmp2 x tmp3 <- getElementPtr0 fmt3 (0::Word32, ()) let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32) _ <- call p3 tmp3 x x ret () return func ))) main :: IO () main = do initializeNativeTarget varargs <- simpleFunction bldVarargs varargs 42 return () llvm-3.2.0.0/examples/List.hs0000644000000000000000000000557312142507720014111 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} module List(main) where import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.ExecutionEngine (simpleFunction, ) import LLVM.Core hiding ( sizeOf ) import qualified System.IO as IO import Data.Word (Word32, ) import Data.Int (Int32, ) import Foreign.Storable (Storable, sizeOf, ) import Foreign.Marshal.Array (allocaArray, ) import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) import Foreign.Ptr (FunPtr, ) import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) {- I had to export Phi's methods in llvm-0.6.8 in order to be able to implement this function. -} arrayLoop :: (Phi a, IsType b, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) => Value i -> Value (Ptr b) -> a -> (Value (Ptr b) -> a -> CodeGenFunction r a) -> CodeGenFunction r a arrayLoop len ptr start loopBody = do top <- getCurrentBasicBlock loop <- newBasicBlock body <- newBasicBlock exit <- newBasicBlock br loop defineBasicBlock loop i <- phi [(len, top)] p <- phi [(ptr, top)] vars <- phis top start t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) condBr t body exit defineBasicBlock body vars' <- loopBody p vars i' <- sub i (valueOf 1 `asTypeOf` len) p' <- getElementPtr p (valueOf 1 :: Value Word32, ()) body' <- getCurrentBasicBlock addPhis body' vars vars' addPhiInputs i [(i', body')] addPhiInputs p [(p', body')] br loop defineBasicBlock exit return vars mList :: CodeGenModule (Function (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) mList = createFunction ExternalLinkage $ \ ref size ptr -> do next <- staticFunction nelem let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32) s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do flip store ptri =<< call next ref return y ret (s :: Value Int32) renderList :: IO () renderList = do m <- newModule _f <- defineModule m mList writeBitcodeToFile "List.bc" m fill <- simpleFunction mList stable <- newStablePtr =<< newIORef [3,5..] IO.withFile "listcontent.u32" IO.WriteMode $ \h -> let len = 100 in allocaArray len $ \ ptr -> fill stable (fromIntegral len) ptr >> IO.hPutBuf h ptr (len*sizeOf(undefined::Int32)) freeStablePtr stable foreign import ccall "&nextListElement" nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) foreign export ccall nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 nextListElement stable = do ioRef <- deRefStablePtr stable xt <- readIORef ioRef case xt of [] -> return 0 (x:xs) -> writeIORef ioRef xs >> return x main :: IO () main = do -- Initialize jitter initializeNativeTarget renderList llvm-3.2.0.0/examples/Array.hs0000644000000000000000000000401112142507720014236 0ustar0000000000000000module Array where import Data.Word import LLVM.Core --import LLVM.ExecutionEngine import LLVM.Util.Loop import LLVM.Util.Optimize cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) cg = do dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do ai <- mul aStride i bi <- mul bStride i ap <- getElementPtr aPtr (ai, ()) bp <- getElementPtr bPtr (bi, ()) a <- load ap b <- load bp ab <- mul a b add (s :: Value Double) ab ret r let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) -- multiply a:[n x m], b:[m x l] matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do forLoop (valueOf 0) n () $ \ ni () -> do forLoop (valueOf 0) l () $ \ li () -> do ni' <- mul ni m row <- getElementPtr aPtr (ni', ()) col <- getElementPtr bPtr (li, ()) x <- call dotProd m row (valueOf 1) col m j <- add ni' li p <- getElementPtr cPtr (j, ()) store x p return () ret () let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) let fillArray _ [] = return () fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs test <- createNamedFunction ExternalLinkage "test" $ \ x -> do a <- arrayMalloc (4 :: Word32) fillArray a $ map valueOf [1,2,3,4] b <- arrayMalloc (4 :: Word32) fillArray b [x,x,x,x] c <- arrayMalloc (4 :: Word32) _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c ret c let _ = test :: Function (Double -> IO (Ptr Double)) return test main :: IO () main = do -- Initialize jitter initializeNativeTarget m <- newModule _f <- defineModule m cg writeBitcodeToFile "Arr.bc" m _ <- optimizeModule 3 m writeBitcodeToFile "Arr-opt.bc" m llvm-3.2.0.0/examples/Fibonacci.hs0000644000000000000000000000570012142507720015043 0ustar0000000000000000module Fibonacci where import Prelude hiding(and, or) import System.Environment(getArgs) import Control.Monad(forM_) import Data.Word import LLVM.Core import LLVM.Util.Optimize import LLVM.ExecutionEngine -- Our module will have these two functions. data Mod = Mod { mfib :: Function (Word32 -> IO Word32), mplus :: Function (Word32 -> Word32 -> IO Word32) } main :: IO () main = do args <- getArgs let args' = if null args then ["10"] else args -- Initialize jitter initializeNativeTarget -- Create a module, m <- newNamedModule "fib" -- and define its contents. fns <- defineModule m buildMod -- Show the code for the two functions, just for fun. --dumpValue $ mfib fns --dumpValue $ mplus fns -- Write the code to a file for later perusal. -- Can be disassembled with llvm-dis. writeBitcodeToFile "Fibonacci.bc" m _ <- optimizeModule 3 m writeBitcodeToFile "Fibonacci-opt.bc" m -- Generate code for mfib, and then throw away the IO in the type. -- The result is an ordinary Haskell function. iofib <- runEngineAccess $ do addModule m generateFunction $ mfib fns let fib = unsafePurify iofib -- Run fib for the arguments. forM_ args' $ \num -> do putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) return () buildMod :: CodeGenModule Mod buildMod = do -- Add two numbers in a cumbersome way. plus <- createFunction InternalLinkage $ \ x y -> do -- Create three additional basic blocks, need to be created before being referred to. l1 <- newBasicBlock l2 <- newBasicBlock l3 <- newBasicBlock -- Test if x is even/odd. a <- and x (1 :: Word32) c <- cmp CmpEQ a (0 :: Word32) condBr c l1 l2 -- Do x+y if even. defineBasicBlock l1 r1 <- add x y br l3 -- Do y+x if odd. defineBasicBlock l2 r2 <- add y x br l3 defineBasicBlock l3 -- Join the two execution paths with a phi instruction. r <- phi [(r1, l1), (r2, l2)] ret r -- The usual doubly recursive Fibonacci. -- Use new&define so the name fib is defined in the body for recursive calls. fib <- newNamedFunction ExternalLinkage "fib" defineFunction fib $ \ arg -> do -- Create the two basic blocks. recurse <- newBasicBlock exit <- newBasicBlock -- Test if arg > 2 test <- cmp CmpGT arg (2::Word32) condBr test recurse exit -- Just return 1 if not > 2 defineBasicBlock exit ret (1::Word32) -- Recurse if > 2, using the cumbersome plus to add the results. defineBasicBlock recurse x1 <- sub arg (1::Word32) fibx1 <- call fib x1 x2 <- sub arg (2::Word32) fibx2 <- call fib x2 r <- call plus fibx1 fibx2 ret r -- Return the two functions. return $ Mod fib plus llvm-3.2.0.0/examples/HelloJIT.hs0000644000000000000000000000112612142507720014576 0ustar0000000000000000module HelloJIT (main) where import Data.Word import LLVM.Core import LLVM.ExecutionEngine bldGreet :: CodeGenModule (Function (IO ())) bldGreet = withStringNul "Hello, JIT!" (\greetz -> do puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) func <- createFunction ExternalLinkage $ do tmp <- getElementPtr0 greetz (0::Word32, ()) _ <- call puts tmp -- Throw away return value. ret () return func) main :: IO () main = do initializeNativeTarget greet <- simpleFunction bldGreet greet greet greet return ()