├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── Example1.hs ├── Example2.hs ├── Example3.hs ├── LICENSE ├── README.md ├── Setup.hs ├── llvm-hs-typed.cabal ├── src └── LLVM │ └── AST │ ├── Tagged.hs │ ├── Tagged │ ├── AddrSpace.hs │ ├── Attribute.hs │ ├── COMDAT.hs │ ├── CallingConvention.hs │ ├── Constant.hs │ ├── DLL.hs │ ├── DataLayout.hs │ ├── Float.hs │ ├── FloatingPointPredicate.hs │ ├── FunctionAttribute.hs │ ├── Global.hs │ ├── IRBuilder.hs │ ├── InlineAssembly.hs │ ├── Instruction.hs │ ├── IntegerPredicate.hs │ ├── Linkage.hs │ ├── Name.hs │ ├── Operand.hs │ ├── ParameterAttribute.hs │ ├── RMWOperation.hs │ ├── Tag.hs │ ├── ThreadLocalStorage.hs │ ├── Type.hs │ └── Visibility.hs │ └── TypeLevel │ ├── Type.hs │ └── Utils.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | .shake.database 4 | out 5 | .DS_Store 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | .stack-work 9 | /dist-newstyle/ 10 | *~ 11 | cabal.project.local 12 | *.dwo 13 | *.sw[ponm] 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | dist: trusty 3 | language: generic 4 | 5 | env: 6 | global: 7 | - GCC=gcc-5 8 | - GXX=g++-5 9 | 10 | cache: 11 | directories: 12 | - $HOME/.stack/ 13 | 14 | addons: 15 | apt: 16 | packages: 17 | - gcc-5 18 | - g++-5 19 | - libgmp-dev 20 | - llvm-6.0-dev 21 | sources: 22 | - llvm-toolchain-trusty-6.0 23 | - ubuntu-toolchain-r-test 24 | 25 | before_install: 26 | - mkdir -p ~/.local/bin 27 | - export PATH=~/.local/bin:$PATH 28 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 29 | - export CC=/usr/bin/$GCC 30 | - export CXX=/usr/bin/$GXX 31 | 32 | install: 33 | - stack update 34 | - stack --no-terminal --install-ghc test --only-dependencies 35 | 36 | script: 37 | - stack --no-terminal test 38 | 39 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for llvm-hs-typed 2 | 3 | ## 4.0.0.0 -- not yet released 4 | 5 | * First version. 6 | -------------------------------------------------------------------------------- /Example1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE ExplicitForAll #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE AllowAmbiguousTypes #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | 14 | module Example where 15 | 16 | -- AST 17 | import GHC.TypeLits 18 | import LLVM.Prelude 19 | import LLVM.AST.Tagged 20 | import LLVM.AST.Constant 21 | import LLVM.AST.Tagged.Global 22 | import LLVM.AST.Tagged.Constant 23 | import LLVM.AST.Tagged.Tag 24 | import LLVM.AST.TypeLevel.Type 25 | 26 | import qualified LLVM.AST as AST 27 | import qualified LLVM.AST.Global as AST 28 | 29 | c0 :: Constant ::: IntegerType' 32 30 | c0 = int 42 31 | 32 | named :: forall (t :: Type'). ShortByteString -> Name ::: t 33 | named s = assertLLVMType $ AST.Name s 34 | 35 | type ArgTys = [(IntegerType' 32), (IntegerType' 32)] 36 | type RetTy = IntegerType' 32 37 | 38 | defAdd :: Global 39 | defAdd = function nm (params, False) [body, body] 40 | where 41 | nm :: Name ::: (PointerType' (FunctionType' (IntegerType' 32) ArgTys) ('AddrSpace' 0)) 42 | nm = named "add" 43 | 44 | {-p1 :: Parameter ::: (IntegerType' 32)-} 45 | p1 = parameter (named "a") [] 46 | 47 | {-p2 :: Parameter ::: (IntegerType' 32)-} 48 | p2 = parameter (named "b") [] 49 | 50 | {-body :: BasicBlock ::: IntegerType' 32-} 51 | body = basicBlock "entry" [] (ret (constantOperand c0) []) 52 | 53 | {-params :: Parameter :::* ArgTys-} 54 | params = p1 :* p2 :* tnil 55 | 56 | module_ :: AST.Module 57 | module_ = defaultModule 58 | { moduleName = "basic" 59 | , moduleDefinitions = [GlobalDefinition defAdd] 60 | } 61 | -------------------------------------------------------------------------------- /Example2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE RecursiveDo #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Example2 where 10 | 11 | import GHC.TypeLits 12 | import LLVM.Prelude 13 | import LLVM.AST.Constant 14 | import LLVM.AST.Tagged.Global 15 | import LLVM.AST.Tagged.Tag 16 | import LLVM.AST.TypeLevel.Type 17 | import qualified LLVM.AST as AST 18 | import qualified LLVM.AST.Type as AST 19 | import qualified LLVM.AST.Global as AST 20 | import qualified LLVM.AST.Tagged as AST 21 | 22 | import LLVM.AST.Tagged.IRBuilder as TBuilder 23 | import qualified LLVM.IRBuilder as Builder 24 | 25 | import Data.HVect 26 | 27 | simple :: AST.Module 28 | simple = Builder.buildModule "exampleModule" $ do 29 | func 30 | where 31 | func :: Builder.ModuleBuilder (AST.Operand ::: IntegerType' 32) 32 | func = 33 | TBuilder.function @(IntegerType' 32) @'[ '(IntegerType' 32, 'ParameterName' "a"), '(IntegerType' 32, 'ParameterName' "b")] "add" $ \(a :&: b :&: HNil) -> do 34 | entry <- block `named` "entry"; do 35 | c <- add a b 36 | ret c 37 | -------------------------------------------------------------------------------- /Example3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Main where 10 | 11 | import GHC.TypeLits 12 | import LLVM.Prelude 13 | import LLVM.AST.Tagged.Operand 14 | import qualified LLVM.AST.Tagged.Constant as TC 15 | import LLVM.AST.Tagged.Global 16 | import LLVM.AST.Tagged.Tag 17 | import LLVM.AST.TypeLevel.Type 18 | import qualified LLVM.AST as AST 19 | import qualified LLVM.AST.Type as AST 20 | import qualified LLVM.AST.Float as F 21 | import qualified LLVM.AST.Constant as C 22 | import qualified LLVM.AST.IntegerPredicate as P 23 | 24 | import LLVM.AST.Tagged.IRBuilder as TBuilder 25 | import qualified LLVM.IRBuilder as Builder 26 | 27 | import Data.HVect 28 | 29 | simple :: AST.Module 30 | simple = Builder.buildModule "exampleModule" $ mdo 31 | TBuilder.function @(IntegerType' 32) @'[ '(IntegerType' 32, 'ParameterName' "a")] "f" $ \(a :&: HNil) -> mdo 32 | entry <- block `named` "entry" 33 | cond <- icmp P.EQ a (constantOperand (TC.int 0)) 34 | condBr cond ifThen ifElse 35 | ifThen <- block 36 | trVal <- add a (constantOperand (TC.int 0)) 37 | br ifExit 38 | ifElse <- block `named` "if.else" 39 | flVal <- add a (constantOperand (TC.int 0)) 40 | br ifExit 41 | ifExit <- block `named` "if.exit" 42 | r <- phi [(trVal, ifThen), (flVal, ifElse)] 43 | ret r 44 | 45 | main :: IO () 46 | main = print simple 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Joachim Breitner 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Joachim Breitner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | llvm-hs-typed 2 | ============= 3 | 4 | [![Build Status](https://travis-ci.org/llvm-hs/llvm-hs-typed.svg?branch=master)](https://travis-ci.org/llvm-hs/llvm-hs-typed) 5 | 6 | An experimental branch of 7 | [llvm-hs-pure](https://hackage.haskell.org/package/llvm-hs-pure) AST that 8 | enforces the semantics of correct AST construction using the Haskell type system 9 | to prevent malformed ASTs. 10 | 11 | Usage 12 | ----- 13 | 14 | ### Typed AST 15 | 16 | ```haskell 17 | {-# LANGUAGE DataKinds #-} 18 | {-# LANGUAGE PolyKinds #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE TypeOperators #-} 21 | {-# LANGUAGE ExplicitForAll #-} 22 | {-# LANGUAGE TypeApplications #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE OverloadedStrings #-} 25 | {-# LANGUAGE ScopedTypeVariables #-} 26 | {-# LANGUAGE AllowAmbiguousTypes #-} 27 | {-# LANGUAGE UndecidableInstances #-} 28 | {-# LANGUAGE MultiParamTypeClasses #-} 29 | 30 | module Example where 31 | 32 | -- AST 33 | import GHC.TypeLits 34 | import LLVM.Prelude 35 | import LLVM.AST.Tagged 36 | import LLVM.AST.Constant 37 | import LLVM.AST.Tagged.Global 38 | import LLVM.AST.Tagged.Constant 39 | import LLVM.AST.Tagged.Tag 40 | import LLVM.AST.TypeLevel.Type 41 | 42 | import qualified LLVM.AST as AST 43 | import qualified LLVM.AST.Global as AST 44 | 45 | c0 :: Constant ::: IntegerType' 32 46 | c0 = int 42 47 | 48 | named :: forall (t :: Type'). ShortByteString -> Name ::: t 49 | named s = assertLLVMType $ AST.Name s 50 | 51 | type ArgTys = [(IntegerType' 32), (IntegerType' 32)] 52 | type RetTy = IntegerType' 32 53 | 54 | defAdd :: Global 55 | defAdd = function nm (params, False) [body, body] 56 | where 57 | nm :: Name ::: (PointerType' (FunctionType' (IntegerType' 32) ArgTys) ('AddrSpace' 0)) 58 | nm = named "add" 59 | 60 | -- Types of subexpression are inferred from toplevel LLVM function signature 61 | 62 | {-p1 :: Parameter ::: (IntegerType' 32)-} 63 | p1 = parameter (named "a") [] 64 | 65 | {-p2 :: Parameter ::: (IntegerType' 32)-} 66 | p2 = parameter (named "b") [] 67 | 68 | {-body :: BasicBlock ::: IntegerType' 32-} 69 | body = basicBlock "entry" [] (ret (constantOperand c0) []) 70 | 71 | {-params :: Parameter :::* ArgTys-} 72 | params = p1 :* p2 :* tnil 73 | 74 | module_ :: AST.Module 75 | module_ = defaultModule 76 | { moduleName = "basic" 77 | , moduleDefinitions = [GlobalDefinition defAdd] 78 | } 79 | ``` 80 | 81 | ### Typed IRBuilder 82 | 83 | ```haskell 84 | {-# LANGUAGE DataKinds #-} 85 | {-# LANGUAGE PolyKinds #-} 86 | {-# LANGUAGE RecursiveDo #-} 87 | {-# LANGUAGE TypeOperators #-} 88 | {-# LANGUAGE OverloadedStrings #-} 89 | 90 | module Example2 where 91 | 92 | import GHC.TypeLits 93 | import LLVM.Prelude 94 | import LLVM.AST.Constant 95 | import LLVM.AST.Tagged.Global 96 | import LLVM.AST.Tagged.Tag 97 | import LLVM.AST.TypeLevel.Type 98 | import qualified LLVM.AST as AST 99 | import qualified LLVM.AST.Type as AST 100 | import qualified LLVM.AST.Global as AST 101 | import qualified LLVM.AST.Tagged as AST 102 | 103 | import LLVM.AST.Tagged.IRBuilder as TBuilder 104 | import qualified LLVM.IRBuilder as Builder 105 | 106 | import Data.Coerce 107 | 108 | simple :: AST.Module 109 | simple = Builder.buildModule "exampleModule" $ do 110 | func 111 | where 112 | func :: Builder.ModuleBuilder (AST.Operand ::: IntegerType' 32) 113 | func = 114 | TBuilder.function "add" [(AST.i32, "a"), (AST.i32, "b")] $ \[a, b] -> do 115 | entry <- block `named` "entry"; do 116 | c <- add (coerce a) (coerce b) 117 | ret c 118 | ``` 119 | 120 | License 121 | ------- 122 | 123 | Copyright (c) 2017, Joachim Breitner 124 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /llvm-hs-typed.cabal: -------------------------------------------------------------------------------- 1 | -- Initial llvm-hs-typed.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: llvm-hs-typed 5 | version: 5.0.0.0 6 | synopsis: LLVM AST with type-level tracking of LLVM types 7 | description: 8 | llvm-hs-typed provides a type-safe way of producin LLVM IR 9 | (). Type-safety here means that phantom 10 | types and type level computation are used to track the LLVM types of names, 11 | operations, instructions. 12 | 13 | The module structure mirrors that of llvm-hs-pure. 14 | homepage: https://github.com/llvm-hs/llvm-hs-typed 15 | license: BSD3 16 | license-file: LICENSE 17 | author: Joachim Breitner 18 | maintainer: mail@joachim-breitner.de 19 | copyright: 2017 Joachim Breitner 20 | category: Compilers/Interpreters, Code Generation 21 | build-type: Simple 22 | extra-source-files: ChangeLog.md 23 | cabal-version: >=1.10 24 | tested-with: GHC == 8.0.2 25 | 26 | library 27 | exposed-modules: 28 | LLVM.AST.TypeLevel.Type 29 | LLVM.AST.TypeLevel.Utils 30 | LLVM.AST.Tagged 31 | LLVM.AST.Tagged.Tag 32 | LLVM.AST.Tagged.Instruction 33 | LLVM.AST.Tagged.Name 34 | LLVM.AST.Tagged.Visibility 35 | LLVM.AST.Tagged.Operand 36 | LLVM.AST.Tagged.Attribute 37 | LLVM.AST.Tagged.Global 38 | LLVM.AST.Tagged.Constant 39 | LLVM.AST.Tagged.Float 40 | LLVM.AST.Tagged.COMDAT 41 | LLVM.AST.Tagged.InlineAssembly 42 | LLVM.AST.Tagged.Type 43 | LLVM.AST.Tagged.CallingConvention 44 | LLVM.AST.Tagged.ThreadLocalStorage 45 | LLVM.AST.Tagged.ParameterAttribute 46 | LLVM.AST.Tagged.Linkage 47 | LLVM.AST.Tagged.FloatingPointPredicate 48 | LLVM.AST.Tagged.FunctionAttribute 49 | LLVM.AST.Tagged.AddrSpace 50 | LLVM.AST.Tagged.DLL 51 | LLVM.AST.Tagged.IntegerPredicate 52 | LLVM.AST.Tagged.DataLayout 53 | LLVM.AST.Tagged.RMWOperation 54 | LLVM.AST.Tagged.IRBuilder 55 | build-depends: 56 | base >= 4.7 && <5, 57 | llvm-hs-pure == 5.1.*, 58 | llvm-hs-pretty >= 0.2, 59 | bytestring >= 0.10 && < 0.11, 60 | encode-string == 0.1.*, 61 | hvect == 0.4.* 62 | hs-source-dirs: src 63 | default-language: Haskell2010 64 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | This module provides a type-safe variant of "LLVM.AST". 4 | 5 | The tagged variant of the type-safe API of "LLVM.AST" mirrors the untyped 6 | API using the following principle: 7 | 8 | For every constructor @Con@ in the untyped API in module @LLVM.AST.Foo@ 9 | there is a type-safe smart constructor @con@ in the corresponding module in 10 | @LLVM.AST.Tagged.Foo@. All value level arguments of type 'Type' disappear 11 | (and turn into 'Known' constraints). The other arguments, where it makes sense, 12 | get tagged with their LLVM type, on the Haskell type level. Finally, the 13 | types of different arguments (multiple operators) are connected to ensure 14 | type safety. This connection is sometimes done by simply using the same type variable 15 | to ensure that two types are the same, sometimes using more complex 16 | type-level machinery. 17 | 18 | Example 1: 19 | 20 | The constructor 21 | 22 | FAdd :: Constant -> Constant -> Constant 23 | 24 | turns into 25 | 26 | fadd = forall fpt. 27 | Constant ::: (FloatingPointType' fpt) -> 28 | Constant ::: (FloatingPointType' fpt) -> 29 | Constant ::: (FloatingPointType' fpt) 30 | 31 | Which ensures that the arguments and the return value are all of floating point 32 | type, and furthermore that all of them use the same floating point format. 33 | 34 | Example 2: 35 | 36 | The constructor 37 | 38 | FPExt :: Constant -> Type -> Constant 39 | 40 | turns into 41 | 42 | fpext :: forall fpt1 fpt2. Known fpt2 => 43 | (Known fpt2, BitSizeOfFP fpt1 <= BitSizeOfFP fpt2) => 44 | Constant ::: FloatingPointType' fpt1 -> 45 | Constant ::: FloatingPointType' fpt2 46 | 47 | which ensures that the argument and the return value are both floating point 48 | values, and further more that the argument has a smaller bit size than the 49 | result. This uses the type-level function @BitSizeOfFP :: FloatingPointType -> 50 | Nat@ that returns the bit width of a givne @FloatingPointType@. 51 | -} 52 | module LLVM.AST.Tagged ( 53 | Module(..), defaultModule, 54 | Definition(..), 55 | Global(GlobalVariable, GlobalAlias, Function), 56 | globalVariableDefaults, 57 | globalAliasDefaults, 58 | functionDefaults, 59 | UnnamedAddr(..), 60 | Parameter(..), 61 | BasicBlock(..), 62 | module LLVM.AST.Tagged.Instruction, 63 | module LLVM.AST.Tagged.Name, 64 | module LLVM.AST.Tagged.Operand, 65 | module LLVM.AST.Tagged.Type 66 | ) where 67 | 68 | import LLVM.AST 69 | 70 | import LLVM.AST.Tagged.Name 71 | import LLVM.AST.Tagged.Type (Type(..), FloatingPointType(..)) 72 | import LLVM.AST.Tagged.Global 73 | import LLVM.AST.Tagged.Operand 74 | import LLVM.AST.Tagged.Instruction 75 | import LLVM.AST.Tagged.DataLayout 76 | 77 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/AddrSpace.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.AddrSpace". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.AddrSpace (module LLVM.AST.AddrSpace) where 4 | 5 | import LLVM.AST.AddrSpace 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Attribute.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.Attribute". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.Attribute (module LLVM.AST.Attribute) where 4 | 5 | import LLVM.AST.Attribute 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/COMDAT.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.COMDAT". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.COMDAT (module LLVM.AST.COMDAT) where 4 | 5 | import LLVM.AST.COMDAT 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/CallingConvention.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.CallingConvention". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.CallingConvention (module LLVM.AST.CallingConvention) where 4 | 5 | import LLVM.AST.CallingConvention 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Constant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeFamilyDependencies #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE AllowAmbiguousTypes #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | This module provides a type-safe variant of "LLVM.AST.Constant". 17 | module LLVM.AST.Tagged.Constant where 18 | 19 | import Data.Word 20 | import GHC.TypeLits 21 | import GHC.Exts (Constraint) 22 | 23 | import LLVM.AST.TypeLevel.Type 24 | import LLVM.AST.Type 25 | import LLVM.AST.TypeLevel.Utils 26 | import LLVM.AST.Tagged.Tag 27 | import LLVM.AST.Constant 28 | import LLVM.AST.Name (Name) 29 | import LLVM.AST.Float (SomeFloat) 30 | import LLVM.AST.IntegerPredicate (IntegerPredicate) 31 | import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) 32 | 33 | import Data.Coerce 34 | 35 | type family NotNull (xs :: [a]) :: Constraint where 36 | NotNull '[] = TypeError (Text "The list must not be empty") 37 | NotNull _ = () 38 | 39 | type family ValueAt (t :: Type') (as :: [nat]) :: Type' where 40 | ValueAt t '[] = t 41 | ValueAt (StructureType' _ ts) (n : as) = ValueAt (Nth ts n) as 42 | ValueAt (ArrayType' _ t2) (_ : as) = ValueAt t2 as 43 | ValueAt t _ = TypeError (Text "Cannot index into non-aggregate type " :$$: ShowType t) 44 | 45 | -- A list of arguments to @getElementPtr@ which, on the type level, 46 | -- tracks which arguments are statically known. 47 | data GEP_Args (static_args :: [Maybe Nat]) where 48 | None :: GEP_Args '[] 49 | -- | Statically known index. Only this is allowed to index into a structure 50 | AKnown :: forall n xs. KnownNat n => 51 | GEP_Args xs -> 52 | GEP_Args (Just n : xs) 53 | -- | Dynamically known index. 54 | AUnknown :: forall width xs. 55 | Constant ::: IntegerType' width -> 56 | GEP_Args xs -> 57 | GEP_Args (Nothing : xs) 58 | 59 | -- | This type family calculates the return type of a 'getElementPtr' instruction. 60 | type family GEP_Res (t :: Type') (as :: [Maybe nat]) :: Type' where 61 | GEP_Res t '[] = t 62 | GEP_Res (StructureType' _ ts) (Just n : as) = GEP_Res (Nth ts n) as 63 | GEP_Res (PointerType' t2 _) (_ : as) = GEP_Res t2 as 64 | GEP_Res (ArrayType' _ t2) (_ : as) = GEP_Res t2 as 65 | 66 | 67 | getGEPArgs :: forall static_args. GEP_Args static_args -> [Constant] 68 | getGEPArgs None = [] 69 | getGEPArgs (AKnown as) = 70 | let i :: forall n xs . (Just n : xs) ~ static_args => Integer 71 | -- this extracts the n from the static args 72 | i = val @_ @n 73 | in Int (word32Val @32) i : getGEPArgs as 74 | getGEPArgs (AUnknown v as) = unTyped v : getGEPArgs as 75 | 76 | getElementPtr :: forall t as static_args t2. 77 | Bool -> 78 | Constant ::: PointerType' t as -> 79 | GEP_Args static_args -> 80 | Constant ::: GEP_Res (PointerType' t as) static_args 81 | getElementPtr in_bounds address indices 82 | = assertLLVMType $ GetElementPtr in_bounds (unTyped address) (getGEPArgs indices) 83 | 84 | 85 | int :: forall width. Known width => Integer -> Constant ::: IntegerType' width 86 | int value = assertLLVMType $ Int (word32Val @width) value 87 | 88 | float :: forall fpt. SomeFloat :::: fpt -> Constant ::: FloatingPointType' fpt 89 | float = coerce Float 90 | 91 | null :: forall as t. Known t => Constant ::: PointerType' t as 92 | null = coerce Null (val @_ @t) 93 | 94 | struct :: forall b ts. Known b => 95 | Maybe Name -> Constant :::* ts -> Constant ::: (StructureType' b ts) 96 | struct mbName xs = coerce Struct mbName (val @_ @b) xs 97 | 98 | array :: forall n t. Known t => 99 | n × (Constant ::: t) -> Constant ::: (ArrayType' n t) 100 | array vals = coerce Array (val @_ @t) (unCounted vals) 101 | 102 | vector :: forall n t. Known t => 103 | n × (Constant ::: t) -> Constant ::: (VectorType' n t) 104 | vector vals = coerce Vector (unCounted vals) 105 | 106 | undef :: forall t. Known t => Constant ::: t 107 | undef = coerce Undef (val @_ @t) 108 | 109 | -- TODO: Does it make sense to include BlockAddress here? 110 | 111 | globalReference :: forall t. Known t => Name ::: t -> Constant ::: t 112 | globalReference name = coerce GlobalReference (val @_ @t) name 113 | 114 | tokenNone :: Constant ::: TokenType' 115 | tokenNone = coerce TokenNone 116 | 117 | add :: forall width. 118 | Bool -> Bool -> 119 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 120 | Constant ::: IntegerType' width 121 | add = coerce Add 122 | 123 | fadd :: forall fpt. 124 | Constant ::: (FloatingPointType' fpt) -> Constant ::: (FloatingPointType' fpt) -> 125 | Constant ::: (FloatingPointType' fpt) 126 | fadd = coerce FAdd 127 | 128 | sub :: forall width. 129 | Bool -> Bool -> 130 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 131 | Constant ::: IntegerType' width 132 | sub = coerce Sub 133 | 134 | fsub :: forall fpt. 135 | Constant ::: (FloatingPointType' fpt) -> Constant ::: (FloatingPointType' fpt) -> 136 | Constant ::: (FloatingPointType' fpt) 137 | fsub = coerce FSub 138 | 139 | mul :: forall width. 140 | Bool -> Bool -> 141 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 142 | Constant ::: IntegerType' width 143 | mul = coerce Mul 144 | 145 | fmul :: forall fpt. 146 | Constant ::: (FloatingPointType' fpt) -> Constant ::: (FloatingPointType' fpt) -> 147 | Constant ::: (FloatingPointType' fpt) 148 | fmul = coerce FMul 149 | 150 | udiv :: forall width. 151 | Bool -> 152 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 153 | Constant ::: IntegerType' width 154 | udiv = coerce UDiv 155 | 156 | sdiv :: forall width. 157 | Bool -> 158 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 159 | Constant ::: IntegerType' width 160 | sdiv = coerce SDiv 161 | 162 | fdiv :: forall fpt. 163 | Constant ::: (FloatingPointType' fpt) -> Constant ::: (FloatingPointType' fpt) -> 164 | Constant ::: (FloatingPointType' fpt) 165 | fdiv = coerce FDiv 166 | 167 | urem :: forall width. 168 | Bool -> 169 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 170 | Constant ::: IntegerType' width 171 | urem = coerce UDiv 172 | 173 | srem :: forall width. 174 | Bool -> 175 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 176 | Constant ::: IntegerType' width 177 | srem = coerce SDiv 178 | 179 | frem :: forall fpt. 180 | Constant ::: (FloatingPointType' fpt) -> Constant ::: (FloatingPointType' fpt) -> 181 | Constant ::: (FloatingPointType' fpt) 182 | frem = coerce FDiv 183 | 184 | shl :: forall width. 185 | Bool -> Bool -> 186 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 187 | Constant ::: IntegerType' width 188 | shl = coerce Shl 189 | 190 | lshr :: forall width. 191 | Bool -> 192 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 193 | Constant ::: IntegerType' width 194 | lshr = coerce LShr 195 | 196 | ashr :: forall width. 197 | Bool -> 198 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 199 | Constant ::: IntegerType' width 200 | ashr = coerce AShr 201 | 202 | and :: forall width. 203 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 204 | Constant ::: IntegerType' width 205 | and = coerce And 206 | 207 | or :: forall width. 208 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 209 | Constant ::: IntegerType' width 210 | or = coerce Or 211 | 212 | xor :: forall width. 213 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 214 | Constant ::: IntegerType' width 215 | xor = coerce Xor 216 | 217 | trunc :: forall width1 width2. (Known width2, width2 <= width1) => 218 | Constant ::: IntegerType' width1 -> Constant ::: IntegerType' width2 219 | trunc o1 = coerce Trunc o1 (val @_ @(IntegerType' width2)) 220 | 221 | zext :: forall width1 width2. (Known width2, width1 <= width2) => 222 | Constant ::: IntegerType' width1 -> Constant ::: IntegerType' width2 223 | zext o1 = coerce ZExt o1 (val @_ @(IntegerType' width2)) 224 | 225 | sext :: forall width1 width2. (Known width2, width1 <= width2) => 226 | Constant ::: IntegerType' width1 -> Constant ::: IntegerType' width2 227 | sext o1 = coerce SExt o1 (val @_ @(IntegerType' width2)) 228 | 229 | fptoui :: forall fpt width. Known width => 230 | Constant ::: FloatingPointType' fpt -> 231 | Constant ::: IntegerType' width 232 | fptoui o1 = coerce FPToUI o1 (val @_ @(IntegerType' width)) 233 | 234 | fptosi :: forall fpt width. Known width => 235 | Constant ::: FloatingPointType' fpt -> 236 | Constant ::: IntegerType' width 237 | fptosi o1 = coerce FPToSI o1 (val @_ @(IntegerType' width)) 238 | 239 | uitofp :: forall width fpt. Known fpt => 240 | Constant ::: IntegerType' width -> 241 | Constant ::: FloatingPointType' fpt 242 | uitofp o1 = coerce UIToFP o1 (val @_ @(FloatingPointType' fpt)) 243 | 244 | sitofp :: forall width fpt. Known fpt => 245 | Constant ::: IntegerType' width -> 246 | Constant ::: FloatingPointType' fpt 247 | sitofp o1 = coerce SIToFP o1 (val @_ @(FloatingPointType' fpt)) 248 | 249 | fptrunc :: forall fpt1 fpt2. 250 | (Known fpt2, BitSizeOfFP fpt2 <= BitSizeOfFP fpt1) => 251 | Constant ::: FloatingPointType' fpt1 -> 252 | Constant ::: FloatingPointType' fpt2 253 | fptrunc o1 = coerce FPTrunc o1 (val @_ @(FloatingPointType' fpt2)) 254 | 255 | fpext :: forall fpt1 fpt2. Known fpt2 => 256 | (Known fpt2, BitSizeOfFP fpt1 <= BitSizeOfFP fpt2) => 257 | Constant ::: FloatingPointType' fpt1 -> 258 | Constant ::: FloatingPointType' fpt2 259 | fpext o1 = coerce FPExt o1 (val @_ @(FloatingPointType' fpt2)) 260 | 261 | ptrtoint :: forall as t width. Known width => 262 | Constant ::: PointerType' t as -> 263 | Constant ::: IntegerType' width 264 | ptrtoint o1 = coerce PtrToInt o1 (val @_ @(IntegerType' width)) 265 | 266 | inttoptr :: forall as t width. (Known t, Known as) => 267 | Constant ::: IntegerType' width -> 268 | Constant ::: PointerType' t as 269 | inttoptr o1 = coerce IntToPtr o1 (val @_ @(PointerType' t as)) 270 | 271 | -- | We differentiate between bitcasting non-pointers and bitcasting pointers; 272 | -- there is little point in trying to use one function for these two distinct usecases. 273 | bitcast :: forall t1 t2. 274 | (Known t2, NonAggregate t1, NonAggregate t2, BitSizeOf t1 ~ BitSizeOf t2) => 275 | Constant ::: t1 -> Constant ::: t2 276 | bitcast o1 = coerce BitCast o1 (val @_ @t2) 277 | 278 | bitcastPtr :: forall t1 t2 as. 279 | (Known as, Known t2) => 280 | Constant ::: (PointerType' t1 as) -> Constant ::: (PointerType' t2 as) 281 | bitcastPtr o1 = coerce BitCast o1 (val @_ @(PointerType' t2 as)) 282 | 283 | icmp :: forall width. 284 | IntegerPredicate -> 285 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 286 | Constant ::: IntegerType' width 287 | icmp = coerce ICmp 288 | 289 | fcmp :: forall width. 290 | FloatingPointPredicate -> 291 | Constant ::: IntegerType' width -> Constant ::: IntegerType' width -> 292 | Constant ::: IntegerType' width 293 | fcmp = coerce FCmp 294 | 295 | select :: forall t. 296 | Constant ::: IntegerType' 1 -> 297 | Constant ::: t -> Constant ::: t -> 298 | Constant ::: t 299 | select = coerce Select 300 | 301 | extractElement :: forall n t width. 302 | Constant ::: VectorType' n t -> 303 | Constant ::: IntegerType' width -> 304 | Constant ::: t 305 | extractElement = coerce ExtractElement 306 | 307 | insertElement :: forall n t width. 308 | Constant ::: VectorType' n t -> 309 | Constant ::: t -> 310 | Constant ::: IntegerType' width -> 311 | Constant ::: VectorType' n t 312 | insertElement = coerce InsertElement 313 | 314 | shuffleVector :: forall n m t. 315 | Constant ::: VectorType' n t -> 316 | Constant ::: VectorType' n t -> 317 | Constant ::: VectorType' m (IntegerType' 32) -> 318 | Constant ::: VectorType' m t 319 | shuffleVector = coerce ShuffleVector 320 | 321 | -- | The indices to extractValue need to be known at compile time, to index into 322 | -- structures. 323 | extractValue :: forall t (idxs :: [Nat]). 324 | (Known idxs, NotNull idxs) => 325 | Constant ::: t -> 326 | Constant ::: ValueAt t idxs 327 | extractValue c = coerce ExtractValue c (map fromIntegral (val @_ @idxs) :: [Word32]) 328 | 329 | -- | The indices to insertValue need to be known at compile time, to index into 330 | -- structures. 331 | insertValue :: forall t (idxs :: [Nat]). 332 | (Known idxs, NotNull idxs) => 333 | Constant ::: t -> 334 | Constant ::: ValueAt t idxs -> 335 | Constant ::: t 336 | insertValue c v = coerce InsertValue c v (map fromIntegral (val @_ @idxs) :: [Word32]) 337 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/DLL.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.DLL". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.DLL (module LLVM.AST.DLL) where 4 | 5 | import LLVM.AST.DLL 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/DataLayout.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.DataLayout". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.DataLayout (module LLVM.AST.DataLayout) where 4 | 5 | import LLVM.AST.DataLayout 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Float.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | -- | This module provides a type-safe variant of "LLVM.AST.Float". 5 | module LLVM.AST.Tagged.Float where 6 | 7 | import Data.Word 8 | 9 | import LLVM.AST.Float 10 | import LLVM.AST.Type (FloatingPointType(..)) 11 | import LLVM.AST.Tagged.Tag 12 | 13 | half :: Word16 -> SomeFloat :::: HalfFP 14 | half w = assertLLVMType (Half w) 15 | 16 | single :: Float -> SomeFloat :::: FloatFP 17 | single f = assertLLVMType (Single f) 18 | 19 | double :: Double -> SomeFloat :::: DoubleFP 20 | double d = assertLLVMType (Double d) 21 | 22 | quadruple :: Word64 -> Word64 -> SomeFloat :::: FP128FP 23 | quadruple w1 w2 = assertLLVMType (Quadruple w1 w2) 24 | 25 | x86_fp80 :: Word16 -> Word64 -> SomeFloat :::: X86_FP80FP 26 | x86_fp80 w1 w2 = assertLLVMType (X86_FP80 w1 w2) 27 | 28 | ppc_fp128 :: Word64 -> Word64 -> SomeFloat :::: PPC_FP128FP 29 | ppc_fp128 w1 w2 = assertLLVMType (PPC_FP128 w1 w2) 30 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/FloatingPointPredicate.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.FloatingPointPredicate". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.FloatingPointPredicate (module LLVM.AST.FloatingPointPredicate) where 4 | 5 | import LLVM.AST.FloatingPointPredicate 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/FunctionAttribute.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.FunctionAttribute". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.FunctionAttribute (module LLVM.AST.FunctionAttribute) where 4 | 5 | import LLVM.AST.FunctionAttribute 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Global.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeFamilyDependencies #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE AllowAmbiguousTypes #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | 17 | -- | This module provides a type-safe variant of "LLVM.AST.Global". 18 | -- It is currently a stub 19 | module LLVM.AST.Tagged.Global ( 20 | basicBlock, 21 | parameter, 22 | function, 23 | ) where 24 | 25 | import Data.Coerce 26 | 27 | import LLVM.AST.Name 28 | import LLVM.AST.Global as AST 29 | import qualified LLVM.AST.Attribute as A 30 | import LLVM.AST.Instruction (Named, Instruction, Terminator) 31 | 32 | import LLVM.AST.Tagged.Tag 33 | import LLVM.AST.Tagged.Name 34 | import LLVM.AST.Tagged.Instruction 35 | import LLVM.AST.TypeLevel.Type 36 | 37 | basicBlock 38 | :: Name 39 | -> [Named Instruction] 40 | -> Named Terminator ::: t 41 | -> (BasicBlock ::: t) 42 | basicBlock nm instr term = assertLLVMType $ BasicBlock nm instr (coerce term) 43 | 44 | parameter 45 | :: forall t. Known t 46 | => (Name ::: t) 47 | -> [A.ParameterAttribute] 48 | -> (Parameter ::: t) 49 | parameter nm attrs = coerce Parameter (val @_ @t) nm attrs 50 | 51 | -- | This creates a 'Global' from typed parameters. It is equal to 52 | -- 'functionDefaults' with the fields 'AST.name', 'AST.returnType' and 53 | -- 'AST.parameters' set. 54 | -- 55 | -- It does not support varargs. 56 | function 57 | :: forall ret_ty args_tys as. Known ret_ty 58 | => (Name ::: PointerType' (FunctionType' ret_ty args_tys) as) 59 | -> (Parameter :::* args_tys, Bool) 60 | -> [BasicBlock ::: ret_ty] 61 | -> Global 62 | function nm (params,variadic) bbs = functionDefaults 63 | { AST.name = coerce nm 64 | , AST.returnType = (val @_ @ret_ty) 65 | , AST.parameters = (coerce params, variadic) 66 | , AST.basicBlocks = (coerce bbs) 67 | } 68 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/IRBuilder.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | This module provides a type-safe variant of "LLVM.IRBuilder" interface. 4 | 5 | -} 6 | 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE NoImplicitPrelude #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE AllowAmbiguousTypes #-} 17 | 18 | module LLVM.AST.Tagged.IRBuilder ( 19 | -- ** Operands 20 | emitInstr, 21 | emitInstrVoid, 22 | emitTerm, 23 | emitBlockStart, 24 | fresh, 25 | freshName, 26 | freshUnName, 27 | named, 28 | 29 | block, 30 | function, 31 | 32 | -- ** Types 33 | i1, 34 | i8, 35 | i32, 36 | i64, 37 | float, 38 | double, 39 | ptr, 40 | 41 | -- ** Instructions 42 | fadd, 43 | fmul, 44 | fsub, 45 | fdiv, 46 | frem, 47 | 48 | add, 49 | mul, 50 | sub, 51 | udiv, 52 | sdiv, 53 | urem, 54 | shl, 55 | lshr, 56 | ashr, 57 | and, 58 | or, 59 | xor, 60 | sext, 61 | zext, 62 | fptoui, 63 | fptosi, 64 | sitofp, 65 | uitofp, 66 | gep, 67 | 68 | trunc, 69 | inttoptr, 70 | ptrtoint, 71 | 72 | icmp, 73 | fcmp, 74 | 75 | bitcast, 76 | bitcastPtr, 77 | 78 | extractElement, 79 | insertElement, 80 | shuffleVector, 81 | extractValue, 82 | insertValue, 83 | 84 | br, 85 | ret, 86 | condBr, 87 | switch, 88 | phi, 89 | select, 90 | IR.unreachable, 91 | IR.retVoid, 92 | ) where 93 | 94 | import LLVM.Prelude hiding (and, or) 95 | import LLVM.AST hiding (function) 96 | import qualified LLVM.AST.Type as AST 97 | import LLVM.AST.Constant 98 | import LLVM.AST.TypeLevel.Type 99 | import LLVM.AST.TypeLevel.Utils 100 | import LLVM.AST.Tagged.Tag 101 | import LLVM.AST.Tagged.Constant (GEP_Args, GEP_Res, NotNull, ValueAt, getElementPtr, getGEPArgs) 102 | import LLVM.AST.Operand 103 | import LLVM.AST.Instruction hiding (function) 104 | import LLVM.AST.Name (Name) 105 | import LLVM.AST.Float (SomeFloat) 106 | import LLVM.AST.IntegerPredicate (IntegerPredicate) 107 | import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) 108 | import qualified LLVM.AST.IntegerPredicate as IP 109 | import qualified LLVM.AST.FloatingPointPredicate as FP 110 | 111 | import GHC.TypeLits 112 | import GHC.Exts (Constraint) 113 | import Data.Coerce 114 | import Unsafe.Coerce 115 | import Data.HVect hiding (Nat) 116 | import qualified LLVM.IRBuilder as IR 117 | 118 | ------------------------------------------------------------------------------- 119 | -- Builder 120 | ------------------------------------------------------------------------------- 121 | 122 | emitInstr :: IR.MonadIRBuilder m => Type -> (Instruction ::: t) -> m Operand 123 | emitInstr ty instr = IR.emitInstr ty (coerce instr) 124 | 125 | emitInstrVoid :: IR.MonadIRBuilder m => (Instruction ::: t) -> m () 126 | emitInstrVoid instr = IR.emitInstrVoid (coerce instr) 127 | 128 | emitTerm :: IR.MonadIRBuilder m => (Terminator ::: t) -> m () 129 | emitTerm instr = IR.emitTerm (coerce instr) 130 | 131 | emitBlockStart :: IR.MonadIRBuilder m => (Name ::: LabelType') -> m () 132 | emitBlockStart instr = IR.emitBlockStart (coerce instr) 133 | 134 | block :: IR.MonadIRBuilder m => m (Name ::: LabelType') 135 | block = IR.block >>= pure . coerce 136 | 137 | fresh :: IR.MonadIRBuilder m => m (Name ::: t) 138 | fresh = IR.fresh >>= pure . coerce 139 | 140 | freshName :: IR.MonadIRBuilder m => ShortByteString -> m (Name ::: t) 141 | freshName prefix = IR.freshName prefix >>= pure . coerce 142 | 143 | freshUnName :: IR.MonadIRBuilder m => m (Name ::: t) 144 | freshUnName = IR.freshUnName >>= pure . coerce 145 | 146 | named :: IR.MonadIRBuilder m => m (r ::: t) -> ShortByteString -> m (r ::: t) 147 | named m = IR.named m 148 | 149 | -- partially applied Map 150 | type family MapOp (as :: [(Type', ParameterName')]) where 151 | MapOp '[] = '[] 152 | MapOp ('(t, _) ': xs) = (Operand :::: t) ': MapOp xs 153 | 154 | function 155 | :: forall (t :: Type') -- ^ Function return type 156 | (as :: [(Type', ParameterName')]) -- ^ Function arguments 157 | m. 158 | (Known t, Known as, IR.MonadModuleBuilder m) 159 | => Name -- ^ Function name 160 | -> (HVect (MapOp as) -> IR.IRBuilderT m ()) -- ^ Function body builder 161 | -> m (Operand ::: t) 162 | function nm m = IR.function nm (val @_ @as) (val @_ @t) (unsafeCoerce m) >>= pure . coerce 163 | 164 | ------------------------------------------------------------------------------- 165 | -- Types 166 | ------------------------------------------------------------------------------- 167 | 168 | type I32 = IntegerType' 32 169 | type I64 = IntegerType' 64 170 | 171 | i1 :: Type ::: IntegerType' 1 172 | i1 = coerce AST.i1 173 | 174 | i8 :: Type ::: IntegerType' 8 175 | i8 = coerce AST.i8 176 | 177 | i32 :: Type ::: IntegerType' 32 178 | i32 = coerce AST.i32 179 | 180 | i64 :: Type ::: IntegerType' 64 181 | i64 = coerce AST.i32 182 | 183 | void :: Type ::: VoidType' 184 | void = coerce AST.void 185 | 186 | double :: Type ::: FloatingPointType' DoubleFP 187 | double = coerce AST.double 188 | 189 | float :: Type ::: FloatingPointType' FloatFP 190 | float = coerce AST.float 191 | 192 | ptr :: Known t => (Type ::: t) -> (Type ::: (PointerType' t ('AddrSpace' 0))) 193 | ptr ty = coerce (AST.ptr (coerce ty)) 194 | 195 | ------------------------------------------------------------------------------- 196 | -- Instructions 197 | ------------------------------------------------------------------------------- 198 | 199 | fadd 200 | :: IR.MonadIRBuilder m 201 | => (Operand ::: (FloatingPointType' t)) 202 | -> (Operand ::: (FloatingPointType' t)) 203 | -> m (Operand ::: (FloatingPointType' t)) 204 | fadd a b = IR.fadd (coerce a) (coerce b) >>= pure . coerce 205 | 206 | fmul 207 | :: IR.MonadIRBuilder m 208 | => (Operand ::: (FloatingPointType' t)) 209 | -> (Operand ::: (FloatingPointType' t)) 210 | -> m (Operand ::: (FloatingPointType' t)) 211 | fmul a b = IR.fmul (coerce a) (coerce b) >>= pure . coerce 212 | 213 | fsub 214 | :: IR.MonadIRBuilder m 215 | => (Operand ::: (IntegerType' t)) 216 | -> (Operand ::: (IntegerType' t)) 217 | -> m (Operand ::: (IntegerType' t)) 218 | fsub a b = IR.fsub (coerce a) (coerce b) >>= pure . coerce 219 | 220 | fdiv 221 | :: IR.MonadIRBuilder m 222 | => (Operand ::: (IntegerType' t)) 223 | -> (Operand ::: (IntegerType' t)) 224 | -> m (Operand ::: (IntegerType' t)) 225 | fdiv a b = IR.fdiv (coerce a) (coerce b) >>= pure . coerce 226 | 227 | frem 228 | :: IR.MonadIRBuilder m 229 | => (Operand ::: (IntegerType' t)) 230 | -> (Operand ::: (IntegerType' t)) 231 | -> m (Operand ::: (IntegerType' t)) 232 | frem a b = IR.frem (coerce a) (coerce b) >>= pure . coerce 233 | 234 | add 235 | :: IR.MonadIRBuilder m 236 | => (Operand ::: (IntegerType' t)) 237 | -> (Operand ::: (IntegerType' t)) 238 | -> m (Operand ::: (IntegerType' t)) 239 | add a b = IR.add (coerce a) (coerce b) >>= pure . coerce 240 | 241 | mul 242 | :: IR.MonadIRBuilder m 243 | => (Operand ::: (IntegerType' t)) 244 | -> (Operand ::: (IntegerType' t)) 245 | -> m (Operand ::: (IntegerType' t)) 246 | mul a b = IR.mul (coerce a) (coerce b) >>= pure . coerce 247 | 248 | sub 249 | :: IR.MonadIRBuilder m 250 | => (Operand ::: (IntegerType' t)) 251 | -> (Operand ::: (IntegerType' t)) 252 | -> m (Operand ::: (IntegerType' t)) 253 | sub a b = IR.sub (coerce a) (coerce b) >>= pure . coerce 254 | 255 | udiv 256 | :: IR.MonadIRBuilder m 257 | => (Operand ::: (IntegerType' t)) 258 | -> (Operand ::: (IntegerType' t)) 259 | -> m (Operand ::: (IntegerType' t)) 260 | udiv a b = IR.udiv (coerce a) (coerce b) >>= pure . coerce 261 | 262 | sdiv 263 | :: IR.MonadIRBuilder m 264 | => (Operand ::: (IntegerType' t)) 265 | -> (Operand ::: (IntegerType' t)) 266 | -> m (Operand ::: (IntegerType' t)) 267 | sdiv a b = IR.sdiv (coerce a) (coerce b) >>= pure . coerce 268 | 269 | urem 270 | :: IR.MonadIRBuilder m 271 | => (Operand ::: (IntegerType' t)) 272 | -> (Operand ::: (IntegerType' t)) 273 | -> m (Operand ::: (IntegerType' t)) 274 | urem a b = IR.urem (coerce a) (coerce b) >>= pure . coerce 275 | 276 | shl 277 | :: IR.MonadIRBuilder m 278 | => (Operand ::: (IntegerType' t)) 279 | -> (Operand ::: (IntegerType' t)) 280 | -> m (Operand ::: (IntegerType' t)) 281 | shl a b = IR.shl (coerce a) (coerce b) >>= pure . coerce 282 | 283 | lshr 284 | :: IR.MonadIRBuilder m 285 | => (Operand ::: (IntegerType' t)) 286 | -> (Operand ::: (IntegerType' t)) 287 | -> m (Operand ::: (IntegerType' t)) 288 | lshr a b = IR.lshr (coerce a) (coerce b) >>= pure . coerce 289 | 290 | ashr 291 | :: IR.MonadIRBuilder m 292 | => (Operand ::: (IntegerType' t)) 293 | -> (Operand ::: (IntegerType' t)) 294 | -> m (Operand ::: (IntegerType' t)) 295 | ashr a b = IR.ashr (coerce a) (coerce b) >>= pure . coerce 296 | 297 | and 298 | :: IR.MonadIRBuilder m 299 | => (Operand ::: (IntegerType' t)) 300 | -> (Operand ::: (IntegerType' t)) 301 | -> m (Operand ::: (IntegerType' t)) 302 | and a b = IR.and (coerce a) (coerce b) >>= pure . coerce 303 | 304 | or 305 | :: IR.MonadIRBuilder m 306 | => (Operand ::: (IntegerType' t)) 307 | -> (Operand ::: (IntegerType' t)) 308 | -> m (Operand ::: (IntegerType' t)) 309 | or a b = IR.or (coerce a) (coerce b) >>= pure . coerce 310 | 311 | xor 312 | :: IR.MonadIRBuilder m 313 | => (Operand ::: (IntegerType' t)) 314 | -> (Operand ::: (IntegerType' t)) 315 | -> m (Operand ::: (IntegerType' t)) 316 | xor a b = IR.or (coerce a) (coerce b) >>= pure . coerce 317 | 318 | sext 319 | :: forall width1 width2 m. (Known width2, width1 <= width2) 320 | => IR.MonadIRBuilder m 321 | => (Operand ::: (IntegerType' width1)) 322 | -> m (Operand ::: (IntegerType' width2)) 323 | sext a = IR.sext (coerce a) (val @_ @(IntegerType' width2)) >>= pure . coerce 324 | 325 | zext 326 | :: forall width1 width2 m. (Known width2, width1 <= width2) 327 | => IR.MonadIRBuilder m 328 | => (Operand ::: (IntegerType' width1)) 329 | -> m (Operand ::: (IntegerType' width2)) 330 | zext a = IR.zext (coerce a) (val @_ @(IntegerType' width2)) >>= pure . coerce 331 | 332 | fptoui 333 | :: forall fpt width m. Known width 334 | => IR.MonadIRBuilder m 335 | => (Operand ::: (FloatingPointType' fpt)) 336 | -> m (Operand ::: (IntegerType' width)) 337 | fptoui a = IR.fptoui (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 338 | 339 | fptosi 340 | :: forall fpt width m. Known width 341 | => IR.MonadIRBuilder m 342 | => (Operand ::: (FloatingPointType' fpt)) 343 | -> m (Operand ::: (IntegerType' width)) 344 | fptosi a = IR.fptosi (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 345 | 346 | uitofp 347 | :: forall fpt width m. Known width 348 | => IR.MonadIRBuilder m 349 | => (Operand ::: (FloatingPointType' fpt)) 350 | -> m (Operand ::: (IntegerType' width)) 351 | uitofp a = IR.uitofp (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 352 | 353 | sitofp 354 | :: forall fpt width m. Known width 355 | => IR.MonadIRBuilder m 356 | => (Operand ::: (FloatingPointType' fpt)) 357 | -> m (Operand ::: (IntegerType' width)) 358 | sitofp a = IR.sitofp (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 359 | 360 | trunc 361 | :: forall width1 width2 m. (Known width2, width1 <= width2) 362 | => IR.MonadIRBuilder m 363 | => (Operand ::: (IntegerType' width1)) 364 | -> m (Operand ::: (IntegerType' width2)) 365 | trunc a = IR.trunc (coerce a) (val @_ @(IntegerType' width2)) >>= pure . coerce 366 | 367 | ptrtoint 368 | :: forall width t as m. (Known width) 369 | => IR.MonadIRBuilder m 370 | => (Operand ::: PointerType' t as) 371 | -> m (Operand ::: IntegerType' width) 372 | ptrtoint a = IR.ptrtoint (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 373 | 374 | inttoptr 375 | :: forall width t as m. (Known width) 376 | => IR.MonadIRBuilder m 377 | => (Operand ::: IntegerType' width) 378 | -> m (Operand ::: PointerType' t as) 379 | inttoptr a = IR.inttoptr (coerce a) (val @_ @(IntegerType' width)) >>= pure . coerce 380 | 381 | fptrunc :: forall fpt1 fpt2 m. 382 | (Known fpt2, BitSizeOfFP fpt2 <= BitSizeOfFP fpt1, IR.MonadIRBuilder m) 383 | => Operand ::: FloatingPointType' fpt1 384 | -> m (Operand ::: FloatingPointType' fpt2) 385 | fptrunc a = IR.fptrunc (coerce a) (val @_ @(FloatingPointType' fpt2)) >>= pure . coerce 386 | 387 | fpext :: forall fpt1 fpt2 m. Known fpt2 => 388 | (Known fpt2, BitSizeOfFP fpt1 <= BitSizeOfFP fpt2, IR.MonadIRBuilder m) 389 | => Operand ::: FloatingPointType' fpt1 390 | -> m (Operand ::: FloatingPointType' fpt2) 391 | fpext a = IR.fpext (coerce a) (val @_ @(FloatingPointType' fpt2)) >>= pure . coerce 392 | 393 | icmp 394 | :: IR.MonadIRBuilder m 395 | => IP.IntegerPredicate 396 | -> (Operand ::: IntegerType' t) 397 | -> (Operand ::: IntegerType' t) 398 | -> m (Operand ::: IntegerType' 1) 399 | icmp pred a b = IR.icmp pred (coerce a) (coerce b) >>= pure . coerce 400 | 401 | fcmp 402 | :: IR.MonadIRBuilder m 403 | => FP.FloatingPointPredicate 404 | -> (Operand ::: FloatingPointType' t) 405 | -> (Operand ::: FloatingPointType' t) 406 | -> m (Operand ::: IntegerType' 1) 407 | fcmp pred a b = IR.fcmp pred (coerce a) (coerce b) >>= pure . coerce 408 | 409 | select 410 | :: forall t m. IR.MonadIRBuilder m 411 | => Operand ::: IntegerType' 1 412 | -> Operand ::: t 413 | -> Operand ::: t 414 | -> m (Operand ::: t) 415 | select cond t f = IR.select (coerce cond) (coerce t) (coerce f) >>= pure . coerce 416 | 417 | bitcast 418 | :: forall t1 t2 m. IR.MonadIRBuilder m 419 | => (Known t1, Known t2, NonAggregate t1, NonAggregate t2) 420 | => (Operand ::: t1) 421 | -> m (Operand ::: t2) 422 | bitcast a = IR.bitcast (coerce a) (val @_ @t2) >>= pure . coerce 423 | 424 | bitcastPtr 425 | :: forall t1 t2 as m. IR.MonadIRBuilder m 426 | => (Known as, Known t2) 427 | => (Operand ::: PointerType' t1 as) 428 | -> m (Operand ::: PointerType' t2 as) 429 | bitcastPtr a = IR.bitcast (coerce a) (val @_ @(PointerType' t2 as)) >>= pure . coerce 430 | 431 | br :: IR.MonadIRBuilder m => (Name ::: LabelType') -> m () 432 | br val = IR.br (coerce val) 433 | 434 | ret :: IR.MonadIRBuilder m => (Operand ::: t) -> m () 435 | ret val = IR.ret (coerce val) 436 | 437 | condBr 438 | :: IR.MonadIRBuilder m 439 | => (Operand ::: t) 440 | -> Name ::: LabelType' 441 | -> Name ::: LabelType' 442 | -> m () 443 | condBr cond tdest fdest = IR.condBr (coerce cond) (coerce tdest) (coerce fdest) 444 | 445 | switch 446 | :: IR.MonadIRBuilder m 447 | => (Operand ::: t) 448 | -> (Name ::: t2) 449 | -> [(Constant ::: t, Name ::: LabelType')] 450 | -> m () 451 | switch val def dests = IR.switch (coerce val) (coerce def) (coerce dests) 452 | 453 | phi 454 | :: IR.MonadIRBuilder m 455 | => [(Operand ::: t, Name ::: LabelType')] 456 | -> m (Operand ::: t) 457 | phi dests = IR.phi (coerce dests) >>= pure . coerce 458 | 459 | gep 460 | :: forall t as static_args m. IR.MonadIRBuilder m 461 | => (Operand ::: PointerType' t as) 462 | -> GEP_Args static_args 463 | -> m (Operand ::: GEP_Res (PointerType' t as) static_args) 464 | gep address indices = IR.gep (coerce address) args >>= pure . coerce 465 | where 466 | args = fmap ConstantOperand (getGEPArgs indices) 467 | 468 | insertElement 469 | :: forall n t width m. IR.MonadIRBuilder m 470 | => Operand ::: VectorType' n t 471 | -> Operand ::: t 472 | -> Operand ::: IntegerType' width 473 | -> m (Operand ::: VectorType' n t) 474 | insertElement a b c = IR.insertElement (coerce a) (coerce b) (coerce c) >>= pure . coerce 475 | 476 | extractElement 477 | :: forall n t width m. IR.MonadIRBuilder m 478 | => Operand ::: VectorType' n t 479 | -> Operand ::: IntegerType' width 480 | -> m (Operand ::: t) 481 | extractElement v i = IR.extractElement (coerce v) (coerce i) >>= pure . coerce 482 | 483 | shuffleVector 484 | :: forall n l t width m. IR.MonadIRBuilder m 485 | => Operand ::: VectorType' n t 486 | -> Operand ::: VectorType' n t 487 | -> Constant ::: VectorType' l (IntegerType' 32) 488 | -> m (Operand ::: VectorType' l t) 489 | shuffleVector a b c = IR.shuffleVector (coerce a) (coerce b) (coerce c) >>= pure . coerce 490 | 491 | extractValue 492 | :: forall t (idxs :: [Nat]) m. 493 | (Known idxs, NotNull idxs, IR.MonadIRBuilder m) 494 | => Operand ::: t 495 | -> m (Operand ::: ValueAt t idxs) 496 | extractValue c = IR.extractValue (coerce c) (map fromIntegral (val @_ @idxs) :: [Word32]) >>= pure . coerce 497 | 498 | insertValue :: forall t (idxs :: [Nat]) m. 499 | (Known idxs, NotNull idxs, IR.MonadIRBuilder m) 500 | => Operand ::: t 501 | -> Operand ::: ValueAt t idxs 502 | -> m (Operand ::: t) 503 | insertValue c v = IR.insertValue (coerce c) (coerce v) (map fromIntegral (val @_ @idxs) :: [Word32]) >>= pure . coerce 504 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/InlineAssembly.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.InlineAssembly". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.InlineAssembly (module LLVM.AST.InlineAssembly) where 4 | 5 | import LLVM.AST.InlineAssembly 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Instruction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeFamilyDependencies #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE AllowAmbiguousTypes #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | This module provides a type-safe variant of "LLVM.AST.Instruction". 17 | -- 18 | -- Note that the smart constructors create @Named Terminators@ directly. Almost 19 | -- all of them do not accept a name anyways, with the exception of 'invoke', 20 | -- which now takes the @Name@ as an argument. 21 | module LLVM.AST.Tagged.Instruction where 22 | 23 | import Data.Coerce 24 | 25 | import LLVM.AST.Tagged.Tag 26 | import LLVM.AST.Operand 27 | import LLVM.AST.Constant 28 | import LLVM.AST.TypeLevel.Type 29 | import LLVM.AST.Instruction 30 | import LLVM.AST.Tagged.Name 31 | 32 | import Data.List.NonEmpty 33 | 34 | import LLVM.AST.CallingConvention (CallingConvention) 35 | import qualified LLVM.AST.ParameterAttribute as PA (ParameterAttribute) 36 | import qualified LLVM.AST.FunctionAttribute as FA (FunctionAttribute, GroupID) 37 | 38 | 39 | -- TODO: Lots of stuff missing 40 | 41 | -- | We distuingish between returning from a @void@ function and otherwise by 42 | -- two different smart constructors (instead of passing a @Maybe@ to @Ret@). 43 | ret :: Operand ::: t -> InstructionMetadata -> Named Terminator ::: t 44 | ret o im = doRet $ coerce Ret (Just o) im 45 | 46 | retVoid :: InstructionMetadata -> Named Terminator ::: VoidType' 47 | retVoid im = doRet $ coerce (Ret Nothing) im 48 | 49 | condBr :: 50 | Operand ::: IntegerType' 1 -> 51 | Name ::: LabelType' -> 52 | Name ::: LabelType' -> 53 | InstructionMetadata -> 54 | Named Terminator ::: t 55 | condBr o1 n1 n2 im = doRet $ coerce CondBr o1 n1 n2 im 56 | 57 | br :: 58 | Name ::: LabelType' -> 59 | InstructionMetadata -> 60 | Named Terminator ::: t 61 | br n im = doRet $ coerce Br n im 62 | 63 | switch :: 64 | Operand ::: t -> 65 | Name ::: LabelType' -> 66 | [(Constant ::: t, Name ::: LabelType')] -> 67 | InstructionMetadata -> 68 | Named Terminator ::: t2 69 | switch o n targets im = doRet $ coerce Switch o n targets im 70 | 71 | indirectBr :: 72 | Operand ::: PointerType' (IntegerType' 8) as -> 73 | [( Name ::: LabelType')] -> 74 | InstructionMetadata -> 75 | Named Terminator ::: t2 76 | indirectBr o ns im = doRet $ coerce IndirectBr o ns im 77 | 78 | invoke :: 79 | Name ::: ret_ty -> 80 | CallingConvention -> 81 | [PA.ParameterAttribute] -> 82 | CallableOperand ::: PointerType' (FunctionType' ret_ty args_tys) as -> 83 | (Operand, [PA.ParameterAttribute]) :::* args_tys -> 84 | [Either FA.GroupID FA.FunctionAttribute] -> 85 | Name ::: LabelType' -> 86 | Name ::: LabelType' -> 87 | InstructionMetadata -> 88 | Named Terminator ::: t2 89 | invoke n cc pas o os fas n1 n2 im 90 | = assertLLVMType $ coerce n := coerce Invoke cc pas o os fas n1 n2 im 91 | 92 | -- | It is not checked that the type of the operand matches the type of 93 | -- landingpads in this function. 94 | resume :: 95 | Operand ::: t -> 96 | InstructionMetadata -> 97 | Named Terminator ::: t2 98 | resume o im = doRet $ coerce Resume o im 99 | 100 | unreachable :: 101 | InstructionMetadata -> 102 | Named Terminator ::: t 103 | unreachable im = doRet $ coerce Unreachable im 104 | 105 | cleanupRet :: 106 | Operand ::: TokenType' -> 107 | Maybe (Name ::: LabelType') -> 108 | InstructionMetadata -> 109 | Named Terminator ::: t2 110 | cleanupRet o mbn im = doRet $ coerce CleanupRet o mbn im 111 | 112 | catchRet :: 113 | Operand ::: TokenType' -> 114 | Name ::: LabelType' -> 115 | InstructionMetadata -> 116 | Named Terminator ::: t2 117 | catchRet o n im = doRet $ coerce CatchRet o n im 118 | 119 | catchSwitch :: 120 | Operand ::: TokenType' -> 121 | NonEmpty (Name ::: LabelType') -> 122 | Maybe (Name ::: LabelType') -> 123 | InstructionMetadata -> 124 | Named Terminator ::: t2 125 | catchSwitch o ns n im = doRet $ coerce CatchSwitch o ns n im 126 | 127 | 128 | 129 | -- | This is the type-safe type corresponding to @Named Instruction@. It 130 | -- enforces that an instruction has a name if and only if it is not a void 131 | -- instruction, and that the name and instruction have the same type. 132 | -- 133 | -- The returned 'Named Instruction' does not carry a type, because it is not 134 | -- useful in any way. 135 | name :: forall (t :: Type'). NonVoid t => 136 | Name ::: t -> 137 | Instruction ::: t -> 138 | Named Instruction 139 | name = coerce ((:=) :: Name -> Instruction -> Named Instruction) 140 | 141 | -- | If you do have a void instruction, you must use 'do'' and not pass a name 142 | -- to it. 143 | -- 144 | do' :: Instruction ::: VoidType' -> Named Instruction 145 | do' = coerce (Do :: Instruction -> Named Instruction) 146 | 147 | -- Local helper, for Terminators 148 | doRet = assertLLVMType . Do 149 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/IntegerPredicate.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.IntegerPredicate". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.IntegerPredicate (module LLVM.AST.IntegerPredicate) where 4 | 5 | import LLVM.AST.IntegerPredicate 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Linkage.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.Linkage". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.Linkage (module LLVM.AST.Linkage) where 4 | 5 | import LLVM.AST.Linkage 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Name.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.Name". 2 | -- 3 | -- There is nothing type-safety-specific here, so this just re-exports "LLVM.AST.Name" 4 | module LLVM.AST.Tagged.Name (module LLVM.AST.Name) where 5 | 6 | import LLVM.AST.Name 7 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Operand.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE AllowAmbiguousTypes #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | -- | This module provides a type-safe variant of "LLVM.AST.Operand". 14 | -- It is currently a stub 15 | module LLVM.AST.Tagged.Operand ( 16 | module LLVM.AST.Operand, 17 | constantOperand, 18 | ) where 19 | 20 | import Data.Coerce 21 | import LLVM.AST.Tagged.Tag 22 | import LLVM.AST.TypeLevel.Type 23 | import LLVM.AST.Operand 24 | import LLVM.AST.Constant 25 | 26 | constantOperand 27 | :: forall t. Known t 28 | => (Constant ::: t) 29 | -> Operand ::: t 30 | constantOperand c = assertLLVMType (ConstantOperand (coerce c)) 31 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/ParameterAttribute.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.ParameterAttribute". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.ParameterAttribute (module LLVM.AST.ParameterAttribute) where 4 | 5 | import LLVM.AST.ParameterAttribute 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/RMWOperation.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.RMWOperation". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.RMWOperation (module LLVM.AST.RMWOperation) where 4 | 5 | import LLVM.AST.RMWOperation 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | 13 | module LLVM.AST.Tagged.Tag where 14 | 15 | import GHC.TypeLits 16 | import Data.Coerce 17 | 18 | import LLVM.AST.TypeLevel.Type 19 | import LLVM.AST.Type (Type) 20 | import LLVM.Pretty 21 | 22 | -- | A value of type @v ::: t@ denotes a value of type @v@ with an LLVM type 23 | -- annotation of @t :: Type'@. 24 | -- 25 | -- This anntation exists only on the Haskell type level. Functions that need to 26 | -- get hold of the actual 'LLVM.Ast.Type.Type' associated to the tag will 27 | -- typically have a 'Known' type class constraint. 28 | type v ::: (t :: Type') = v :::: t 29 | 30 | -- | Sometimes we want to annotate a value @v@ with something else than an LLVM 31 | -- type (@Type'@), so this allows any kind 32 | newtype v :::: (t :: k) = Typed v 33 | 34 | 35 | -- | Adds an LLVM type annotation to its argument. Note that this function is unchecked. 36 | assertLLVMType :: v -> v :::: t 37 | assertLLVMType = Typed 38 | 39 | -- | Removes the LLVM type annotation. 40 | unTyped :: v :::: t -> v 41 | unTyped (Typed v) = v 42 | 43 | 44 | -- | Removes the LLVM type annotation. 45 | typeOf :: forall (t :: Type') v. Known t => (v ::: t) -> Type 46 | typeOf (Typed v) = (val @_ @t) 47 | 48 | -- | A list of tagged values. The smart constructors below ensure 49 | -- that the type-level list has the same lengths as the value list, 50 | -- and that the elements have the corresponding tag. 51 | type v :::* (ts :: [k']) = [v] :::: ts 52 | 53 | tnil :: v :::* '[] 54 | tnil = assertLLVMType [] 55 | 56 | pattern (:*) :: v :::: t -> v :::* ts -> v :::* (t:ts) 57 | pattern x :* xs <- (unTyped -> ((coerce -> x) : (coerce -> xs) :: [v])) 58 | where 59 | (:*) x xs = assertLLVMType (unTyped x : unTyped xs) 60 | 61 | 62 | infixr 5 :* 63 | 64 | -- | A vector type 65 | data (n::Nat) × a where 66 | VNil :: 0 × a 67 | (:×) :: a -> n × a -> (1 + n) × a 68 | infixr 5 :× 69 | 70 | unCounted :: n × a -> [a] 71 | unCounted VNil = [] 72 | unCounted (x :× xs) = x : unCounted xs 73 | 74 | instance (PP a) => PP (a :::: t) where 75 | pp (Typed v) = pp v 76 | 77 | instance (PP a) => PP (a ::: t) where 78 | pp (Typed v) = pp v 79 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/ThreadLocalStorage.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.ThreadLocalStorage". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.ThreadLocalStorage (module LLVM.AST.ThreadLocalStorage) where 4 | 5 | import LLVM.AST.ThreadLocalStorage 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Type.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.Type". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.Type (module LLVM.AST.Type) where 4 | 5 | import LLVM.AST.Type 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/Tagged/Visibility.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a type-safe variant of "LLVM.AST.Visibility". 2 | -- It is currently a stub 3 | module LLVM.AST.Tagged.Visibility (module LLVM.AST.Visibility) where 4 | 5 | import LLVM.AST.Visibility 6 | -------------------------------------------------------------------------------- /src/LLVM/AST/TypeLevel/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE AllowAmbiguousTypes #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | {- | 15 | This modules contains a variant of the 'LLVM.AST.Type.Type' type, suitable for 16 | promotion to the type-level. We cannot just use 'LLVM.AST.Type.Type' directy, 17 | as basic types such as 'Word32' are not useful as kinds, and we have to replace 18 | them with 'GHC.TypeLits.Nat'. 19 | 20 | Because we have to define a new type, but expect users want access to both 21 | variants, we have to avoid name clashes. The convention is to simply append a 22 | @'@. 23 | 24 | This module also contains various type-level functions, classes and other 25 | machinery that provide the necessary functionality for the typed AST. 26 | 27 | -} 28 | module LLVM.AST.TypeLevel.Type where 29 | 30 | import Data.Word 31 | import GHC.TypeLits 32 | import GHC.Exts (Constraint) 33 | import Data.String.Encode 34 | import qualified Data.ByteString.Short as BS 35 | 36 | import LLVM.AST.Type 37 | import LLVM.AST.AddrSpace 38 | import LLVM.AST.Name 39 | import qualified LLVM.IRBuilder as IR 40 | 41 | data Name' = Name' Symbol | UnName' Nat 42 | 43 | data AddrSpace' = AddrSpace' Nat 44 | 45 | data ParameterName' = ParameterName' Symbol 46 | 47 | -- | A copy of 'Type', suitable to be used on the type level 48 | data Type' 49 | = VoidType' 50 | | IntegerType' Nat 51 | | PointerType' Type' AddrSpace' 52 | | FloatingPointType' FloatingPointType 53 | | FunctionType' Type' [Type'] 54 | -- ^ we do not support varargs in the typed represenation 55 | | VectorType' Nat Type' 56 | | StructureType' Bool [Type'] 57 | | ArrayType' Nat Type' 58 | | NamedTypeReference' Name' 59 | | MetadataType' 60 | | TokenType' 61 | | LabelType' 62 | 63 | -- | Ensures a type is not void 64 | type family NonVoid (t :: Type') :: Constraint where 65 | NonVoid VoidType' = TypeError (Text "Type must not be void") 66 | NonVoid t = () 67 | 68 | -- | A non-aggregate, non-vector type. Basically, everything that can 69 | -- be bitcaste’d into each other. 70 | type family NonAggregate (t :: Type') :: Constraint where 71 | NonAggregate (IntegerType' _) = () 72 | NonAggregate (FloatingPointType' _) = () 73 | NonAggregate (VectorType' _ _ ) = () 74 | NonAggregate t = TypeError (ShowType t :<>: Text " is aggregate") 75 | 76 | -- | Bit widths of the given floating point type 77 | type family BitSizeOfFP (t :: FloatingPointType) :: Nat where 78 | BitSizeOfFP HalfFP = 16 79 | BitSizeOfFP FloatFP = 32 80 | BitSizeOfFP DoubleFP = 64 81 | BitSizeOfFP FP128FP = 128 82 | BitSizeOfFP X86_FP80FP = 80 83 | BitSizeOfFP PPC_FP128FP = 128 84 | 85 | -- | Bit widths of this nonaggregate type 86 | type family BitSizeOf (t :: Type') :: Nat where 87 | BitSizeOf (IntegerType' w) = w 88 | BitSizeOf (FloatingPointType' fpf) = BitSizeOfFP fpf 89 | BitSizeOf (VectorType' n t) = n * BitSizeOf t 90 | BitSizeOf t = TypeError (ShowType t :<>: Text " is aggregate") 91 | 92 | -- | This type family indicates the value-level representation of a type-level 93 | -- type. Often these are the same. 94 | type family Value k :: * 95 | 96 | -- | This class connects type variables (of kind @k@) to their value-level 97 | -- representation (of type 'Value k'). 98 | class Known (t :: k) where 99 | val :: Value k 100 | 101 | type instance Value Type' = Type 102 | type instance Value [a] = [Value a] 103 | type instance Value AddrSpace' = AddrSpace 104 | type instance Value Name' = Name 105 | type instance Value FloatingPointType = FloatingPointType 106 | type instance Value Bool = Bool 107 | type instance Value Symbol = String 108 | type instance Value Nat = Integer 109 | type instance Value ParameterName' = IR.ParameterName 110 | type instance Value (a, b) = (Value a, Value b) 111 | 112 | word32Val :: forall (n::Nat). Known n => Word32 113 | word32Val = fromIntegral (val @_ @n) 114 | 115 | word64Val :: forall (n::Nat). Known n => Word64 116 | word64Val = fromIntegral (val @_ @n) 117 | 118 | wordVal :: forall (n::Nat). Known n => Word 119 | wordVal = fromIntegral (val @_ @n) 120 | 121 | byteStringVal :: forall (s::Symbol). Known s => BS.ShortByteString 122 | byteStringVal = convertString (val @_ @s) 123 | 124 | instance Known VoidType' where 125 | val = VoidType 126 | instance Known n => Known (IntegerType' n) where 127 | val = IntegerType (word32Val @n) 128 | instance (Known t, Known as) => Known (PointerType' t as) where 129 | val = PointerType (val @_ @t) (val @_ @as) 130 | instance Known fpt => Known (FloatingPointType' fpt) where 131 | val = FloatingPointType (val @_ @fpt) 132 | instance (Known t, Known ts) => Known (FunctionType' t ts) where 133 | val = FunctionType (val @_ @t) (val @_ @ts) False 134 | instance (Known n, Known t) => Known (VectorType' n t) where 135 | val = VectorType (word32Val @n) (val @_ @t) 136 | instance (Known b, Known ts) => Known (StructureType' b ts) where 137 | val = StructureType (val @_ @b) (val @_ @ts) 138 | instance (Known n, Known t) => Known (ArrayType' n t) where 139 | val = ArrayType (word64Val @n) (val @_ @t) 140 | instance Known n => Known (NamedTypeReference' n) where 141 | val = NamedTypeReference (val @_ @n) 142 | instance Known MetadataType' where 143 | val = MetadataType 144 | instance Known TokenType' where 145 | val = TokenType 146 | instance Known LabelType' where 147 | val = LabelType 148 | 149 | instance Known '[] where 150 | val = [] 151 | instance (Known t, Known tys) => Known (t:tys) where 152 | val = (val @_ @t) : (val @_ @tys) 153 | 154 | instance Known n => Known ('AddrSpace' n) where 155 | val = AddrSpace (word32Val @n) 156 | 157 | instance Known s => Known ('Name' s) where 158 | val = Name (byteStringVal @s) 159 | instance Known n => Known (UnName' n) where 160 | val = UnName (wordVal @n) 161 | instance Known s => Known ('ParameterName' s) where 162 | val = IR.ParameterName (byteStringVal @s) 163 | 164 | instance (Known a, Known b) => Known '(a, b) where 165 | val = (val @_ @a, val @_ @b) 166 | 167 | instance Known HalfFP where val = HalfFP 168 | instance Known FloatFP where val = FloatFP 169 | instance Known DoubleFP where val = DoubleFP 170 | instance Known FP128FP where val = FP128FP 171 | instance Known X86_FP80FP where val = X86_FP80FP 172 | instance Known PPC_FP128FP where val = PPC_FP128FP 173 | 174 | instance Known True where val = True 175 | instance Known False where val = False 176 | 177 | instance KnownNat n => Known (n :: Nat) where 178 | val = natVal @n undefined 179 | instance KnownSymbol s => Known (s :: Symbol) where 180 | val = symbolVal @s undefined 181 | -------------------------------------------------------------------------------- /src/LLVM/AST/TypeLevel/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module LLVM.AST.TypeLevel.Utils where 8 | 9 | import GHC.TypeLits 10 | 11 | type family Nth (xs :: [a]) n :: a where 12 | Nth '[] 0 = TypeError (Text "empty list") 13 | Nth (x:xs) 0 = x 14 | Nth (x:xs) n = Nth xs (n-1) 15 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.0 2 | packages: 3 | - '.' 4 | - location: 5 | git: https://github.com/llvm-hs/llvm-hs.git 6 | commit: 7fcccd3cc6bddd44d77602e13f85a8402ab35cb0 7 | extra-dep: true 8 | subdirs: 9 | - 'llvm-hs-pure' 10 | - location: 11 | git: https://github.com/llvm-hs/llvm-hs-pretty.git 12 | commit: 57bd441770996642e224427455df2e302c988a9c 13 | extra-dep: true 14 | 15 | extra-deps: 16 | - encode-string-0.1.0.0 17 | --------------------------------------------------------------------------------