├── .github └── ISSUE_TEMPLATE.md ├── .gitignore ├── LICENSE.TXT ├── README.md ├── bindinggen ├── HeaderSyntax.fs ├── Lexer.fsl ├── Lexing.fs ├── Lexing.fsi ├── Parser.fsy ├── Parsing.fs ├── Parsing.fsi ├── bindinggen.fs └── bindinggen.fsproj ├── build.bash ├── clean.bash ├── gen-bindings.bash ├── llvm-fs.fsproj ├── src └── LLVM │ ├── BitReader.fs │ ├── Core.fs │ ├── ExecutionEngine.fs │ ├── Extra.fs │ ├── FFIUtil.fs │ ├── Generated.fs │ ├── Quote.fs │ └── Target.fs └── test ├── CSSimpleTest2.cs ├── add.fs ├── metadatatest.fs ├── printadds.c ├── quotetest.c ├── quotetest.fs ├── simpletest.fs └── simpletest2.fs /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | ### Description 2 | 3 | Please provide a succinct description of your issue. 4 | 5 | ### Repro steps 6 | 7 | Please provide the steps required to reproduce the problem 8 | 9 | 1. Step A 10 | 11 | 2. Step B 12 | 13 | ### Expected behavior 14 | 15 | Please provide a description of the behavior you expect. 16 | 17 | ### Actual behavior 18 | 19 | Please provide a description of the actual behavior you observe. 20 | 21 | ### Known workarounds 22 | 23 | Please provide a description of any known workarounds. 24 | 25 | ### Related information 26 | 27 | * Operating system 28 | * Branch 29 | * .NET Runtime, CoreCLR or Mono Version 30 | * Performance information, links to performance testing scripts 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | bin/ 2 | *.dll 3 | *.exe 4 | obj/ 5 | Backup/ 6 | UpgradeLog.* 7 | _UpgradeReport_Files/ 8 | llvm-fs.sln 9 | llvm-fs.suo 10 | llvm-fs.v11.suo 11 | bindinggen/Lexer.fs 12 | bindinggen/Parser.fs 13 | bindinggen/Parser.fsi 14 | bindinggen/bindinggen.sln 15 | bindinggen/bindinggen.suo 16 | 17 | -------------------------------------------------------------------------------- /LICENSE.TXT: -------------------------------------------------------------------------------- 1 | University of Illinois/NCSA 2 | Open Source License 3 | 4 | Copyright (c) 2011 Keith Sheppard. 5 | All rights reserved. 6 | 7 | Developed by: 8 | 9 | Keith Sheppard 10 | 11 | https://github.com/keithshep/llvm-fs 12 | 13 | Permission is hereby granted, free of charge, to any person obtaining a copy of 14 | this software and associated documentation files (the "Software"), to deal with 15 | the Software without restriction, including without limitation the rights to 16 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 17 | of the Software, and to permit persons to whom the Software is furnished to do 18 | so, subject to the following conditions: 19 | 20 | * Redistributions of source code must retain the above copyright notice, 21 | this list of conditions and the following disclaimers. 22 | 23 | * Redistributions in binary form must reproduce the above copyright notice, 24 | this list of conditions and the following disclaimers in the 25 | documentation and/or other materials provided with the distribution. 26 | 27 | * Neither the names of llvm-fs, nor the names of its contributors may be used to 28 | endorse or promote products derived from this Software without specific 29 | prior written permission. 30 | 31 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 32 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 33 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 34 | CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 35 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 36 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE 37 | SOFTWARE. 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Issue Stats](http://issuestats.com/github/fsprojects/llvm-fs/badge/issue)](http://issuestats.com/github/fsprojects/llvm-fs) 2 | [![Issue Stats](http://issuestats.com/github/fsprojects/llvm-fs/badge/pr)](http://issuestats.com/github/fsprojects/llvm-fs) 3 | 4 | # llvm-fs: An F# binding for LLVM 5 | 6 | llvm-fs can be used to write your LLVM compiler in a .NET language. The code 7 | is all F# but an effort has been made to make the library easy to use from 8 | C#. See test/CSSimpleTest.cs for an example of how you can call the llvm-fs 9 | functions from C#. If you have questions or comments about llvm-fs you can 10 | use the project google group: http://groups.google.com/group/llvm-fs 11 | 12 | ## Building LLVM for llvm-fs 13 | 14 | NOTE: this has been tested on OS X 10.6 and on Windows 7 (using MinGW 15 | bash/gcc/g++ with python 2.7 installed) 16 | 17 | Checkout a copy of the LLVM source code (current at version 3.5.0svn). In order to 18 | use the LLVM native libraries with llvm-fs they must be built with 19 | `--enabled-shared`. Unfortunately the prebuilt LLVM binaries don't come with 20 | shared libraries so you will have to build LLVM yourself. For windows you can do 21 | this by using a build command like: 22 | `./configure --enable-shared --enable-jit && make && make install`. OS X 10.6 23 | needs more convincing to build the 32-bit libraries as required to work with 24 | mono. The following LLVM configuration works on 10.6: 25 | 26 | CXX='g++ -m32' CC='gcc -m32' CFLAGS=-m32 CXXFLAGS=-m32 LDFLAGS=-m32 ./configure \ 27 | --disable-bindings --build=i686-apple-darwin --host=i686-apple-darwin \ 28 | --target=i686-apple-darwin --enable-targets=x86,x86_64 \ 29 | --enable-optimized --enable-shared --enable-jit 30 | 31 | ## Building the llvm-fs Assembly 32 | 33 | OS X/mono: On OS X run the `./build.bash` script to generate the LLVMFsharp.dll 34 | assembly. This should also work on Linux but is untested (Please let me know if 35 | it works on Linux for you). 36 | 37 | Windows 7: open the llvm-fs.fsproj project file and build the project. This 38 | will generate the LLVMFsharp.dll assembly for you. 39 | 40 | ## Using llvm-fs in your project 41 | 42 | In order to use llvm-fs you will want to consult the following: 43 | 44 | 1. Example F# and C# code under the ./test directory. If you are using mono you 45 | can see how these tests are built and run by un-commenting everything under 46 | `# uncomment the following to build and run the tests` in the build.bash 47 | file. 48 | 2. The [LLVM C](http://llvm.org/doxygen/dir_ba5bdc16f452288d1429bb9e178a5965.html) 49 | documentation. Almost all of the llvm-fs binding functions are 50 | auto-generated from the C header files so these docs are very useful. 51 | 3. The LLVMFSharp.fsi file for all of the types and function signatures and 52 | of course the source code. 53 | 54 | ### Compiling F# Quotations 55 | 56 | You can use F# Quotations to build LLVM functions. Using quotations is much 57 | more concise and simple than the API but there are caveats: 58 | 59 | * The F# quotations are treated a way to represent LLVM IR more than F# code, so 60 | F# semantics are not 100% respected. 61 | * Many common F# language constructs are not supported for simplicity and so 62 | that the code in quotations will map fairly directly to LLVM IR code. Examples 63 | of this are that: 64 | * quotations only allow you to use a part of the functionality that is 65 | available in the LLVM API 66 | * the only supported types are: `bool`, `int[8,16,32,64]`, 67 | `uint[8,16,32,64]`, `single`, `double`, tuples and arrays (using 68 | `LLVM.Quote.RawArray` type which does not have a length property) 69 | * functions cannot be treated as first class values and partial application 70 | is not supported 71 | * there are no exceptions and there is no garbage collection. Any items 72 | allocated on the heap should be freed using the `LLVM.Quote.free` function. 73 | Tuple construction is always done on the heap and arrays can be allocated 74 | on the heap using `LLVM.Quote.heapAllocRawArray` or on the stack using 75 | `LLVM.Quote.stackAllocRawArray`. 76 | * functions can only be top level definitions (closures are not 77 | supported) 78 | * the list of top level function definitions in your quotation must end with 79 | a single unit value `()` 80 | 81 | These limitations are not set in stone and new F# language features may be 82 | added in the future as long as doing so maintains the goal of having an 83 | almost direct mapping from F# code to LLVM code. 84 | 85 | To get a better idea of how you can build functions with quotations take a look 86 | at the examples in `test/quotetest.fs` which generates all of the functions 87 | called in `test/quotetest.c`. 88 | 89 | ## Regenerating bindings 90 | 91 | Regenerating bindings should not be necessary unless you're building bindings to 92 | a new version of LLVM. If you want to do this start with the `./gen-bindings.bash` 93 | script and ask questions on the project list if you have problems. 94 | 95 | ## Maintainer(s) 96 | 97 | - [@keithshep](https://github.com/keithshep) 98 | 99 | The default maintainer account for projects under "fsprojects" is [@fsprojectsgit](https://github.com/fsprojectsgit) - F# Community Project Incubation Space (repo management) 100 | -------------------------------------------------------------------------------- /bindinggen/HeaderSyntax.fs: -------------------------------------------------------------------------------- 1 | module FSExternHelper.HeaderSyntax 2 | 3 | type CBaseType = 4 | | GeneralType of string 5 | | StructType of string 6 | | IntType 7 | | VoidType 8 | | CharType 9 | | UnsignedIntType 10 | | UnsignedLongLongType 11 | | LongLongType 12 | | UnsignedByteType 13 | | SizeTType 14 | | DoubleType 15 | | FunctionType 16 | override self.ToString() = 17 | match self with 18 | | GeneralType s -> s 19 | | StructType s -> "struct " + s 20 | | IntType -> "int" 21 | | VoidType -> "void" 22 | | CharType -> "char" 23 | | UnsignedIntType -> "unsigned" 24 | | UnsignedLongLongType -> "unsigned long long" 25 | | LongLongType -> "long long" 26 | | UnsignedByteType -> "uint8_t" 27 | | SizeTType -> "size_t" 28 | | DoubleType -> "double" 29 | | FunctionType -> "function" 30 | 31 | type CFullType = { 32 | baseType : CBaseType 33 | isConst : bool 34 | pointerDepth: int} with 35 | override x.ToString() = 36 | let mutable str = x.baseType.ToString () 37 | if x.isConst then 38 | str <- "const " + str 39 | for i = 0 to x.pointerDepth - 1 do 40 | str <- str + "*" 41 | str 42 | 43 | type CDef = 44 | | CFuncDef of CFullType * string * (CFullType * string option) list 45 | | CEnumDef of string * (string * int option) list 46 | | CStructDef of string 47 | | CTypeAlias of CFullType * string 48 | 49 | -------------------------------------------------------------------------------- /bindinggen/Lexer.fsl: -------------------------------------------------------------------------------- 1 | { 2 | module FSExternHelper.Lexer 3 | 4 | open FSExternHelper.Parser 5 | 6 | open System 7 | open Microsoft.FSharp.Text.Lexing 8 | 9 | //let lexeme (lb:LexBuffer) = System.Text.Encoding.ASCII.GetString(lb.Lexeme, 0, lb.Lexeme.Length) 10 | let lexeme (lb:LexBuffer) = new String(lb.Lexeme) 11 | 12 | let nextLine (lb:LexBuffer<_>) = lb.EndPos <- lb.EndPos.NextLine 13 | let badToken (lb : LexBuffer<_>) = 14 | failwith (sprintf "Unexpected token near line %i" lb.StartPos.Line) 15 | } 16 | 17 | // These are some regular expression definitions 18 | let digit = ['0'-'9'] 19 | let alpha = ['a'-'z'] | ['A'-'Z'] 20 | let varHead = alpha | '_' 21 | let varTail = varHead | digit 22 | let whitespace = [' ' '\t' ] 23 | let newline = '\n' | '\r' '\n' 24 | let anyWhite = whitespace | newline 25 | 26 | rule tokenize = parse 27 | // Eat whitespace 28 | | newline { nextLine lexbuf; tokenize lexbuf } 29 | | whitespace { tokenize lexbuf } 30 | 31 | | "#ifdef" { tokenizeIfdef 0 lexbuf } 32 | | "/*" { multiLineComment lexbuf } 33 | | "//" { singleLineComment lexbuf } 34 | | '#' { tokenizeMacro lexbuf } 35 | 36 | // don't care about these 37 | | "LLVM_FOR_EACH_VALUE_SUBCLASS(LLVM_DECLARE_VALUE_CAST)" { tokenize lexbuf } 38 | 39 | | "typedef" { TYPEDEF } 40 | | "enum" { ENUM } 41 | | "struct" { STRUCT } 42 | | "static" { STATIC } 43 | | "inline" { INLINE } 44 | 45 | | ';' { SEMICOL } 46 | | ',' { COMMA } 47 | | '*' { ASTER } 48 | | '(' { LPAREN } 49 | | ')' { RPAREN } 50 | | '{' { LCURL } 51 | | '}' { RCURL } 52 | | '[' { LSQUARE } 53 | | ']' { RSQUARE } 54 | | '=' { EQ } 55 | | "<<" { SHIFTL } 56 | 57 | | "const" { CONST } 58 | | "void" { VOID } 59 | | "char" { CHAR } 60 | | "int" { INT } 61 | | "long" { LONG } 62 | | "double" { DOUBLE } 63 | | "float" { FLOAT } 64 | | "unsigned" { UNSIGNED } 65 | | "short" { SHORT } 66 | | "uint8_t" { UINT8 } 67 | | "uint64_t" { UINT64 } 68 | | "size_t" { SIZE_T } 69 | 70 | | varHead varTail* { NAME (lexeme lexbuf) } 71 | 72 | // Numeric constants 73 | | ['-']?digit+ { INTCONST (Int32.Parse(lexeme lexbuf)) } 74 | //| ['-']?digit+('.'digit+)? { FLOAT (Double.Parse(lexeme lexbuf)) } 75 | 76 | // EOF 77 | | eof { EOF } 78 | 79 | | _ { badToken lexbuf } 80 | 81 | and multiLineComment = parse 82 | | newline { nextLine lexbuf; multiLineComment lexbuf } 83 | | "*/" { tokenize lexbuf } 84 | | _ { multiLineComment lexbuf } 85 | 86 | and singleLineComment = parse 87 | | newline { nextLine lexbuf; tokenize lexbuf } 88 | | _ { singleLineComment lexbuf } 89 | 90 | and tokenizeMacro = parse 91 | | '\\' newline { nextLine lexbuf; tokenizeMacro lexbuf } 92 | | newline { nextLine lexbuf; tokenize lexbuf } 93 | | _ { tokenizeMacro lexbuf } 94 | 95 | and tokenizeIfdef n = parse 96 | | "#endif" { if n = 0 then tokenize lexbuf else tokenizeIfdef (n - 1) lexbuf } 97 | | "#if" { tokenizeIfdef (n + 1) lexbuf } 98 | | newline { nextLine lexbuf; tokenizeIfdef n lexbuf } 99 | | _ { tokenizeIfdef n lexbuf } 100 | 101 | -------------------------------------------------------------------------------- /bindinggen/Lexing.fs: -------------------------------------------------------------------------------- 1 | // (c) Microsoft Corporation 2005-2009. 2 | 3 | #nowarn "47" // recursive initialization of LexBuffer 4 | 5 | 6 | #if INTERNALIZED_POWER_PACK 7 | namespace Internal.Utilities.Text.Lexing 8 | 9 | #else 10 | namespace Microsoft.FSharp.Text.Lexing 11 | #endif 12 | 13 | open System.Collections.Generic 14 | 15 | // REVIEW: This type showed up on a parsing-intensive performance measurement. Consider whether it can be a struct-record later when we have this feature. -jomo 16 | #if INTERNALIZED_POWER_PACK 17 | type internal Position = 18 | #else 19 | type Position = 20 | #endif 21 | { pos_fname : string; 22 | pos_lnum : int; 23 | #if INTERNALIZED_POWER_PACK 24 | pos_orig_lnum : int; 25 | #endif 26 | pos_bol : int; 27 | pos_cnum : int; } 28 | member x.FileName = x.pos_fname 29 | member x.Line = x.pos_lnum 30 | #if INTERNALIZED_POWER_PACK 31 | member x.OriginalLine = x.pos_orig_lnum 32 | #endif 33 | member x.Char = x.pos_cnum 34 | member x.AbsoluteOffset = x.pos_cnum 35 | member x.StartOfLine = x.pos_bol 36 | member x.StartOfLineAbsoluteOffset = x.pos_bol 37 | member x.Column = x.pos_cnum - x.pos_bol 38 | member pos.NextLine = 39 | { pos with 40 | #if INTERNALIZED_POWER_PACK 41 | pos_orig_lnum = pos.OriginalLine + 1; 42 | #endif 43 | pos_lnum = pos.Line+1; 44 | pos_bol = pos.AbsoluteOffset } 45 | member pos.EndOfToken(n) = {pos with pos_cnum=pos.pos_cnum + n } 46 | member pos.AsNewLinePos() = pos.NextLine 47 | member pos.ShiftColumnBy(by) = {pos with pos_cnum = pos.pos_cnum + by} 48 | static member Empty = 49 | { pos_fname=""; 50 | pos_lnum= 0; 51 | #if INTERNALIZED_POWER_PACK 52 | pos_orig_lnum = 0; 53 | #endif 54 | pos_bol= 0; 55 | pos_cnum=0 } 56 | static member FirstLine(filename) = 57 | { pos_fname=filename; 58 | #if INTERNALIZED_POWER_PACK 59 | pos_orig_lnum = 1; 60 | #endif 61 | pos_lnum= 1; 62 | pos_bol= 0; 63 | pos_cnum=0 } 64 | 65 | #if INTERNALIZED_POWER_PACK 66 | type internal LexBufferFiller<'char> = 67 | #else 68 | type LexBufferFiller<'char> = 69 | #endif 70 | { fillSync : (LexBuffer<'char> -> unit) option 71 | fillAsync : (LexBuffer<'char> -> Async) option } 72 | 73 | and [] 74 | #if INTERNALIZED_POWER_PACK 75 | internal LexBuffer<'char>(filler: LexBufferFiller<'char>) as this = 76 | #else 77 | LexBuffer<'char>(filler: LexBufferFiller<'char>) as this = 78 | #endif 79 | let context = new Dictionary(1) in 80 | let extendBufferSync = (fun () -> match filler.fillSync with Some refill -> refill this | None -> invalidOp "attempt to read synchronously from an asynchronous lex buffer") 81 | let extendBufferAsync = (fun () -> match filler.fillAsync with Some refill -> refill this | None -> invalidOp "attempt to read asynchronously from a synchronous lex buffer") 82 | let mutable buffer=[||]; 83 | /// number of valid charactes beyond bufferScanStart 84 | let mutable bufferMaxScanLength=0; 85 | /// count into the buffer when scanning 86 | let mutable bufferScanStart=0; 87 | /// number of characters scanned so far 88 | let mutable bufferScanLength=0; 89 | /// length of the scan at the last accepting state 90 | let mutable lexemeLength=0; 91 | /// action related to the last accepting state 92 | let mutable bufferAcceptAction=0; 93 | let mutable eof = false; 94 | let mutable startPos = Position.Empty ; 95 | let mutable endPos = Position.Empty 96 | 97 | // Throw away all the input besides the lexeme 98 | 99 | let discardInput () = 100 | let keep = Array.sub buffer bufferScanStart bufferScanLength 101 | let nkeep = keep.Length 102 | Array.blit keep 0 buffer 0 nkeep; 103 | bufferScanStart <- 0; 104 | bufferMaxScanLength <- nkeep 105 | 106 | 107 | member lexbuf.EndOfScan () : int = 108 | // Printf.eprintf "endOfScan, lexBuffer.lexemeLength = %d\n" lexBuffer.lexemeLength; 109 | if bufferAcceptAction < 0 then 110 | failwith "unrecognized input" 111 | 112 | // Printf.printf "endOfScan %d state %d on unconsumed input '%c' (%d)\n" a s (Char.chr inp) inp; 113 | // Printf.eprintf "accept, lexeme = %s\n" (lexeme lexBuffer); 114 | lexbuf.StartPos <- endPos; 115 | lexbuf.EndPos <- endPos.EndOfToken(lexbuf.LexemeLength); 116 | bufferAcceptAction 117 | 118 | member lexbuf.StartPos 119 | with get() = startPos 120 | and set(b) = startPos <- b 121 | 122 | member lexbuf.EndPos 123 | with get() = endPos 124 | and set(b) = endPos <- b 125 | 126 | member lexbuf.Lexeme = Array.sub buffer bufferScanStart lexemeLength 127 | member lexbuf.LexemeChar(n) = buffer.[n+bufferScanStart] 128 | 129 | member lexbuf.BufferLocalStore = (context :> IDictionary<_,_>) 130 | member lexbuf.LexemeLength with get() : int = lexemeLength and set v = lexemeLength <- v 131 | member internal lexbuf.Buffer with get() : 'char[] = buffer and set v = buffer <- v 132 | member internal lexbuf.BufferMaxScanLength with get() = bufferMaxScanLength and set v = bufferMaxScanLength <- v 133 | member internal lexbuf.BufferScanLength with get() = bufferScanLength and set v = bufferScanLength <- v 134 | member internal lexbuf.BufferScanStart with get() : int = bufferScanStart and set v = bufferScanStart <- v 135 | member internal lexbuf.BufferAcceptAction with get() = bufferAcceptAction and set v = bufferAcceptAction <- v 136 | member internal lexbuf.RefillBuffer = extendBufferSync 137 | member internal lexbuf.AsyncRefillBuffer = extendBufferAsync 138 | 139 | static member LexemeString(lexbuf:LexBuffer) = 140 | new System.String(lexbuf.Buffer,lexbuf.BufferScanStart,lexbuf.LexemeLength) 141 | 142 | member lexbuf.IsPastEndOfStream 143 | with get() = eof 144 | and set(b) = eof <- b 145 | 146 | member lexbuf.DiscardInput() = discardInput () 147 | 148 | member x.BufferScanPos = bufferScanStart + bufferScanLength 149 | 150 | member lexbuf.EnsureBufferSize n = 151 | if lexbuf.BufferScanPos + n >= buffer.Length then 152 | let repl = Array.zeroCreate (lexbuf.BufferScanPos + n) 153 | Array.blit buffer bufferScanStart repl bufferScanStart bufferScanLength; 154 | buffer <- repl 155 | 156 | static member FromReadFunctions (syncRead : ('char[] * int * int -> int) option, asyncRead : ('char[] * int * int -> Async) option) : LexBuffer<'char> = 157 | let extension= Array.zeroCreate 4096 158 | let fillers = 159 | { fillSync = 160 | match syncRead with 161 | | None -> None 162 | | Some read -> 163 | Some (fun lexBuffer -> 164 | let n = read(extension,0,extension.Length) 165 | lexBuffer.EnsureBufferSize n; 166 | Array.blit extension 0 lexBuffer.Buffer lexBuffer.BufferScanPos n; 167 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferScanLength + n); 168 | fillAsync = 169 | match asyncRead with 170 | | None -> None 171 | | Some read -> 172 | Some (fun lexBuffer -> 173 | async { 174 | let! n = read(extension,0,extension.Length) 175 | lexBuffer.EnsureBufferSize n; 176 | Array.blit extension 0 lexBuffer.Buffer lexBuffer.BufferScanPos n; 177 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferScanLength + n }) } 178 | new LexBuffer<_>(fillers) 179 | 180 | // A full type signature is required on this method because it is used at more specific types within its own scope 181 | static member FromFunction (f : 'char[] * int * int -> int) : LexBuffer<'char> = LexBuffer<_>.FromReadFunctions(Some(f),None) 182 | static member FromAsyncFunction (f : 'char[] * int * int -> Async) : LexBuffer<'char> = LexBuffer<_>.FromReadFunctions(None,Some(f)) 183 | 184 | static member FromCharFunction f : LexBuffer = 185 | LexBuffer.FromFunction(fun (buff,start,len) -> 186 | let buff2 = Array.zeroCreate len 187 | let n = f buff2 len 188 | Array.blit buff2 0 buff start len 189 | n) 190 | static member FromByteFunction f : LexBuffer = 191 | LexBuffer.FromFunction(fun (buff,start,len) -> 192 | let buff2 = Array.zeroCreate len 193 | let n = f buff2 len 194 | Array.blit buff2 0 buff start len 195 | n) 196 | 197 | // A full type signature is required on this method because it is used at more specific types within its own scope 198 | static member FromArray (s: 'char[]) : LexBuffer<'char> = 199 | let lexBuffer = 200 | new LexBuffer<_> 201 | { fillSync = Some (fun _ -> ()); 202 | fillAsync = Some (fun _ -> async { return () }) } 203 | let buffer = Array.copy s 204 | lexBuffer.Buffer <- buffer; 205 | lexBuffer.BufferMaxScanLength <- buffer.Length; 206 | lexBuffer 207 | 208 | static member FromBytes (arr) = LexBuffer.FromArray(arr) 209 | static member FromChars (arr) = LexBuffer.FromArray(arr) 210 | static member FromString (s:string) = LexBuffer.FromChars (s.ToCharArray()) 211 | 212 | static member FromTextReader (tr:System.IO.TextReader) : LexBuffer = 213 | LexBuffer.FromFunction(tr.Read) 214 | 215 | static member FromBinaryReader (br:System.IO.BinaryReader) : LexBuffer = 216 | LexBuffer.FromFunction(br.Read) 217 | 218 | static member FromStream (stream:System.IO.Stream) : LexBuffer = 219 | LexBuffer.FromReadFunctions(Some(stream.Read),Some(fun (buf,offset,len) -> stream.AsyncRead(buf,offset=offset,count=len))) 220 | 221 | module GenericImplFragments = 222 | let startInterpret(lexBuffer:LexBuffer<_>)= 223 | lexBuffer.BufferScanStart <- lexBuffer.BufferScanStart + lexBuffer.LexemeLength; 224 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferMaxScanLength - lexBuffer.LexemeLength; 225 | lexBuffer.BufferScanLength <- 0; 226 | lexBuffer.LexemeLength <- 0; 227 | lexBuffer.BufferAcceptAction <- -1; 228 | 229 | let afterRefill (trans: uint16[] array,sentinel,lexBuffer:LexBuffer<_>,scanUntilSentinel,endOfScan,state,eofPos) = 230 | // end of file occurs if we couldn't extend the buffer 231 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 232 | let snew = int trans.[state].[eofPos] // == EOF 233 | if snew = sentinel then 234 | endOfScan() 235 | else 236 | if lexBuffer.IsPastEndOfStream then failwith "End of file on lexing stream"; 237 | lexBuffer.IsPastEndOfStream <- true; 238 | // Printf.printf "state %d --> %d on eof\n" state snew; 239 | scanUntilSentinel(lexBuffer,snew) 240 | else 241 | scanUntilSentinel(lexBuffer, state) 242 | 243 | let onAccept (lexBuffer:LexBuffer<_>,a) = 244 | lexBuffer.LexemeLength <- lexBuffer.BufferScanLength; 245 | lexBuffer.BufferAcceptAction <- a; 246 | 247 | open GenericImplFragments 248 | 249 | [] 250 | #if INTERNALIZED_POWER_PACK 251 | type internal AsciiTables(trans: uint16[] array, accept: uint16[]) = 252 | #else 253 | type AsciiTables(trans: uint16[] array, accept: uint16[]) = 254 | #endif 255 | let rec scanUntilSentinel(lexBuffer, state) = 256 | let sentinel = 255 * 256 + 255 257 | // Return an endOfScan after consuming the input 258 | let a = int accept.[state] 259 | if a <> sentinel then 260 | onAccept (lexBuffer,a) 261 | 262 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 263 | lexBuffer.DiscardInput(); 264 | lexBuffer.RefillBuffer (); 265 | // end of file occurs if we couldn't extend the buffer 266 | afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,lexBuffer.EndOfScan,state,256 (* == EOF *) ) 267 | else 268 | // read a character - end the scan if there are no further transitions 269 | let inp = int(lexBuffer.Buffer.[lexBuffer.BufferScanPos]) 270 | let snew = int trans.[state].[inp] 271 | if snew = sentinel then 272 | lexBuffer.EndOfScan() 273 | else 274 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 275 | // Printf.printf "state %d --> %d on '%c' (%d)\n" state snew (Char.chr inp) inp; 276 | scanUntilSentinel(lexBuffer, snew) 277 | 278 | /// Interpret tables for an ascii lexer generated by fslex. 279 | member tables.Interpret(initialState,lexBuffer : LexBuffer) = 280 | startInterpret(lexBuffer) 281 | scanUntilSentinel(lexBuffer, initialState) 282 | 283 | /// Interpret tables for an ascii lexer generated by fslex. 284 | member tables.AsyncInterpret(initialState,lexBuffer : LexBuffer) = 285 | 286 | let rec scanUntilSentinel(lexBuffer,state) : Async = 287 | async { 288 | let sentinel = 255 * 256 + 255 289 | // Return an endOfScan after consuming the input 290 | let a = int accept.[state] 291 | if a <> sentinel then 292 | onAccept (lexBuffer,a) 293 | 294 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 295 | lexBuffer.DiscardInput(); 296 | do! lexBuffer.AsyncRefillBuffer (); 297 | // end of file occurs if we couldn't extend the buffer 298 | return! afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,endOfScan,state,256 (* == EOF *) ) 299 | else 300 | // read a character - end the scan if there are no further transitions 301 | let inp = int(lexBuffer.Buffer.[lexBuffer.BufferScanPos]) 302 | let snew = int trans.[state].[inp] 303 | if snew = sentinel then 304 | return! endOfScan() 305 | else 306 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 307 | return! scanUntilSentinel(lexBuffer,snew) 308 | } 309 | and endOfScan() = 310 | async { return lexBuffer.EndOfScan() } 311 | startInterpret(lexBuffer) 312 | scanUntilSentinel(lexBuffer, initialState) 313 | 314 | 315 | static member Create(trans,accept) = new AsciiTables(trans,accept) 316 | 317 | [] 318 | #if INTERNALIZED_POWER_PACK 319 | type internal UnicodeTables(trans: uint16[] array, accept: uint16[]) = 320 | #else 321 | type UnicodeTables(trans: uint16[] array, accept: uint16[]) = 322 | #endif 323 | let sentinel = 255 * 256 + 255 324 | let numUnicodeCategories = 30 325 | let numLowUnicodeChars = 128 326 | let numSpecificUnicodeChars = (trans.[0].Length - 1 - numLowUnicodeChars - numUnicodeCategories)/2 327 | let lookupUnicodeCharacters (state,inp) = 328 | let inpAsInt = int inp 329 | // Is it a fast ASCII character? 330 | if inpAsInt < numLowUnicodeChars then 331 | int trans.[state].[inpAsInt] 332 | else 333 | // Search for a specific unicode character 334 | let baseForSpecificUnicodeChars = numLowUnicodeChars 335 | let rec loop i = 336 | if i >= numSpecificUnicodeChars then 337 | // OK, if we failed then read the 'others' entry in the alphabet, 338 | // which covers all Unicode characters not covered in other 339 | // ways 340 | let baseForUnicodeCategories = numLowUnicodeChars+numSpecificUnicodeChars*2 341 | let unicodeCategory = System.Char.GetUnicodeCategory(inp) 342 | //System.Console.WriteLine("inp = {0}, unicodeCategory = {1}", [| box inp; box unicodeCategory |]); 343 | int trans.[state].[baseForUnicodeCategories + int32 unicodeCategory] 344 | else 345 | // This is the specific unicode character 346 | let c = char (int trans.[state].[baseForSpecificUnicodeChars+i*2]) 347 | //System.Console.WriteLine("c = {0}, inp = {1}, i = {2}", [| box c; box inp; box i |]); 348 | // OK, have we found the entry for a specific unicode character? 349 | if c = inp 350 | then int trans.[state].[baseForSpecificUnicodeChars+i*2+1] 351 | else loop(i+1) 352 | 353 | loop 0 354 | let eofPos = numLowUnicodeChars + 2*numSpecificUnicodeChars + numUnicodeCategories 355 | 356 | let rec scanUntilSentinel(lexBuffer,state) = 357 | // Return an endOfScan after consuming the input 358 | let a = int accept.[state] 359 | if a <> sentinel then 360 | onAccept(lexBuffer,a) 361 | 362 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 363 | lexBuffer.DiscardInput(); 364 | lexBuffer.RefillBuffer (); 365 | // end of file occurs if we couldn't extend the buffer 366 | afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,lexBuffer.EndOfScan,state,eofPos) 367 | else 368 | // read a character - end the scan if there are no further transitions 369 | let inp = lexBuffer.Buffer.[lexBuffer.BufferScanPos] 370 | 371 | // Find the new state 372 | let snew = lookupUnicodeCharacters (state,inp) 373 | 374 | if snew = sentinel then 375 | lexBuffer.EndOfScan() 376 | else 377 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 378 | // Printf.printf "state %d --> %d on '%c' (%d)\n" s snew (char inp) inp; 379 | scanUntilSentinel(lexBuffer,snew) 380 | 381 | // Each row for the Unicode table has format 382 | // 128 entries for ASCII characters 383 | // A variable number of 2*UInt16 entries for SpecificUnicodeChars 384 | // 30 entries, one for each UnicodeCategory 385 | // 1 entry for EOF 386 | 387 | member tables.Interpret(initialState,lexBuffer : LexBuffer) = 388 | startInterpret(lexBuffer) 389 | scanUntilSentinel(lexBuffer, initialState) 390 | 391 | member tables.AsyncInterpret(initialState,lexBuffer : LexBuffer) = 392 | 393 | let rec scanUntilSentinel(lexBuffer, state) = 394 | async { 395 | // Return an endOfScan after consuming the input 396 | let a = int accept.[state] 397 | if a <> sentinel then 398 | onAccept(lexBuffer,a) 399 | 400 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 401 | lexBuffer.DiscardInput(); 402 | lexBuffer.RefillBuffer (); 403 | // end of file occurs if we couldn't extend the buffer 404 | return! afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,endOfScan,state,eofPos) 405 | else 406 | // read a character - end the scan if there are no further transitions 407 | let inp = lexBuffer.Buffer.[lexBuffer.BufferScanPos] 408 | 409 | // Find the new state 410 | let snew = lookupUnicodeCharacters (state,inp) 411 | 412 | if snew = sentinel then 413 | return! endOfScan() 414 | else 415 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 416 | return! scanUntilSentinel(lexBuffer, snew) 417 | } 418 | and endOfScan() = 419 | async { return lexBuffer.EndOfScan() } 420 | startInterpret(lexBuffer) 421 | scanUntilSentinel(lexBuffer, initialState) 422 | 423 | static member Create(trans,accept) = new UnicodeTables(trans,accept) 424 | -------------------------------------------------------------------------------- /bindinggen/Lexing.fsi: -------------------------------------------------------------------------------- 1 | //========================================================================== 2 | // LexBuffers are for use with automatically generated lexical analyzers, 3 | // in particular those produced by 'fslex'. 4 | // 5 | // (c) Microsoft Corporation 2005-2008. 6 | //=========================================================================== 7 | 8 | #if INTERNALIZED_POWER_PACK 9 | namespace Internal.Utilities.Text.Lexing 10 | #else 11 | namespace Microsoft.FSharp.Text.Lexing 12 | #endif 13 | 14 | open System.Collections.Generic 15 | 16 | /// Position information stored for lexing tokens 17 | // 18 | // Note: this is an OCaml compat record type. 19 | #if INTERNALIZED_POWER_PACK 20 | type internal Position = 21 | #else 22 | type Position = 23 | #endif 24 | { /// The file name for the position 25 | pos_fname: string; 26 | /// The line number for the position 27 | pos_lnum: int; 28 | #if INTERNALIZED_POWER_PACK 29 | /// The line number for the position in the original source file 30 | pos_orig_lnum : int; 31 | #endif 32 | /// The absolute offset of the beginning of the line 33 | pos_bol: int; 34 | /// The absolute offset of the column for the position 35 | pos_cnum: int; } 36 | /// The file name associated with the input stream. 37 | member FileName : string 38 | /// The line number in the input stream, assuming fresh positions have been updated 39 | /// using AsNewLinePos() and by modifying the EndPos property of the LexBuffer. 40 | member Line : int 41 | #if INTERNALIZED_POWER_PACK 42 | /// The line number for the position in the input stream, assuming fresh positions have been updated 43 | /// using AsNewLinePos() 44 | member OriginalLine : int 45 | #endif 46 | [] 47 | member Char : int 48 | /// The character number in the input stream 49 | member AbsoluteOffset : int 50 | /// Return absolute offset of the start of the line marked by the position 51 | member StartOfLineAbsoluteOffset : int 52 | /// Return the column number marked by the position, i.e. the difference between the AbsoluteOffset and the StartOfLineAbsoluteOffset 53 | member Column : int 54 | // Given a position just beyond the end of a line, return a position at the start of the next line 55 | member NextLine : Position 56 | 57 | /// Given a position at the start of a token of length n, return a position just beyond the end of the token 58 | member EndOfToken: n:int -> Position 59 | /// Gives a position shifted by specified number of characters 60 | member ShiftColumnBy: by:int -> Position 61 | 62 | [] 63 | member AsNewLinePos : unit -> Position 64 | 65 | /// Get an arbitrary position, with the empty string as filename, and 66 | static member Empty : Position 67 | 68 | /// Get a position corresponding to the first line (line number 1) in a given file 69 | static member FirstLine : filename:string -> Position 70 | 71 | [] 72 | #if INTERNALIZED_POWER_PACK 73 | type internal LexBuffer<'char> = 74 | #else 75 | /// Input buffers consumed by lexers generated by fslex.exe 76 | type LexBuffer<'char> = 77 | #endif 78 | /// The start position for the lexeme 79 | member StartPos: Position with get,set 80 | /// The end position for the lexeme 81 | member EndPos: Position with get,set 82 | /// The matched string 83 | member Lexeme: 'char array 84 | 85 | /// Fast helper to turn the matched characters into a string, avoiding an intermediate array 86 | static member LexemeString : LexBuffer -> string 87 | 88 | /// The length of the matched string 89 | member LexemeLength: int 90 | /// Fetch a particular character in the matched string 91 | member LexemeChar: int -> 'char 92 | 93 | /// Dynamically typed, non-lexically scoped parameter table 94 | member BufferLocalStore : IDictionary 95 | 96 | /// True if the refill of the buffer ever failed , or if explicitly set to true. 97 | member IsPastEndOfStream: bool with get,set 98 | /// Remove all input, though don't discard the current lexeme 99 | member DiscardInput: unit -> unit 100 | 101 | /// Create a lex buffer suitable for byte lexing that reads characters from the given array 102 | static member FromBytes: byte[] -> LexBuffer 103 | /// Create a lex buffer suitable for Unicode lexing that reads characters from the given array 104 | static member FromChars: char[] -> LexBuffer 105 | /// Create a lex buffer suitable for Unicode lexing that reads characters from the given string 106 | static member FromString: string -> LexBuffer 107 | /// Create a lex buffer that reads character or byte inputs by using the given function 108 | static member FromFunction: ('char[] * int * int -> int) -> LexBuffer<'char> 109 | /// Create a lex buffer that asynchronously reads character or byte inputs by using the given function 110 | static member FromAsyncFunction: ('char[] * int * int -> Async) -> LexBuffer<'char> 111 | 112 | 113 | [.FromFunction instead")>] 114 | static member FromCharFunction: (char[] -> int -> int) -> LexBuffer 115 | [.FromFunction instead")>] 116 | static member FromByteFunction: (byte[] -> int -> int) -> LexBuffer 117 | 118 | /// Create a lex buffer suitable for use with a Unicode lexer that reads character inputs from the given text reader 119 | static member FromTextReader: System.IO.TextReader -> LexBuffer 120 | /// Create a lex buffer suitable for use with ASCII byte lexing that reads byte inputs from the given binary reader 121 | static member FromBinaryReader: System.IO.BinaryReader -> LexBuffer 122 | 123 | 124 | /// The type of tables for an ascii lexer generated by fslex. 125 | [] 126 | #if INTERNALIZED_POWER_PACK 127 | type internal AsciiTables = 128 | #else 129 | type AsciiTables = 130 | #endif 131 | static member Create : uint16[] array * uint16[] -> AsciiTables 132 | /// Interpret tables for an ascii lexer generated by fslex. 133 | member Interpret: initialState:int * LexBuffer -> int 134 | /// Interpret tables for an ascii lexer generated by fslex, processing input asynchronously 135 | member AsyncInterpret: initialState:int * LexBuffer -> Async 136 | 137 | 138 | /// The type of tables for an unicode lexer generated by fslex. 139 | [] 140 | #if INTERNALIZED_POWER_PACK 141 | type internal UnicodeTables = 142 | #else 143 | type UnicodeTables = 144 | #endif 145 | static member Create : uint16[] array * uint16[] -> UnicodeTables 146 | /// Interpret tables for a unicode lexer generated by fslex. 147 | member Interpret: initialState:int * LexBuffer -> int 148 | 149 | /// Interpret tables for a unicode lexer generated by fslex, processing input asynchronously 150 | member AsyncInterpret: initialState:int * LexBuffer -> Async 151 | 152 | -------------------------------------------------------------------------------- /bindinggen/Parser.fsy: -------------------------------------------------------------------------------- 1 | %{ 2 | open Microsoft.FSharp.Text.Parsing 3 | open FSExternHelper.HeaderSyntax 4 | 5 | // NOTE: fsyacc expects this function to be named parse_error_rich 6 | let parse_error_rich = 7 | let parseError (errorContext : ParseErrorContext<_>) = 8 | let fstResultRange = fst errorContext.ParseState.ResultRange 9 | match fstResultRange :> obj with 10 | | null -> eprintfn "Parse error near start of file" 11 | | _ -> eprintfn "Parse error near line %i" fstResultRange.Line 12 | 13 | exit 1 14 | 15 | Some parseError 16 | 17 | let normArgs = function 18 | | [({CFullType.baseType = VoidType; CFullType.pointerDepth = 0}, _)] -> [] 19 | | args -> args 20 | 21 | %} 22 | 23 | // The start token becomes a parser function in the compiled code: 24 | %start start 25 | 26 | // These are the terminal tokens of the grammar along with the types of 27 | // the data carried by each token: 28 | %token INTCONST 29 | %token NAME 30 | %token SEMICOL COMMA ASTER LPAREN RPAREN EOF LCURL RCURL LSQUARE RSQUARE 31 | %token STRUCT ENUM TYPEDEF EQ SHIFTL 32 | %token CONST VOID CHAR INT LONG DOUBLE FLOAT UNSIGNED SHORT UINT8 UINT64 SIZE_T STATIC INLINE 33 | 34 | // This is the type of the data produced by a successful reduction of the 'start' 35 | // symbol: 36 | %type < CDef list > start 37 | 38 | %% 39 | 40 | start: Defs { $1 } 41 | 42 | Defs: 43 | | Def Defs { match $1 with Some x -> x :: $2 | None -> $2 } 44 | | EOF { [] } 45 | 46 | Def: 47 | | FuncDef { $1 } 48 | | TYPEDEF ENUM LCURL EnumVals RCURL NAME SEMICOL { Some (CEnumDef ($6, $4)) } 49 | | ENUM NAME LCURL EnumVals RCURL SEMICOL { Some (CEnumDef ($2, $4)) } 50 | | TYPEDEF HackType NAME SEMICOL { Some (CTypeAlias ($2, $3)) } 51 | | FuncPointerTypedef { $1 } 52 | | STRUCT NAME LCURL StructMemDefs RCURL SEMICOL { Some (CStructDef $2) } 53 | 54 | StructMemDefs: 55 | | StructMemDef StructMemDefs { } 56 | | { } 57 | 58 | StructMemDef: 59 | | HackType NAME SEMICOL { } 60 | 61 | FuncDef: 62 | | STATIC INLINE HackType NAME LPAREN Params RPAREN LCURL RCURL 63 | { None } 64 | | HackType NAME LPAREN Params RPAREN SEMICOL 65 | { Some (CFuncDef ($1, $2, normArgs $4)) } 66 | 67 | FuncPointerTypedef: 68 | | TYPEDEF FullType LPAREN ASTER NAME RPAREN LPAREN Params RPAREN SEMICOL 69 | { Some (CTypeAlias ({baseType = FunctionType; isConst = true; pointerDepth = 1}, $5)) } 70 | 71 | EnumVals: 72 | | EnumVal COMMA EnumVals { $1 :: $3 } 73 | | EnumVal { [$1] } 74 | 75 | EnumVal: 76 | | NAME { ($1, None) } 77 | | NAME EQ IntVal { ($1, Some $3) } 78 | 79 | IntVal: 80 | | INTCONST SHIFTL INTCONST { $1 <<< $3 } 81 | | INTCONST { $1 } 82 | 83 | HackType: 84 | | FullType { $1 } 85 | // HACK! 86 | | FullType CONST ASTER 87 | { {$1 with pointerDepth = ($1).pointerDepth + 1} } 88 | 89 | FullType: 90 | | CONST BaseType Pointers { {baseType = $2; isConst = true; pointerDepth = $3} } 91 | | BaseType Pointers { {baseType = $1; isConst = false; pointerDepth = $2} } 92 | 93 | Pointers: 94 | | ASTER Pointers { $2 + 1 } 95 | | { 0 } 96 | 97 | BaseType: 98 | | NAME { GeneralType $1 } 99 | | ENUM NAME { GeneralType $2 } 100 | | STRUCT NAME { StructType $2 } 101 | | INT { IntType } 102 | | VOID { VoidType } 103 | | CHAR { CharType } 104 | | UNSIGNED LONG LONG { UnsignedLongLongType } 105 | | LONG LONG { LongLongType } 106 | | UNSIGNED { UnsignedIntType } 107 | | UINT8 { UnsignedByteType } 108 | | UINT64 { UnsignedLongLongType } 109 | | SIZE_T { SizeTType } 110 | | DOUBLE { DoubleType } 111 | 112 | Params: 113 | | Param COMMA Params { $1 :: $3 } 114 | | Param { [$1] } 115 | | { [] } 116 | 117 | Param: 118 | | ParamNoArray { $1 } 119 | | ParamNoArray LSQUARE RSQUARE 120 | { match $1 with (ty, name) -> ({ty with pointerDepth = ty.pointerDepth + 1}, name) } 121 | 122 | ParamNoArray: 123 | | HackType NAME { ($1, Some $2) } 124 | | HackType { ($1, None) } 125 | 126 | -------------------------------------------------------------------------------- /bindinggen/Parsing.fs: -------------------------------------------------------------------------------- 1 | // (c) Microsoft Corporation 2005-2009. 2 | 3 | #if INTERNALIZED_POWER_PACK 4 | 5 | namespace Internal.Utilities.Text.Parsing 6 | open Internal.Utilities 7 | open Internal.Utilities.Text.Lexing 8 | 9 | #else 10 | namespace Microsoft.FSharp.Text.Parsing 11 | open Microsoft.FSharp.Text.Lexing 12 | #endif 13 | 14 | 15 | 16 | open System 17 | open System.Collections.Generic 18 | 19 | #if INTERNALIZED_POWER_PACK 20 | type internal IParseState = 21 | #else 22 | type IParseState = 23 | #endif 24 | abstract InputRange: int -> Position * Position 25 | abstract InputEndPosition: int -> Position 26 | abstract InputStartPosition: int -> Position 27 | abstract ResultRange: Position * Position 28 | abstract GetInput: int -> obj 29 | abstract ParserLocalStore : IDictionary 30 | abstract RaiseError<'b> : unit -> 'b 31 | 32 | //------------------------------------------------------------------------- 33 | // This context is passed to the error reporter when a syntax error occurs 34 | 35 | [] 36 | #if INTERNALIZED_POWER_PACK 37 | type internal ParseErrorContext<'tok> 38 | #else 39 | type ParseErrorContext<'tok> 40 | #endif 41 | (//lexbuf: LexBuffer<_>, 42 | stateStack:int list, 43 | parseState: IParseState, 44 | reduceTokens: int list, 45 | currentToken: 'tok option, 46 | reducibleProductions: int list list, 47 | shiftableTokens: int list , 48 | message : string) = 49 | //member x.LexBuffer = lexbuf 50 | member x.StateStack = stateStack 51 | member x.ReduceTokens = reduceTokens 52 | member x.CurrentToken = currentToken 53 | member x.ParseState = parseState 54 | member x.ReducibleProductions = reducibleProductions 55 | member x.ShiftTokens = shiftableTokens 56 | member x.Message = message 57 | 58 | 59 | //------------------------------------------------------------------------- 60 | // This is the data structure emitted as code by FSYACC. 61 | 62 | #if INTERNALIZED_POWER_PACK 63 | type internal Tables<'tok> = 64 | #else 65 | type Tables<'tok> = 66 | #endif 67 | { reductions: (IParseState -> obj) array; 68 | endOfInputTag: int; 69 | tagOfToken: 'tok -> int; 70 | dataOfToken: 'tok -> obj; 71 | actionTableElements: uint16[]; 72 | actionTableRowOffsets: uint16[]; 73 | reductionSymbolCounts: uint16[]; 74 | immediateActions: uint16[]; 75 | gotos: uint16[]; 76 | sparseGotoTableRowOffsets: uint16[]; 77 | stateToProdIdxsTableElements: uint16[]; 78 | stateToProdIdxsTableRowOffsets: uint16[]; 79 | productionToNonTerminalTable: uint16[]; 80 | /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function 81 | /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened 82 | /// at the top of the generated parser file) 83 | parseError: ParseErrorContext<'tok> -> unit; 84 | numTerminals: int; 85 | tagOfErrorTerminal: int } 86 | 87 | //------------------------------------------------------------------------- 88 | // An implementation of stacks. 89 | 90 | // This type is in System.dll so for the moment we can't use it in FSharp.Core.dll 91 | //type Stack<'a> = System.Collections.Generic.Stack<'a> 92 | 93 | #if INTERNALIZED_POWER_PACK 94 | type Stack<'a>(n) = 95 | #else 96 | type internal Stack<'a>(n) = 97 | #endif 98 | let mutable contents = Array.zeroCreate<'a>(n) 99 | let mutable count = 0 100 | 101 | member buf.Ensure newSize = 102 | let oldSize = Array.length contents 103 | if newSize > oldSize then 104 | let old = contents 105 | contents <- Array.zeroCreate (max newSize (oldSize * 2)); 106 | Array.blit old 0 contents 0 count; 107 | 108 | member buf.Count = count 109 | member buf.Pop() = count <- count - 1 110 | member buf.Peep() = contents.[count - 1] 111 | member buf.Top(n) = [ for x in contents.[max 0 (count-n)..count - 1] -> x ] |> List.rev 112 | member buf.Push(x) = 113 | buf.Ensure(count + 1); 114 | contents.[count] <- x; 115 | count <- count + 1 116 | 117 | member buf.IsEmpty = (count = 0) 118 | member buf.PrintStack() = 119 | for i = 0 to (count - 1) do 120 | System.Console.Write("{0}{1}",(contents.[i]),if i=count-1 then ":" else "-") 121 | 122 | exception RecoverableParseError 123 | exception Accept of obj 124 | 125 | #if DEBUG 126 | module Flags = 127 | let mutable debug = false 128 | #endif 129 | 130 | #if INTERNALIZED_POWER_PACK 131 | module internal Implementation = 132 | #else 133 | module Implementation = 134 | #endif 135 | 136 | // Definitions shared with fsyacc 137 | let anyMarker = 0xffff 138 | let shiftFlag = 0x0000 139 | let reduceFlag = 0x4000 140 | let errorFlag = 0x8000 141 | let acceptFlag = 0xc000 142 | let actionMask = 0xc000 143 | 144 | let actionValue action = action &&& (~~~ actionMask) 145 | let actionKind action = action &&& actionMask 146 | 147 | //------------------------------------------------------------------------- 148 | // Read the tables written by FSYACC. 149 | 150 | type AssocTable(elemTab:uint16[], offsetTab:uint16[]) = 151 | let cache = new Dictionary<_,_>(2000) 152 | 153 | member t.readAssoc (minElemNum,maxElemNum,defaultValueOfAssoc,keyToFind) = 154 | // do a binary chop on the table 155 | let elemNumber : int = (minElemNum+maxElemNum)/2 156 | if elemNumber = maxElemNum 157 | then defaultValueOfAssoc 158 | else 159 | let x = int elemTab.[elemNumber*2] 160 | if keyToFind = x then 161 | int elemTab.[elemNumber*2+1] 162 | elif keyToFind < x then t.readAssoc (minElemNum ,elemNumber,defaultValueOfAssoc,keyToFind) 163 | else t.readAssoc (elemNumber+1,maxElemNum,defaultValueOfAssoc,keyToFind) 164 | 165 | member t.Read(rowNumber ,keyToFind) = 166 | 167 | // First check the sparse lookaside table 168 | // Performance note: without this lookaside table the binary chop in readAssoc 169 | // takes up around 10% of of parsing time 170 | // for parsing intensive samples such as the bootstrapped F# compiler. 171 | // 172 | // Note: using a .NET Dictionary for this int -> int table looks like it could be sub-optimal. 173 | // Some other better sparse lookup table may be better. 174 | let mutable res = 0 175 | let cacheKey = (rowNumber <<< 16) ||| keyToFind 176 | let ok = cache.TryGetValue(cacheKey, &res) 177 | if ok then res 178 | else 179 | let headOfTable = int offsetTab.[rowNumber] 180 | let firstElemNumber = headOfTable + 1 181 | let numberOfElementsInAssoc = int elemTab.[headOfTable*2] 182 | let defaultValueOfAssoc = int elemTab.[headOfTable*2+1] 183 | let res = t.readAssoc (firstElemNumber,(firstElemNumber+numberOfElementsInAssoc),defaultValueOfAssoc,keyToFind) 184 | cache.[cacheKey] <- res 185 | res 186 | 187 | // Read all entries in the association table 188 | // Used during error recovery to find all valid entries in the table 189 | member x.ReadAll(n) = 190 | let headOfTable = int offsetTab.[n] 191 | let firstElemNumber = headOfTable + 1 192 | let numberOfElementsInAssoc = int32 elemTab.[headOfTable*2] 193 | let defaultValueOfAssoc = int elemTab.[headOfTable*2+1] 194 | [ for i in firstElemNumber .. (firstElemNumber+numberOfElementsInAssoc-1) -> 195 | (int elemTab.[i*2], int elemTab.[i*2+1]) ], defaultValueOfAssoc 196 | 197 | type IdxToIdxListTable(elemTab:uint16[], offsetTab:uint16[]) = 198 | 199 | // Read all entries in a row of the table 200 | member x.ReadAll(n) = 201 | let headOfTable = int offsetTab.[n] 202 | let firstElemNumber = headOfTable + 1 203 | let numberOfElements = int32 elemTab.[headOfTable] 204 | [ for i in firstElemNumber .. (firstElemNumber+numberOfElements-1) -> int elemTab.[i] ] 205 | 206 | //------------------------------------------------------------------------- 207 | // interpret the tables emitted by FSYACC. 208 | 209 | [] 210 | [] 211 | type ValueInfo = 212 | val value: obj 213 | val startPos: Position 214 | val endPos: Position 215 | new(value,startPos,endPos) = { value=value; startPos=startPos;endPos=endPos } 216 | 217 | let interpret (tables: Tables<'tok>) lexer (lexbuf : LexBuffer<_>) initialState = 218 | let localStore = new Dictionary() in 219 | localStore.["LexBuffer"] <- lexbuf; 220 | #if DEBUG 221 | if Flags.debug then System.Console.WriteLine("\nParser: interpret tables"); 222 | #endif 223 | let stateStack : Stack = new Stack<_>(100) 224 | stateStack.Push(initialState); 225 | let valueStack = new Stack(100) 226 | let mutable haveLookahead = false 227 | let mutable lookaheadToken = Unchecked.defaultof<'tok> 228 | let mutable lookaheadEndPos = Unchecked.defaultof 229 | let mutable lookaheadStartPos = Unchecked.defaultof 230 | let mutable finished = false 231 | // After an error occurs, we suppress errors until we've shifted three tokens in a row. 232 | let mutable errorSuppressionCountDown = 0 233 | 234 | // When we hit the end-of-file we don't fail straight away but rather keep permitting shift 235 | // and reduce against the last token in the token stream 20 times or until we've accepted 236 | // or exhausted the stack. This allows error recovery rules of the form 237 | // input : realInput EOF | realInput error EOF | error EOF 238 | // where consuming one EOF to trigger an error doesn't result in overall parse failure 239 | // catastrophe and the loss of intermediate results. 240 | // 241 | let mutable inEofCountDown = false 242 | let mutable eofCountDown = 20 // Number of EOFs to supply at the end for error recovery 243 | // The 100 here means a maximum of 100 elements for each rule 244 | let ruleStartPoss = (Array.zeroCreate 100 : Position array) 245 | let ruleEndPoss = (Array.zeroCreate 100 : Position array) 246 | let ruleValues = (Array.zeroCreate 100 : obj array) 247 | let lhsPos = (Array.zeroCreate 2 : Position array) 248 | let reductions = tables.reductions 249 | let actionTable = new AssocTable(tables.actionTableElements, tables.actionTableRowOffsets) 250 | let gotoTable = new AssocTable(tables.gotos, tables.sparseGotoTableRowOffsets) 251 | let stateToProdIdxsTable = new IdxToIdxListTable(tables.stateToProdIdxsTableElements, tables.stateToProdIdxsTableRowOffsets) 252 | 253 | let parseState = 254 | { new IParseState with 255 | member p.InputRange(n) = ruleStartPoss.[n-1], ruleEndPoss.[n-1]; 256 | member p.InputStartPosition(n) = ruleStartPoss.[n-1] 257 | member p.InputEndPosition(n) = ruleEndPoss.[n-1]; 258 | member p.GetInput(n) = ruleValues.[n-1]; 259 | member p.ResultRange = (lhsPos.[0], lhsPos.[1]); 260 | member p.ParserLocalStore = (localStore :> IDictionary<_,_>); 261 | member p.RaiseError() = raise RecoverableParseError (* NOTE: this binding tests the fairly complex logic associated with an object expression implementing a generic abstract method *) 262 | } 263 | 264 | #if DEBUG 265 | let report haveLookahead lookaheadToken = 266 | if haveLookahead then sprintf "%A" lookaheadToken 267 | else "[TBC]" 268 | #endif 269 | 270 | // Pop the stack until we can shift the 'error' token. If 'tokenOpt' is given 271 | // then keep popping until we can shift both the 'error' token and the token in 'tokenOpt'. 272 | // This is used at end-of-file to make sure we can shift both the 'error' token and the 'EOF' token. 273 | let rec popStackUntilErrorShifted(tokenOpt) = 274 | // Keep popping the stack until the "error" terminal is shifted 275 | #if DEBUG 276 | if Flags.debug then System.Console.WriteLine("popStackUntilErrorShifted"); 277 | #endif 278 | if stateStack.IsEmpty then 279 | #if DEBUG 280 | if Flags.debug then 281 | System.Console.WriteLine("state stack empty during error recovery - generating parse error"); 282 | #endif 283 | failwith "parse error"; 284 | 285 | let currState = stateStack.Peep() 286 | #if DEBUG 287 | if Flags.debug then 288 | System.Console.WriteLine("In state {0} during error recovery", currState); 289 | #endif 290 | 291 | let action = actionTable.Read(currState, tables.tagOfErrorTerminal) 292 | 293 | if actionKind action = shiftFlag && 294 | (match tokenOpt with 295 | | None -> true 296 | | Some(token) -> 297 | let nextState = actionValue action 298 | actionKind (actionTable.Read(nextState, tables.tagOfToken(token))) = shiftFlag) then 299 | 300 | #if DEBUG 301 | if Flags.debug then System.Console.WriteLine("shifting error, continuing with error recovery"); 302 | #endif 303 | let nextState = actionValue action 304 | // The "error" non terminal needs position information, though it tends to be unreliable. 305 | // Use the StartPos/EndPos from the lex buffer 306 | valueStack.Push(ValueInfo(box (), lexbuf.StartPos, lexbuf.EndPos)); 307 | stateStack.Push(nextState) 308 | else 309 | if valueStack.IsEmpty then 310 | failwith "parse error"; 311 | #if DEBUG 312 | if Flags.debug then 313 | System.Console.WriteLine("popping stack during error recovery"); 314 | #endif 315 | valueStack.Pop(); 316 | stateStack.Pop(); 317 | popStackUntilErrorShifted(tokenOpt) 318 | 319 | while not finished do 320 | if stateStack.IsEmpty then 321 | finished <- true 322 | else 323 | let state = stateStack.Peep() 324 | #if DEBUG 325 | if Flags.debug then (Console.Write("{0} value(state), state ",valueStack.Count); stateStack.PrintStack()) 326 | #endif 327 | let action = 328 | let immediateAction = int tables.immediateActions.[state] 329 | if not (immediateAction = anyMarker) then 330 | // Action has been pre-determined, no need to lookahead 331 | // Expecting it to be a Reduce action on a non-fakeStartNonTerminal ? 332 | immediateAction 333 | else 334 | // Lookahead required to determine action 335 | if not haveLookahead then 336 | if lexbuf.IsPastEndOfStream then 337 | // When the input runs out, keep supplying the last token for eofCountDown times 338 | if eofCountDown>0 then 339 | haveLookahead <- true 340 | eofCountDown <- eofCountDown - 1 341 | inEofCountDown <- true 342 | else 343 | haveLookahead <- false 344 | else 345 | lookaheadToken <- lexer lexbuf 346 | lookaheadStartPos <- lexbuf.StartPos 347 | lookaheadEndPos <- lexbuf.EndPos 348 | haveLookahead <- true; 349 | 350 | let tag = 351 | if haveLookahead then tables.tagOfToken lookaheadToken 352 | else tables.endOfInputTag 353 | 354 | // Printf.printf "state %d\n" state 355 | actionTable.Read(state,tag) 356 | 357 | let kind = actionKind action 358 | if kind = shiftFlag then ( 359 | if errorSuppressionCountDown > 0 then 360 | errorSuppressionCountDown <- errorSuppressionCountDown - 1; 361 | #if DEBUG 362 | if Flags.debug then Console.WriteLine("shifting, reduced errorRecoverylevel to {0}\n", errorSuppressionCountDown); 363 | #endif 364 | let nextState = actionValue action 365 | if not haveLookahead then failwith "shift on end of input!"; 366 | let data = tables.dataOfToken lookaheadToken 367 | valueStack.Push(ValueInfo(data, lookaheadStartPos, lookaheadEndPos)); 368 | stateStack.Push(nextState); 369 | #if DEBUG 370 | if Flags.debug then Console.WriteLine("shift/consume input {0}, shift to state {1}", report haveLookahead lookaheadToken, nextState); 371 | #endif 372 | haveLookahead <- false 373 | 374 | ) elif kind = reduceFlag then 375 | let prod = actionValue action 376 | let reduction = reductions.[prod] 377 | let n = int tables.reductionSymbolCounts.[prod] 378 | // pop the symbols, populate the values and populate the locations 379 | #if DEBUG 380 | if Flags.debug then Console.Write("reduce popping {0} values/states, lookahead {1}", n, report haveLookahead lookaheadToken); 381 | #endif 382 | for i = 0 to n - 1 do 383 | if valueStack.IsEmpty then failwith "empty symbol stack"; 384 | let topVal = valueStack.Peep() 385 | valueStack.Pop(); 386 | stateStack.Pop(); 387 | ruleValues.[(n-i)-1] <- topVal.value; 388 | ruleStartPoss.[(n-i)-1] <- topVal.startPos; 389 | ruleEndPoss.[(n-i)-1] <- topVal.endPos; 390 | if i = 0 then lhsPos.[1] <- topVal.endPos; 391 | if i = n - 1 then lhsPos.[0] <- topVal.startPos 392 | done; 393 | // Use the lookahead token to populate the locations if the rhs is empty 394 | if n = 0 then 395 | if haveLookahead then 396 | lhsPos.[0] <- lookaheadStartPos; 397 | lhsPos.[1] <- lookaheadEndPos; 398 | else 399 | lhsPos.[0] <- lexbuf.StartPos; 400 | lhsPos.[1] <- lexbuf.EndPos; 401 | try 402 | // Printf.printf "reduce %d\n" prod; 403 | let redResult = reduction parseState 404 | valueStack.Push(ValueInfo(redResult, lhsPos.[0], lhsPos.[1])); 405 | let currState = stateStack.Peep() 406 | let newGotoState = gotoTable.Read(int tables.productionToNonTerminalTable.[prod], currState) 407 | stateStack.Push(newGotoState) 408 | #if DEBUG 409 | if Flags.debug then Console.WriteLine(" goto state {0}", newGotoState) 410 | #endif 411 | with 412 | | Accept res -> 413 | finished <- true; 414 | valueStack.Push(ValueInfo(res, lhsPos.[0], lhsPos.[1])) 415 | | RecoverableParseError -> 416 | #if DEBUG 417 | if Flags.debug then Console.WriteLine("RecoverableParseErrorException...\n"); 418 | #endif 419 | popStackUntilErrorShifted(None); 420 | // User code raised a Parse_error. Don't report errors again until three tokens have been shifted 421 | errorSuppressionCountDown <- 3 422 | elif kind = errorFlag then ( 423 | #if DEBUG 424 | if Flags.debug then Console.Write("ErrorFlag... "); 425 | #endif 426 | // Silently discard inputs and don't report errors 427 | // until three tokens in a row have been shifted 428 | #if DEBUG 429 | if Flags.debug then printfn "error on token '%A' " (if haveLookahead then Some(lookaheadToken) else None); 430 | #endif 431 | if errorSuppressionCountDown > 0 then 432 | // If we're in the end-of-file count down then we're very keen to 'Accept'. 433 | // We can only do this by repeatedly popping the stack until we can shift both an 'error' token 434 | // and an EOF token. 435 | if inEofCountDown && eofCountDown < 10 then 436 | #if DEBUG 437 | if Flags.debug then printfn "poppin stack, lokking to shift both 'error' and that token, during end-of-file error recovery" ; 438 | #endif 439 | popStackUntilErrorShifted(if haveLookahead then Some(lookaheadToken) else None); 440 | 441 | // If we don't haveLookahead then the end-of-file count down is over and we have no further options. 442 | if not haveLookahead then 443 | failwith "parse error: unexpected end of file" 444 | 445 | #if DEBUG 446 | if Flags.debug then printfn "discarding token '%A' during error suppression" (if haveLookahead then Some(lookaheadToken) else None); 447 | #endif 448 | // Discard the token 449 | haveLookahead <- false 450 | // Try again to shift three tokens 451 | errorSuppressionCountDown <- 3 452 | else ( 453 | 454 | let currentToken = if haveLookahead then Some(lookaheadToken) else None 455 | let actions,defaultAction = actionTable.ReadAll(state) 456 | let explicit = Set.ofList [ for (tag,_action) in actions -> tag ] 457 | 458 | let shiftableTokens = 459 | [ for (tag,action) in actions do 460 | if (actionKind action) = shiftFlag then 461 | yield tag 462 | if actionKind defaultAction = shiftFlag then 463 | for tag in 0 .. tables.numTerminals-1 do 464 | if not (explicit.Contains(tag)) then 465 | yield tag ] in 466 | 467 | let stateStack = stateStack.Top(12) in 468 | let reducibleProductions = 469 | [ for state in stateStack do 470 | yield stateToProdIdxsTable.ReadAll(state) ] 471 | 472 | let reduceTokens = 473 | [ for (tag,action) in actions do 474 | if actionKind(action) = reduceFlag then 475 | yield tag 476 | if actionKind(defaultAction) = reduceFlag then 477 | for tag in 0 .. tables.numTerminals-1 do 478 | if not (explicit.Contains(tag)) then 479 | yield tag ] in 480 | //let activeRules = stateStack |> List.iter (fun state -> 481 | let errorContext = new ParseErrorContext<'tok>(stateStack,parseState, reduceTokens,currentToken,reducibleProductions, shiftableTokens, "syntax error") 482 | tables.parseError(errorContext); 483 | popStackUntilErrorShifted(None); 484 | errorSuppressionCountDown <- 3; 485 | #if DEBUG 486 | if Flags.debug then System.Console.WriteLine("generated syntax error and shifted error token, haveLookahead = {0}\n", haveLookahead); 487 | #endif 488 | ) 489 | ) elif kind = acceptFlag then 490 | finished <- true 491 | #if DEBUG 492 | else 493 | if Flags.debug then System.Console.WriteLine("ALARM!!! drop through case in parser"); 494 | #endif 495 | done; 496 | // OK, we're done - read off the overall generated value 497 | valueStack.Peep().value 498 | 499 | #if INTERNALIZED_POWER_PACK 500 | type internal Tables<'tok> with 501 | #else 502 | type Tables<'tok> with 503 | #endif 504 | member tables.Interpret (lexer,lexbuf,initialState) = 505 | Implementation.interpret tables lexer lexbuf initialState 506 | 507 | #if INTERNALIZED_POWER_PACK 508 | module internal ParseHelpers = 509 | #else 510 | module ParseHelpers = 511 | #endif 512 | let parse_error (_s:string) = () 513 | let parse_error_rich = (None : (ParseErrorContext<_> -> unit) option) 514 | -------------------------------------------------------------------------------- /bindinggen/Parsing.fsi: -------------------------------------------------------------------------------- 1 | //========================================================================== 2 | // (c) Microsoft Corporation 2005-2009. 3 | //========================================================================= 4 | 5 | #if INTERNALIZED_POWER_PACK 6 | namespace Internal.Utilities.Text.Parsing 7 | open Internal.Utilities 8 | open Internal.Utilities.Text.Lexing 9 | #else 10 | namespace Microsoft.FSharp.Text.Parsing 11 | open Microsoft.FSharp.Text.Lexing 12 | #endif 13 | 14 | open System.Collections.Generic 15 | 16 | #if INTERNALIZED_POWER_PACK 17 | type internal IParseState = 18 | #else 19 | /// The information accessible via the parseState value within parser actions. 20 | type IParseState = 21 | #endif 22 | /// Get the start and end position for the terminal or non-terminal at a given index matched by the production 23 | abstract InputRange: index:int -> Position * Position 24 | /// Get the end position for the terminal or non-terminal at a given index matched by the production 25 | abstract InputEndPosition: int -> Position 26 | /// Get the start position for the terminal or non-terminal at a given index matched by the production 27 | abstract InputStartPosition: int -> Position 28 | /// Get the full range of positions matched by the production 29 | abstract ResultRange: Position * Position 30 | /// Get the value produced by the terminal or non-terminal at the given position 31 | abstract GetInput : int -> obj 32 | /// Get the store of local values associated with this parser 33 | // Dynamically typed, non-lexically scoped local store 34 | abstract ParserLocalStore : IDictionary 35 | /// Raise an error in this parse context 36 | abstract RaiseError<'b> : unit -> 'b 37 | 38 | 39 | [] 40 | #if INTERNALIZED_POWER_PACK 41 | type internal ParseErrorContext<'tok> = 42 | #else 43 | /// The context provided when a parse error occurs 44 | type ParseErrorContext<'tok> = 45 | #endif 46 | /// The stack of state indexes active at the parse error 47 | member StateStack : int list 48 | /// The state active at the parse error 49 | member ParseState : IParseState 50 | /// The tokens that would cause a reduction at the parse error 51 | member ReduceTokens: int list 52 | /// The stack of productions that would be reduced at the parse error 53 | member ReducibleProductions : int list list 54 | /// The token that caused the parse error 55 | member CurrentToken : 'tok option 56 | /// The token that would cause a shift at the parse error 57 | member ShiftTokens : int list 58 | /// The message associated with the parse error 59 | member Message : string 60 | 61 | /// Tables generated by fsyacc 62 | #if INTERNALIZED_POWER_PACK 63 | type internal Tables<'tok> = 64 | #else 65 | /// The type of the tables contained in a file produced by the fsyacc.exe parser generator. 66 | type Tables<'tok> = 67 | #endif 68 | { /// The reduction table 69 | reductions: (IParseState -> obj) array ; 70 | /// The token number indicating the end of input 71 | endOfInputTag: int; 72 | /// A function to compute the tag of a token 73 | tagOfToken: 'tok -> int; 74 | /// A function to compute the data carried by a token 75 | dataOfToken: 'tok -> obj; 76 | /// The sparse action table elements 77 | actionTableElements: uint16[]; 78 | /// The sparse action table row offsets 79 | actionTableRowOffsets: uint16[]; 80 | /// The number of symbols for each reduction 81 | reductionSymbolCounts: uint16[]; 82 | /// The immediate action table 83 | immediateActions: uint16[]; 84 | /// The sparse goto table 85 | gotos: uint16[]; 86 | /// The sparse goto table row offsets 87 | sparseGotoTableRowOffsets: uint16[]; 88 | /// The sparse table for the productions active for each state 89 | stateToProdIdxsTableElements: uint16[]; 90 | /// The sparse table offsets for the productions active for each state 91 | stateToProdIdxsTableRowOffsets: uint16[]; 92 | /// This table is logically part of the Goto table 93 | productionToNonTerminalTable: uint16[]; 94 | /// This function is used to hold the user specified "parse_error" or "parse_error_rich" functions 95 | parseError: ParseErrorContext<'tok> -> unit; 96 | /// The total number of terminals 97 | numTerminals: int; 98 | /// The tag of the error terminal 99 | tagOfErrorTerminal: int } 100 | 101 | /// Interpret the parser table taking input from the given lexer, using the given lex buffer, and the given start state. 102 | /// Returns an object indicating the final synthesized value for the parse. 103 | member Interpret : lexer:(LexBuffer<'char> -> 'tok) * lexbuf:LexBuffer<'char> * startState:int -> obj 104 | 105 | #if INTERNALIZED_POWER_PACK 106 | exception internal Accept of obj 107 | exception internal RecoverableParseError 108 | #else 109 | /// Indicates an accept action has occured 110 | exception Accept of obj 111 | /// Indicates a parse error has occured and parse recovery is in progress 112 | exception RecoverableParseError 113 | #endif 114 | 115 | #if DEBUG 116 | module internal Flags = 117 | val mutable debug : bool 118 | #endif 119 | 120 | #if INTERNALIZED_POWER_PACK 121 | module internal ParseHelpers = 122 | #else 123 | /// Helpers used by generated parsers. 124 | module ParseHelpers = 125 | #endif 126 | /// The default implementation of the parse_error_rich function 127 | val parse_error_rich: (ParseErrorContext<'tok> -> unit) option 128 | /// The default implementation of the parse_error function 129 | val parse_error: string -> unit 130 | 131 | -------------------------------------------------------------------------------- /bindinggen/bindinggen.fs: -------------------------------------------------------------------------------- 1 | open System 2 | open System.IO 3 | open Microsoft.FSharp.Text.Lexing 4 | 5 | open FSExternHelper.HeaderSyntax 6 | open FSExternHelper.Lexer 7 | open FSExternHelper.Parser 8 | 9 | let llvmCPrefix = "LLVM" 10 | 11 | let toFSharpFunName (cFunName : string) = 12 | if cFunName.StartsWith llvmCPrefix then 13 | let baseName = cFunName.Substring llvmCPrefix.Length 14 | let fstChar = (baseName.Substring (0, 1)).ToLower () 15 | fstChar + baseName.Substring 1 16 | else 17 | failwith ("unexpected function name: " + cFunName) 18 | 19 | let toFSharpDataName (cDataName : string) = 20 | if cDataName.StartsWith llvmCPrefix then 21 | cDataName.Substring llvmCPrefix.Length 22 | else 23 | failwith ("unexpected data name: " + cDataName) 24 | 25 | // indented fprintf 26 | let inline ifprintf depth out fmt = 27 | let printIndented s = 28 | for i = 0 to depth - 1 do 29 | fprintf out " " 30 | fprintf out "%s" s 31 | Printf.ksprintf printIndented fmt 32 | 33 | // indented fprintfn 34 | let inline ifprintfn depth out fmt = 35 | let printIndented s = 36 | for i = 0 to depth - 1 do 37 | fprintf out " " 38 | fprintfn out "%s" s 39 | Printf.ksprintf printIndented fmt 40 | 41 | let getFuncTypeDefs (defs : CDef list) = 42 | let rec go (funcs : Set)= function 43 | | [] -> funcs 44 | | defHead :: defs -> 45 | match defHead with 46 | | CTypeAlias ({CFullType.baseType = FunctionType _; CFullType.pointerDepth = 1}, name) -> 47 | go (funcs.Add name) defs 48 | | CTypeAlias ({CFullType.baseType = FunctionType _}, name) -> 49 | failwith "only know how to deal with single-pointer function types" 50 | | _ -> 51 | go funcs defs 52 | 53 | go Set.empty defs 54 | 55 | let getStructDefs (defs : CDef list) = 56 | let rec go (structs : Set)= function 57 | | [] -> structs 58 | | defHead :: defs -> 59 | match defHead with 60 | | CTypeAlias ({CFullType.baseType = StructType _; CFullType.pointerDepth = 1}, name) -> 61 | go (structs.Add name) defs 62 | | CTypeAlias ({CFullType.baseType = StructType _}, name) -> 63 | failwith "only know how to deal with single-pointer structs" 64 | | _ -> 65 | go structs defs 66 | 67 | go Set.empty defs 68 | 69 | let getEnumDefs (defs : CDef list) = 70 | let rec go (enums : Set) = function 71 | | [] -> enums 72 | | defHead :: defs -> 73 | match defHead with 74 | | CEnumDef (enumName, _) -> 75 | go (enums.Add enumName) defs 76 | | _ -> 77 | go enums defs 78 | 79 | go Set.empty defs 80 | 81 | let toFSharpSource 82 | (moduleName : string) 83 | (out : System.IO.TextWriter) 84 | (deps : (string * CDef list) list) 85 | (defs : CDef list) = 86 | 87 | // using a black-list to prevent auto-generation of certain function bindings 88 | let blacklistedFuncs = 89 | Set.ofList [ 90 | "LLVMDisposeMessage" 91 | "LLVMCreateSimpleMCJITMemoryManager" 92 | "LLVMDisposeMCJITMemoryManager" 93 | ] 94 | 95 | let nsLen = moduleName.LastIndexOf '.' 96 | let simpleModuleName = moduleName.Substring (nsLen + 1) 97 | let nsName = moduleName.Substring (0, nsLen) 98 | 99 | let friendlyFuncCount = ref 0 100 | let nativeFuncCount = ref 0 101 | 102 | let depDefs = List.map snd deps 103 | let allDefs = defs @ List.concat depDefs 104 | 105 | let funcTypes = getFuncTypeDefs allDefs 106 | let structRefs = getStructDefs allDefs 107 | let enums = getEnumDefs allDefs 108 | let rec go (defs : CDef list) = 109 | match defs with 110 | | [] -> () 111 | | def :: defTail -> 112 | match def with 113 | | CFuncDef (retType, fName, fArgs) -> 114 | nativeFuncCount := !nativeFuncCount + 1 115 | let typeToStr (isParam : bool) (cType : CFullType) = 116 | let pointerAdjust ptrDepth typeStr = 117 | match ptrDepth with 118 | | 0 -> typeStr 119 | | 1 -> typeStr + "*" 120 | | _ -> failwith (sprintf "don't know how to deal with %i pointer depth" ptrDepth) 121 | let defPtrAdj = pointerAdjust cType.pointerDepth 122 | 123 | match cType.baseType with 124 | | GeneralType "LLVMBool" -> defPtrAdj "bool" 125 | | GeneralType typeName -> 126 | if enums.Contains typeName then 127 | defPtrAdj (sprintf "int (* %s *)" (cType.ToString ())) 128 | elif typeName.EndsWith "Ref" then 129 | sprintf "void* (* %s *)" (cType.ToString ()) // TODO 130 | else 131 | failwith (sprintf "don't know how to deal with: %s" typeName) 132 | | StructType typeName -> 133 | if cType.pointerDepth = 1 then 134 | sprintf "void* (* struct %s* *)" (cType.ToString ()) 135 | else 136 | failwith "can't deal with naked struct type" 137 | | IntType -> defPtrAdj "int" 138 | | VoidType -> defPtrAdj "void" 139 | | CharType -> 140 | if cType.pointerDepth = 0 then 141 | "char" 142 | elif cType.pointerDepth = 1 then 143 | if isParam then 144 | "string" 145 | else 146 | "void*" 147 | elif cType.pointerDepth = 2 then 148 | "void*" 149 | else 150 | failwith (sprintf "don't know how to deal with %i pointer depth" cType.pointerDepth) 151 | | UnsignedIntType -> defPtrAdj "uint32" 152 | | UnsignedLongLongType -> defPtrAdj "uint64" 153 | | LongLongType -> defPtrAdj "int64" 154 | | UnsignedByteType -> defPtrAdj "uint8" 155 | | SizeTType -> defPtrAdj "nativeint (* size_t *)" 156 | | DoubleType -> defPtrAdj "double" 157 | | FunctionType -> failwith "can't deal with function types" 158 | 159 | // if there are any function pointers passed, we can't generate a function 160 | let isFuncPtr cType = 161 | match cType.baseType with 162 | | GeneralType typeName -> funcTypes.Contains typeName 163 | | FunctionType -> true 164 | | _ -> false 165 | let anyFuncPtrs () = 166 | if isFuncPtr retType then 167 | true 168 | else 169 | let rec go = function 170 | | (x, _) :: xt -> 171 | if isFuncPtr x then 172 | true 173 | else 174 | go xt 175 | | [] -> 176 | false 177 | go fArgs 178 | 179 | if blacklistedFuncs.Contains fName then 180 | ifprintfn 2 out "// %s is blacklisted by the binding generator" fName 181 | elif anyFuncPtrs () then 182 | ifprintfn 183 | 2 184 | out 185 | "// %s cannot be generated because it uses a function pointer parameter or return value" 186 | fName 187 | else 188 | // the native function def 189 | ifprintfn 2 out "[]" 194 | ifprintf 2 out "extern %s %sNative(" (typeToStr false retType) (toFSharpFunName fName) 195 | let fArgs = 196 | Array.ofList fArgs 197 | |> Array.mapi (fun i a -> (fst a, match snd a with Some x -> x | None -> sprintf "arg%i" i)) 198 | if fArgs.Length >= 1 then 199 | out.WriteLine () 200 | for i = 0 to fArgs.Length - 2 do 201 | let cType, name = fArgs.[i] 202 | ifprintfn 3 out "%s %s," (typeToStr true cType) name 203 | let cType, name = fArgs.[fArgs.Length - 1] 204 | ifprintfn 3 out "%s %s)" (typeToStr true cType) name 205 | else 206 | out.WriteLine ')' 207 | 208 | // the more F# friendly function def 209 | let isFunFriendly = 210 | let isTypeFriendly t = 211 | match t.baseType with 212 | | GeneralType _ | StructType _ | IntType | VoidType 213 | | UnsignedIntType | UnsignedLongLongType | LongLongType 214 | | UnsignedByteType | DoubleType | SizeTType -> 215 | t.pointerDepth = 0 216 | | CharType -> 217 | t.pointerDepth <= 1 218 | | FunctionType -> 219 | false 220 | let rec go = function 221 | | x :: xt -> isTypeFriendly x && go xt 222 | | [] -> true 223 | isTypeFriendly retType && go (List.ofArray (Array.map fst fArgs)) 224 | if isFunFriendly then 225 | friendlyFuncCount := !friendlyFuncCount + 1 226 | if fArgs.Length >= 1 then 227 | ifprintf 2 out "let %s " (toFSharpFunName fName) 228 | for i = 0 to fArgs.Length - 2 do 229 | fprintf out "_%s " (snd fArgs.[i]) 230 | fprintfn out "_%s =" (snd fArgs.[fArgs.Length - 1]) 231 | else 232 | ifprintfn 2 out "let %s () =" (toFSharpFunName fName) 233 | let toNativeParam (arg : CFullType * string) = 234 | let cType, name = arg 235 | let name = "_" + name 236 | if cType.pointerDepth = 0 then 237 | match cType.baseType with 238 | | GeneralType "LLVMBool" -> name 239 | | GeneralType typeName -> 240 | if enums.Contains typeName then 241 | sprintf "(int (%s : %s))" name (toFSharpDataName typeName) 242 | elif typeName.EndsWith "Ref" then 243 | sprintf "(%s : %s).Ptr" name (toFSharpDataName typeName) 244 | else 245 | failwith (sprintf "don't know how to deal with: %s" typeName) 246 | | _ -> name 247 | else 248 | name 249 | let nativeFunCall () = 250 | if fArgs.Length >= 1 then 251 | fprintf out "%sNative (" (toFSharpFunName fName) 252 | for i = 0 to fArgs.Length - 2 do 253 | fprintf out "%s, " (toNativeParam fArgs.[i]) 254 | fprintf out "%s)" (toNativeParam fArgs.[fArgs.Length - 1]) 255 | else 256 | fprintf out "%sNative ()" (toFSharpFunName fName) 257 | let retTypeIsString = 258 | match retType with 259 | | {pointerDepth = 1; baseType = CharType} -> true 260 | | _ -> false 261 | if retTypeIsString then 262 | ifprintf 3 out "Marshal.PtrToStringAuto (" 263 | nativeFunCall () 264 | fprintf out ")" 265 | elif retType.pointerDepth = 0 then 266 | match retType.baseType with 267 | | GeneralType "LLVMBool" -> 268 | ifprintf 3 out "" 269 | nativeFunCall () 270 | | GeneralType typeName -> 271 | if enums.Contains typeName then 272 | ifprintf 3 out "enum<%s> (" (toFSharpDataName typeName) 273 | nativeFunCall () 274 | fprintf out ")" 275 | elif typeName.EndsWith "Ref" then 276 | ifprintf 3 out "new %s (" (toFSharpDataName typeName) 277 | nativeFunCall () 278 | fprintf out ")" 279 | else 280 | failwith (sprintf "don't know how to deal with: %s" typeName) 281 | | _ -> 282 | ifprintf 3 out "" 283 | nativeFunCall () 284 | else 285 | ifprintf 3 out "" 286 | nativeFunCall () 287 | out.WriteLine () 288 | else 289 | ifprintfn 2 out "// I don't know how to generate an \"F# friendly\" version of %s" fName 290 | 291 | out.WriteLine () 292 | 293 | go defTail 294 | 295 | | CEnumDef (enumName, enumVals) -> 296 | ifprintfn 2 out "type %s =" (toFSharpDataName enumName) 297 | let mutable nextEnumVal = 0 298 | for eValName, maybeEnumVal in enumVals do 299 | match maybeEnumVal with 300 | | Some enumVal -> nextEnumVal <- enumVal 301 | | None -> () 302 | 303 | ifprintfn 3 out "| %s = %i" (toFSharpDataName eValName) nextEnumVal 304 | nextEnumVal <- nextEnumVal + 1 305 | out.WriteLine () 306 | 307 | go defTail 308 | 309 | | CTypeAlias ({CFullType.baseType = StructType _; CFullType.pointerDepth = 1}, name) -> 310 | let dataName = toFSharpDataName name 311 | ifprintfn 2 out "type %s (thePtr : nativeint) =" dataName 312 | ifprintfn 3 out "member x.Ptr = (x :> ILLVMRef).Ptr" 313 | ifprintfn 3 out "interface ILLVMRef with member x.Ptr = thePtr" 314 | out.WriteLine () 315 | 316 | go defTail 317 | 318 | | _ -> go defTail 319 | 320 | fprintfn out "// This file should not be edited. It is automatically generated from a C header file" 321 | fprintfn out "namespace %s" nsName 322 | 323 | out.WriteLine () 324 | 325 | ifprintfn 1 out "open LLVM.FFIUtil" 326 | ifprintfn 1 out "open System.Runtime.InteropServices" 327 | List.iter (ifprintfn 1 out "open %s" << fst) deps 328 | 329 | out.WriteLine () 330 | 331 | ifprintfn 1 out "module %s =" simpleModuleName 332 | 333 | out.WriteLine () 334 | 335 | go defs 336 | 337 | (!friendlyFuncCount, !nativeFuncCount) 338 | 339 | 340 | [] 341 | let main (args : string array) = 342 | match args with 343 | | [|llvmHome; outSrcFile|] -> 344 | let cPrefix = Path.Combine [|llvmHome; "include"; "llvm-c"|] 345 | let modulePrefix = "LLVM.Generated." 346 | let parseMod (m : string) = 347 | let hFile = Path.Combine (cPrefix, Path.Combine (m.Split '.') + ".h") 348 | let reader = new StreamReader(hFile) 349 | let lexbuf = LexBuffer<_>.FromTextReader reader 350 | start tokenize lexbuf 351 | let writer = new StreamWriter(outSrcFile) 352 | let rec processModules friendlyCount nativeCount (mods : (string * string list) list) = 353 | match mods with 354 | | [] -> (friendlyCount, nativeCount) 355 | | ((m : string), deps) :: mTail -> 356 | let modName m = "LLVM.Generated." + m 357 | let depDefs = List.map (fun m -> (modName m, parseMod m)) deps 358 | let friendlyFuncCount, nativeFuncCount = 359 | toFSharpSource (modName m) writer depDefs (parseMod m) 360 | printfn 361 | "inferred friendly types for %i/%i functions in %s" 362 | friendlyFuncCount 363 | nativeFuncCount 364 | m 365 | 366 | processModules 367 | (friendlyCount + friendlyFuncCount) 368 | (nativeCount + nativeFuncCount) 369 | mTail 370 | 371 | let modulesToProcess = [ 372 | ("Support", []) 373 | ("Object", ["Support"]) 374 | ("Core", ["Support"]) 375 | ("Initialization", ["Core"]) 376 | ("BitReader", ["Core"]) 377 | ("BitWriter", ["Support"; "Core"]) 378 | ("Target", ["Core"]) 379 | ("TargetMachine", ["Core"; "Target"]) 380 | ("ExecutionEngine", ["Core"; "Target"; "TargetMachine"]) 381 | ("Analysis", ["Core"]) 382 | ("Transforms.Scalar", ["Core"]) 383 | ("Transforms.IPO", ["Core"])] 384 | let friendlyFuncCount, nativeFuncCount = 385 | processModules 0 0 modulesToProcess 386 | writer.Close () 387 | printfn "inferred friendly types for %i/%i functions in total" friendlyFuncCount nativeFuncCount 388 | 389 | | _ -> 390 | failwith "usage: bindinggen llvmHome outSrcFile" 391 | 392 | // Exit code 393 | 0 394 | 395 | -------------------------------------------------------------------------------- /bindinggen/bindinggen.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | Debug 5 | x86 6 | 8.0.30703 7 | 2.0 8 | {9d8fcf1d-f78c-4dcf-963b-f604611cc068} 9 | Exe 10 | bindinggen 11 | bindinggen 12 | v4.0 13 | Client 14 | bindinggen 15 | 16 | 17 | true 18 | full 19 | false 20 | false 21 | bin\Debug\ 22 | DEBUG;TRACE 23 | 3 24 | x86 25 | bin\Debug\bindinggen.XML 26 | 27 | 28 | pdbonly 29 | true 30 | true 31 | bin\Release\ 32 | TRACE 33 | 3 34 | x86 35 | bin\Release\bindinggen.XML 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | HeaderSyntax.fs 47 | 48 | 49 | Lexing.fs 50 | 51 | 52 | Parsing.fs 53 | 54 | 55 | Lexer.fs 56 | 57 | 58 | Parser.fs 59 | 60 | 61 | bindinggen.fs 62 | 63 | 64 | 65 | 11 66 | 67 | 68 | 69 | 70 | 77 | -------------------------------------------------------------------------------- /build.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # by default use fsc, or fsharpc 4 | if [ -z "$FSC" ]; then 5 | if command -v fsc >/dev/null 2>&1; then 6 | FSC=fsc 7 | elif command -v fsharpc >/dev/null 2>&1; then 8 | FSC=fsharpc 9 | else 10 | echo "No FSharp compiler found!" 11 | exit 1 12 | fi 13 | fi 14 | 15 | # exit on error and don't allow the use of unset variables 16 | set -o errexit 17 | set -o nounset 18 | set -x 19 | 20 | # build the LLVM binding DLL 21 | ${FSC} --nologo --debug --target:library --out:LLVMFSharp.dll \ 22 | src/LLVM/FFIUtil.fs \ 23 | src/LLVM/Generated.fs \ 24 | src/LLVM/Core.fs \ 25 | src/LLVM/BitReader.fs \ 26 | src/LLVM/ExecutionEngine.fs \ 27 | src/LLVM/Extra.fs \ 28 | src/LLVM/Target.fs \ 29 | src/LLVM/Quote.fs 30 | 31 | # uncomment the following to build and run the tests 32 | 33 | #echo "a very basic test" 34 | #${FSC} --nologo -r LLVMFSharp.dll test/simpletest.fs 35 | #mono simpletest.exe 36 | # 37 | #echo "a bit more complicated: this version uses the execution engine" 38 | #${FSC} --nologo -r LLVMFSharp.dll test/simpletest2.fs 39 | #mono simpletest2.exe 40 | # 41 | #echo "compile C code against two add functions built from LLVM" 42 | #${FSC} --nologo -r LLVMFSharp.dll test/add.fs 43 | #mono add.exe 44 | #llc -march=x86-64 -filetype=obj addModule.bc 45 | #gcc -o printadds addModule.o test/printadds.c 46 | #./printadds 47 | # 48 | #echo "test that the API works with C#" 49 | #dmcs -out:CSSimpleTest2.exe -r:LLVMFSharp.dll test/CSSimpleTest2.cs 50 | #mono CSSimpleTest2.exe 51 | # 52 | #echo "metadata test" 53 | #${FSC} --nologo -r LLVMFSharp.dll test/metadatatest.fs 54 | #mono metadatatest.exe 55 | # 56 | #echo "quote test" 57 | #${FSC} --nologo -r LLVMFSharp.dll test/quotetest.fs 58 | #mono quotetest.exe 59 | #llc -march=x86-64 -filetype=obj quotemodule.bc 60 | #llvm-dis quotemodule.bc 61 | #gcc -o quotetest quotemodule.o test/quotetest.c 62 | #./quotetest 63 | 64 | -------------------------------------------------------------------------------- /clean.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # exit on error and don't allow the use of unset variables 4 | set -o errexit 5 | set -o nounset 6 | set -x 7 | 8 | rm -f \ 9 | LLVMFSharp.fsi \ 10 | LLVMFSharp.dll \ 11 | LLVMFSharp.sln \ 12 | LLVMFSharp.userprefs \ 13 | bindinggen.exe \ 14 | simpletest.exe \ 15 | simpletest2.exe \ 16 | CSSimpleTest2.exe \ 17 | bindinggen/Parser.fs \ 18 | bindinggen/Parser.fsi \ 19 | bindinggen/Lexer.fs \ 20 | addModule.bc \ 21 | addModule.o \ 22 | my-module.bc \ 23 | printadds \ 24 | tut2.bc 25 | 26 | 27 | -------------------------------------------------------------------------------- /gen-bindings.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # by default use fsc, or fsharpc 4 | if [ -z "$FSC" ]; then 5 | if command -v fsc >/dev/null 2>&1; then 6 | FSC=fsc 7 | elif command -v fsharpc >/dev/null 2>&1; then 8 | FSC=fsharpc 9 | else 10 | echo "No FSharp compiler found!" 11 | exit 1 12 | fi 13 | fi 14 | 15 | # exit on error and don't allow the use of unset variables 16 | set -o errexit 17 | set -o nounset 18 | set -x 19 | 20 | # build and run special purpose tool for generating LLVM C bindings 21 | fslex --unicode bindinggen/Lexer.fsl 22 | fsyacc --module FSExternHelper.Parser bindinggen/Parser.fsy 23 | ${FSC} --nologo \ 24 | bindinggen/Lexing.fs \ 25 | bindinggen/Parsing.fs \ 26 | bindinggen/HeaderSyntax.fs \ 27 | bindinggen/Parser.fs \ 28 | bindinggen/Lexer.fs \ 29 | bindinggen/bindinggen.fs 30 | 31 | # see if mono exists in the path. if not assume we're on windows and can 32 | # run bindinggen.exe directly 33 | if hash mono &> /dev/null; then 34 | #mono bindinggen.exe ~/bin/llvm-3.1 src/LLVM/Generated.fs 35 | mono bindinggen.exe ~/projects/third-party/llvm-git src/LLVM/Generated.fs 36 | else 37 | bindinggen.exe LLVM-3.1.dll C:\\Users\\keith\\Desktop\\projects\\llvm-3.1 src\\LLVM\\Generated.fs 38 | fi 39 | 40 | -------------------------------------------------------------------------------- /llvm-fs.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | de1718ba-b9ce-4d52-a184-408b3c147a29 9 | Library 10 | llvm_fs 11 | LLVMFSharp 12 | v4.5 13 | llvm-fs 14 | 15 | 16 | true 17 | full 18 | false 19 | false 20 | bin\Debug\ 21 | DEBUG;TRACE 22 | 3 23 | bin\Debug\llvm_fs.XML 24 | 25 | 26 | pdbonly 27 | true 28 | true 29 | bin\Release\ 30 | TRACE 31 | 3 32 | bin\Release\llvm_fs.XML 33 | 34 | 35 | 36 | 37 | True 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | FFIUtil.fs 46 | 47 | 48 | Generated.fs 49 | 50 | 51 | Core.fs 52 | 53 | 54 | BitReader.fs 55 | 56 | 57 | ExecutionEngine.fs 58 | 59 | 60 | Extra.fs 61 | 62 | 63 | Target.fs 64 | 65 | 66 | Quote.fs 67 | 68 | 69 | 70 | 11 71 | 72 | 73 | 80 | -------------------------------------------------------------------------------- /src/LLVM/BitReader.fs: -------------------------------------------------------------------------------- 1 | module LLVM.BitReader 2 | 3 | open System.Runtime.InteropServices 4 | 5 | open LLVM.Generated.Support 6 | open LLVM.Generated.Core 7 | open LLVM.Generated.BitReader 8 | 9 | let parseBitcode (memBuf : MemoryBufferRef) = 10 | let modRefPtr = Marshal.AllocHGlobal sizeof 11 | let msgStrPtr = Marshal.AllocHGlobal sizeof 12 | try 13 | // TODO mem leaks!!! 14 | if parseBitcodeNative(memBuf.Ptr, modRefPtr, msgStrPtr) then 15 | // TODO use msgStrPtr 16 | failwith "failed to parse bitcode" 17 | else 18 | new ModuleRef(Marshal.ReadIntPtr(modRefPtr)) 19 | finally 20 | Marshal.FreeHGlobal modRefPtr 21 | Marshal.FreeHGlobal msgStrPtr 22 | -------------------------------------------------------------------------------- /src/LLVM/Core.fs: -------------------------------------------------------------------------------- 1 | module LLVM.Core 2 | 3 | open System.Runtime.InteropServices 4 | open System.Threading 5 | 6 | open LLVM.Generated.Support 7 | open LLVM.Generated.Core 8 | open LLVM.FFIUtil 9 | 10 | /// Extends BuilderRef. This version implements IDisposable and will call 11 | /// disposeBuilder on itself automatically 12 | type Builder(builderRef : BuilderRef) = 13 | inherit BuilderRef(builderRef.Ptr) 14 | 15 | [] 16 | let mutable disposed = 0 17 | 18 | new() = new Builder(createBuilder ()) 19 | 20 | new(ctxt : ContextRef) = new Builder(createBuilderInContext ctxt) 21 | 22 | new(bb : BasicBlockRef) as x = 23 | new Builder(createBuilder ()) then 24 | positionBuilderAtEnd x bb 25 | 26 | interface System.IDisposable with 27 | member x.Dispose () = 28 | if Interlocked.CompareExchange(&disposed, 1, 0) = 0 then 29 | disposeBuilder x 30 | 31 | let varArgFunctionType (retTy : TypeRef) (paramTys : TypeRef array) = 32 | use paramPtrs = new NativePtrs([|for pt in paramTys -> pt.Ptr|]) 33 | let paramCount = uint32 paramTys.Length 34 | 35 | TypeRef (functionTypeNative (retTy.Ptr, paramPtrs.Ptrs, paramCount, true)) 36 | 37 | let functionType (retTy : TypeRef) (paramTys : TypeRef array) = 38 | use paramPtrs = new NativePtrs([|for pt in paramTys -> pt.Ptr|]) 39 | let paramCount = uint32 paramTys.Length 40 | 41 | TypeRef (functionTypeNative (retTy.Ptr, paramPtrs.Ptrs, paramCount, false)) 42 | 43 | let getBasicBlocks (f : ValueRef) = 44 | let bbCount = countBasicBlocks f 45 | if bbCount >= 1u then 46 | let rec goNext i bb = 47 | if i < bbCount then 48 | let nextBB = getNextBasicBlock bb 49 | bb :: goNext (i + 1u) nextBB 50 | else 51 | [bb] 52 | goNext 1u (getFirstBasicBlock f) 53 | else 54 | [] 55 | 56 | let buildCall (bld : BuilderRef) (func : ValueRef) (args : ValueRef array) (name : string) = 57 | use argPtrs = new NativePtrs([|for vr in args -> vr.Ptr|]) 58 | let argCount = uint32 args.Length 59 | 60 | ValueRef (buildCallNative (bld.Ptr, func.Ptr, argPtrs.Ptrs, argCount, name)) 61 | 62 | let addIncoming (phi : ValueRef) (incoming : array) = 63 | let incVals, incBlocks = Array.unzip incoming 64 | use incValPtrs = new NativePtrs([|for vr in incVals -> vr.Ptr|]) 65 | use incBlockPtrs = new NativePtrs([|for br in incBlocks -> br.Ptr|]) 66 | let incCount = uint32 incoming.Length 67 | 68 | addIncomingNative (phi.Ptr, incValPtrs.Ptrs, incBlockPtrs.Ptrs, incCount) 69 | 70 | let buildPhiWithIncoming 71 | (bldr:BuilderRef) 72 | (ty:TypeRef) 73 | (incoming:array) 74 | (name:string) = 75 | 76 | let phi = buildPhi bldr ty name 77 | addIncoming phi incoming 78 | phi 79 | 80 | let getNamedFunction (modRef : ModuleRef) (name : string) = 81 | ValueRef (getNamedFunctionNative (modRef.Ptr, name)) 82 | 83 | let optValueRef (vr : ValueRef) = 84 | match vr.Ptr with 85 | | 0n -> None 86 | | _ -> Some vr 87 | 88 | let tryGetNamedFunction (modRef : ModuleRef) (name : string) = 89 | optValueRef (getNamedFunction modRef name) 90 | 91 | let getParams (func : ValueRef) = 92 | let paramCount = int (countParams func) 93 | [|for i in 0 .. paramCount - 1 -> getParam func (uint32 i)|] 94 | 95 | let getParamTypes (funcTy : TypeRef) = 96 | let paramCount = int (countParamTypes funcTy) 97 | use nativeParamTyPtrs = new NativePtrs([|for _ in 0 .. paramCount - 1 -> 0n|]) 98 | getParamTypesNative (funcTy.Ptr, nativeParamTyPtrs.Ptrs) 99 | 100 | [|for ptr in nativeParamTyPtrs.PtrArr -> new TypeRef (ptr)|] 101 | 102 | let buildSwitchWithCases 103 | (bldr : BuilderRef) 104 | (testVal : ValueRef) 105 | (cases : (ValueRef * BasicBlockRef) array) 106 | (defaultCase : BasicBlockRef) = 107 | 108 | let switchVal = buildSwitch bldr testVal defaultCase (uint32 cases.Length) 109 | for caseVal, caseBlock in cases do 110 | addCase switchVal caseVal caseBlock 111 | 112 | let structTypeInContext (ctxt : ContextRef) (elemTys : TypeRef array) (packed : bool) = 113 | use elemTyPtrs = new NativePtrs([|for t in elemTys -> t.Ptr|]) 114 | TypeRef (structTypeInContextNative (ctxt.Ptr, elemTyPtrs.Ptrs, uint32 elemTys.Length, packed)) 115 | 116 | let structType (elemTys : TypeRef array) (packed : bool) = 117 | use elemTyPtrs = new NativePtrs([|for t in elemTys -> t.Ptr|]) 118 | TypeRef (structTypeNative (elemTyPtrs.Ptrs, uint32 elemTys.Length, packed)) 119 | 120 | let buildGEP (bldr : BuilderRef) (ptr : ValueRef) (indices : ValueRef array) (name : string) = 121 | use indexPtrs = new NativePtrs([|for i in indices -> i.Ptr|]) 122 | ValueRef (buildGEPNative (bldr.Ptr, ptr.Ptr, indexPtrs.Ptrs, uint32 indices.Length, name)) 123 | 124 | let structSetBody (structTy : TypeRef) (elemTys : TypeRef array) (packed : bool) = 125 | use elemPtrs = new NativePtrs([|for e in elemTys -> e.Ptr|]) 126 | structSetBodyNative(structTy.Ptr, elemPtrs.Ptrs, uint32 elemTys.Length, packed) 127 | 128 | let getStructElementTypes (structTy : TypeRef) = 129 | let elemCount = int (countStructElementTypes structTy) 130 | use nativeElemTyPtrs = new NativePtrs([|for _ in 0 .. elemCount - 1 -> 0n|]) 131 | getStructElementTypesNative (structTy.Ptr, nativeElemTyPtrs.Ptrs) 132 | 133 | [|for ptr in nativeElemTyPtrs.PtrArr -> new TypeRef (ptr)|] 134 | 135 | let createMemoryBufferWithContentsOfFile (path : string) = 136 | let buffPtr = Marshal.AllocHGlobal sizeof 137 | let strPtr = Marshal.AllocHGlobal sizeof 138 | try 139 | // TODO mem leaks!!! 140 | if createMemoryBufferWithContentsOfFileNative(path, buffPtr, strPtr) then 141 | // TODO use strPtr message 142 | failwith "failed to create memory buffer" 143 | else 144 | let buff = Marshal.ReadIntPtr buffPtr 145 | new MemoryBufferRef(buff) 146 | finally 147 | Marshal.FreeHGlobal buffPtr 148 | Marshal.FreeHGlobal strPtr 149 | 150 | let mdNode (vals:ValueRef array) : ValueRef = 151 | use valPtrs = new NativePtrs([|for v in vals -> v.Ptr|]) 152 | new ValueRef(mDNodeNative(valPtrs.Ptrs, uint32 vals.Length)) 153 | let mdNodeInContext (ctxt:ContextRef) (vals:ValueRef array) : ValueRef = 154 | use valPtrs = new NativePtrs([|for v in vals -> v.Ptr|]) 155 | new ValueRef(mDNodeInContextNative(ctxt.Ptr, valPtrs.Ptrs, uint32 vals.Length)) 156 | 157 | let constInt1 (b:bool) : ValueRef = 158 | constInt (int1Type()) (if b then 1uL else 0uL) false 159 | let constUInt8 (i:uint8) : ValueRef = 160 | constInt (int8Type()) (uint64 i) false 161 | let constInt8 (i:int8) : ValueRef = 162 | constInt (int8Type()) (uint64 i) false 163 | let constUInt16 (i:uint16) : ValueRef = 164 | constInt (int16Type()) (uint64 i) false 165 | let constInt16 (i:int16) : ValueRef = 166 | constInt (int16Type()) (uint64 i) false 167 | let constUInt32 (i:uint32) : ValueRef = 168 | constInt (int32Type()) (uint64 i) false 169 | let constInt32 (i:int32) : ValueRef = 170 | constInt (int32Type()) (uint64 i) false 171 | let constUInt64 (i:uint64) : ValueRef = 172 | constInt (int64Type()) i false 173 | let constInt64 (i:int64) : ValueRef = 174 | constInt (int64Type()) (uint64 i) false 175 | 176 | let constFloat (f:float32) : ValueRef = 177 | constReal (floatType()) (double f) 178 | let constDouble (d:double) : ValueRef = 179 | constReal (doubleType()) d 180 | 181 | let constArray (elemTy:TypeRef) (constVals:ValueRef array) : ValueRef = 182 | use constPtrs = new NativePtrs([|for constVal in constVals -> constVal.Ptr|]) 183 | let elemCount = uint32 constVals.Length 184 | ValueRef(constArrayNative(elemTy.Ptr, constPtrs.Ptrs, elemCount)) 185 | 186 | let constStruct (constVals:ValueRef array) (packed:bool) : ValueRef = 187 | use constPtrs = new NativePtrs([|for constVal in constVals -> constVal.Ptr|]) 188 | let valCount = uint32 constVals.Length 189 | ValueRef(constStructNative(constPtrs.Ptrs, valCount, packed)) 190 | let constStructInContext (c:ContextRef) (constVals:ValueRef array) (packed:bool) : ValueRef = 191 | use constPtrs = new NativePtrs([|for constVal in constVals -> constVal.Ptr|]) 192 | let valCount = uint32 constVals.Length 193 | ValueRef(constStructInContextNative(c.Ptr, constPtrs.Ptrs, valCount, packed)) 194 | let constNamedStruct (structTy:TypeRef) (constVals:ValueRef array) = 195 | use constPtrs = new NativePtrs([|for constVal in constVals -> constVal.Ptr|]) 196 | let valCount = uint32 constVals.Length 197 | ValueRef(constNamedStructNative(structTy.Ptr, constPtrs.Ptrs, valCount)) 198 | -------------------------------------------------------------------------------- /src/LLVM/ExecutionEngine.fs: -------------------------------------------------------------------------------- 1 | module LLVM.ExecutionEngine 2 | 3 | open System.Runtime.InteropServices 4 | 5 | open LLVM.Generated.Core 6 | open LLVM.Generated.ExecutionEngine 7 | open LLVM.FFIUtil 8 | 9 | let runFunction 10 | (ee : ExecutionEngineRef) 11 | (func : ValueRef) 12 | (args : GenericValueRef array) = 13 | use argPtrs = new NativePtrs(Array.map (fun (gv : GenericValueRef) -> gv.Ptr) args) 14 | let retValPtr = runFunctionNative (ee.Ptr, func.Ptr, uint32 args.Length, argPtrs.Ptrs) 15 | GenericValueRef retValPtr 16 | 17 | let private createEngineForModuleFromNativeFunc 18 | (nativeFunc : (nativeint * nativeint * nativeint) -> bool) 19 | (moduleRef : ModuleRef) = 20 | 21 | use outEnginePtr = new NativePtrs([|0n|]) 22 | use outErrPtr = new NativePtrs([|0n|]) 23 | let createFailed = 24 | nativeFunc ( 25 | outEnginePtr.Ptrs, 26 | moduleRef.Ptr, 27 | outErrPtr.Ptrs) 28 | if createFailed then 29 | let errStr = Marshal.PtrToStringAuto (Marshal.ReadIntPtr outErrPtr.Ptrs) 30 | Marshal.FreeHGlobal (Marshal.ReadIntPtr outErrPtr.Ptrs) 31 | failwith errStr 32 | else 33 | ExecutionEngineRef (Marshal.ReadIntPtr outEnginePtr.Ptrs) 34 | 35 | let createExecutionEngineForModule (modRef : ModuleRef) = 36 | createEngineForModuleFromNativeFunc createExecutionEngineForModuleNative modRef 37 | 38 | let createInterpreterForModule (modRef : ModuleRef) = 39 | createEngineForModuleFromNativeFunc createInterpreterForModuleNative modRef 40 | 41 | let createJITCompilerForModule (modRef : ModuleRef) (optLvl : uint32) = 42 | let f (engPtr, modPtr, outErrPtr) = 43 | createJITCompilerForModuleNative (engPtr, modPtr, optLvl, outErrPtr) 44 | 45 | createEngineForModuleFromNativeFunc f modRef 46 | 47 | -------------------------------------------------------------------------------- /src/LLVM/Extra.fs: -------------------------------------------------------------------------------- 1 | module LLVM.Extra 2 | 3 | open LLVM.Generated.Core 4 | open LLVM.Core 5 | 6 | let rec private typeToStringBuilder (modRef : ModuleRef) (tyRef : TypeRef) = 7 | let newStrBldr (s : string) = new System.Text.StringBuilder(s) 8 | let withElemTySB (s : string) = 9 | let sb = newStrBldr s 10 | sb.Append '<' |> ignore 11 | let elemTySb = typeToStringBuilder modRef (getElementType tyRef) 12 | sb.Append (elemTySb : System.Text.StringBuilder) |> ignore 13 | sb.Append '>' 14 | 15 | match getTypeKind tyRef with 16 | | TypeKind.VoidTypeKind -> newStrBldr "void" 17 | | TypeKind.FloatTypeKind -> newStrBldr "float" 18 | | TypeKind.DoubleTypeKind -> newStrBldr "double" 19 | | TypeKind.X86_FP80TypeKind -> newStrBldr "X86 FP80" 20 | | TypeKind.FP128TypeKind -> newStrBldr "FP 128" 21 | | TypeKind.PPC_FP128TypeKind -> newStrBldr "PPC FP 128" 22 | | TypeKind.LabelTypeKind -> newStrBldr "Label" 23 | | TypeKind.IntegerTypeKind -> 24 | newStrBldr("int").Append(getIntTypeWidth tyRef) 25 | | TypeKind.FunctionTypeKind -> 26 | let sb = newStrBldr "(fun " 27 | let argTys = getParamTypes tyRef 28 | for i = 0 to argTys.Length - 1 do 29 | if i >= 1 then 30 | sb.Append(", ") |> ignore 31 | sb.Append(typeToStringBuilder modRef argTys.[i]) |> ignore 32 | sb.Append "->" |> ignore 33 | sb.Append(typeToStringBuilder modRef (getReturnType tyRef)).Append(")") 34 | | TypeKind.MetadataTypeKind -> newStrBldr "Metadata" 35 | | TypeKind.X86_MMXTypeKind -> newStrBldr "X86 MMX" 36 | | TypeKind.ArrayTypeKind -> withElemTySB "Array" 37 | | TypeKind.PointerTypeKind -> withElemTySB "Pointer" 38 | | TypeKind.VectorTypeKind -> withElemTySB "Vector" 39 | | TypeKind.StructTypeKind -> 40 | match getStructName tyRef with 41 | | null | "" -> 42 | let sb = newStrBldr "struct {" 43 | let structElemTys = getStructElementTypes tyRef 44 | for i in 0 .. structElemTys.Length - 1 do 45 | sb.Append (typeToStringBuilder modRef structElemTys.[i]) |> ignore 46 | sb.Append ';' |> ignore 47 | let isLastElem = i = structElemTys.Length - 1 48 | if not isLastElem then 49 | sb.Append ' ' |> ignore 50 | sb.Append '}' 51 | | name -> new System.Text.StringBuilder(name) 52 | | tk -> 53 | failwithf "unhandled type kind: %A" tk 54 | 55 | let typeToString (modRef : ModuleRef) (tyRef : TypeRef) = 56 | (typeToStringBuilder modRef tyRef).ToString () 57 | 58 | let buildCopy 59 | (moduleRef : ModuleRef) 60 | (bldr : BuilderRef) 61 | (dest : ValueRef) 62 | (src : ValueRef) 63 | (isVolatile : bool) 64 | : unit = 65 | 66 | let destTy = typeOf dest 67 | let srcTy = typeOf src 68 | match getTypeKind destTy, getTypeKind srcTy with 69 | | TypeKind.PointerTypeKind, TypeKind.PointerTypeKind -> 70 | // we must declare the memcpy intrinsic as: 71 | // declare void @llvm.memcpy.p0i8.p0i8.i64( 72 | // i8* , i8* , i64 , i32 , i1 ) 73 | let bytePtr = pointerType (int8Type()) 0u 74 | let memcpyFuncTy = functionType (voidType()) [|bytePtr; bytePtr; int64Type(); int32Type(); int1Type()|] 75 | let memcpy = addFunction moduleRef "llvm.memcpy.p0i8.p0i8.i64" memcpyFuncTy 76 | removeFunctionAttr memcpy Attribute.NoUnwindAttribute 77 | 78 | // how many bytes need to be copied from source to dest 79 | let numBytes = sizeOf (getElementType srcTy) 80 | 81 | // both source and dest need to be cast to i8* 82 | let destArg = buildBitCast bldr dest bytePtr "dest" 83 | let srcArg = buildBitCast bldr src bytePtr "src" 84 | 85 | buildCall bldr memcpy [|destArg; srcArg; numBytes; constInt32 1; constInt1 isVolatile|] "" |> ignore 86 | | destTK, srcTK -> 87 | failwithf "unexpected types in buildCopy (dest=%A, src=%A)" destTK srcTK 88 | -------------------------------------------------------------------------------- /src/LLVM/FFIUtil.fs: -------------------------------------------------------------------------------- 1 | module LLVM.FFIUtil 2 | 3 | open System.Runtime.InteropServices 4 | open System.Threading 5 | 6 | type ILLVMRef = abstract Ptr : nativeint with get 7 | 8 | type NativePtrs(managedPtrs : nativeint array) = 9 | [] 10 | let mutable disposed = 0 11 | let ptrs = Marshal.AllocHGlobal(managedPtrs.Length * sizeof) 12 | do Marshal.Copy(managedPtrs, 0, ptrs, managedPtrs.Length) 13 | 14 | member x.Ptrs = ptrs 15 | 16 | member x.PtrArr = 17 | let len = managedPtrs.Length 18 | [|for i in 0 .. len - 1 -> Marshal.ReadIntPtr(ptrs, i * sizeof)|] 19 | 20 | interface System.IDisposable with 21 | member x.Dispose () = 22 | if Interlocked.CompareExchange(&disposed, 1, 0) = 0 then 23 | Marshal.FreeHGlobal ptrs 24 | 25 | let [] llvmAssemblyName = "LLVM-3.6.0svn.dll" 26 | -------------------------------------------------------------------------------- /src/LLVM/Quote.fs: -------------------------------------------------------------------------------- 1 | // TODO don't allow let bound unit vals 2 | 3 | module LLVM.Quote 4 | 5 | open Microsoft.FSharp.Quotations 6 | open Microsoft.FSharp.Quotations.Patterns 7 | open Microsoft.FSharp.Quotations.DerivedPatterns 8 | 9 | module LGC = LLVM.Generated.Core 10 | module LC = LLVM.Core 11 | 12 | /// Determines if two types are equal assuming that we ignore any 13 | /// generic components 14 | let private typesGenEq (ty1:System.Type) (ty2:System.Type) = 15 | let genTy (ty:System.Type) = 16 | if ty.IsGenericType then 17 | ty.GetGenericTypeDefinition() 18 | else 19 | ty 20 | 21 | genTy ty1 = genTy ty2 22 | 23 | let private onlyForQuotations() = 24 | failwith "this function is only meant to be used within a quotation" 25 | 26 | /// this type should only be used within quotations to represent 27 | /// an LLVM array. It is called RawArray to distinguish it from 28 | /// F# arrays 29 | type [] RawArray<'a> = 30 | abstract Item : int -> 'a with get, set 31 | 32 | /// This function can only be used within a quotation to indicate 33 | /// a heap allocation of an LLVM array 34 | let heapAllocRawArray (size:int) : RawArray<'a> = onlyForQuotations() 35 | 36 | /// This function can only be used within a quotation to indicate 37 | /// a stack allocation of an LLVM array 38 | let stackAllocRawArray (size:int) : RawArray<'a> = onlyForQuotations() 39 | 40 | /// This function can only be used within a quotation to free 41 | /// a heap-allocated variable 42 | let free (heapAllocated:'a) : unit = onlyForQuotations() 43 | 44 | // our internal representation of a function definition 45 | type private Def = { 46 | funVar : Var 47 | funParams : Var list 48 | body : Expr 49 | } 50 | 51 | // a LetDef can either be a single non-recursive function def or 52 | // a list of mutually recursive function definitions 53 | type private LetDef = 54 | | LetDef of Def 55 | | LetRecDefs of Def list 56 | 57 | // concatenates successive lambdas so that they can be treated as a single 58 | // multi-parameter function 59 | let rec private lambdas (expr:Expr) : Var list * Expr = 60 | match expr with 61 | | Lambda (var, expr) -> 62 | let varTail, expr = lambdas expr 63 | var :: varTail, expr 64 | | _ -> 65 | [], expr 66 | 67 | // creates a list of all successive function definitions followed by a function 68 | // representing any remaining expressions 69 | let private allLetFuncDefs (expr:Expr) : LetDef list * Expr = 70 | let rec go expr = 71 | let next (letDef:LetDef) (remExpr:Expr) = 72 | let letDefTail, remExpr = go remExpr 73 | letDef :: letDefTail, remExpr 74 | match expr with 75 | | Let (funId, defExpr, remExpr) -> 76 | let vars, body = lambdas defExpr 77 | next (LetDef {Def.funVar=funId; funParams=vars; body=body}) remExpr 78 | | LetRecursive (funList, remExpr) -> 79 | let makeFun (var:Var, expr:Expr) = 80 | let funParams, body = lambdas expr 81 | {Def.funVar=var; funParams=funParams; body=body} 82 | next (LetRecDefs (List.map makeFun funList)) remExpr 83 | | _ -> 84 | [], expr 85 | 86 | go expr 87 | 88 | let private uInt32Ty = typeof 89 | let private int32Ty = typeof 90 | let private uInt16Ty = typeof 91 | let private int16Ty = typeof 92 | let private uInt8Ty = typeof 93 | let private int8Ty = typeof 94 | 95 | // these active patterns simplify working with .NET types 96 | let private (|UnitTy|_|) (ty:System.Type) = 97 | if ty = typeof then Some UnitTy else None 98 | 99 | let private (|BoolTy|_|) (ty:System.Type) = 100 | if ty = typeof then Some BoolTy else None 101 | 102 | let private (|SingleTy|_|) (ty:System.Type) = 103 | if ty = typeof then Some SingleTy else None 104 | let private (|DoubleTy|_|) (ty:System.Type) = 105 | if ty = typeof then Some DoubleTy else None 106 | 107 | let private (|Int8Ty|_|) (ty:System.Type) = 108 | if ty = typeof then Some Int8Ty else None 109 | let private (|UInt8Ty|_|) (ty:System.Type) = 110 | if ty = typeof then Some UInt8Ty else None 111 | let private (|Int16Ty|_|) (ty:System.Type) = 112 | if ty = typeof then Some Int16Ty else None 113 | let private (|UInt16Ty|_|) (ty:System.Type) = 114 | if ty = typeof then Some UInt16Ty else None 115 | let private (|Int32Ty|_|) (ty:System.Type) = 116 | if ty = typeof then Some Int32Ty else None 117 | let private (|UInt32Ty|_|) (ty:System.Type) = 118 | if ty = typeof then Some UInt32Ty else None 119 | let private (|Int64Ty|_|) (ty:System.Type) = 120 | if ty = typeof then Some Int64Ty else None 121 | let private (|UInt64Ty|_|) (ty:System.Type) = 122 | if ty = typeof then Some UInt64Ty else None 123 | 124 | let intTySize = function 125 | | Int8Ty | UInt8Ty -> 8 126 | | Int16Ty | UInt16Ty -> 16 127 | | Int32Ty | UInt32Ty -> 32 128 | | Int64Ty | UInt64Ty -> 64 129 | | _ -> failwith "expected an int type" 130 | let isSignedInt = function 131 | | Int8Ty | Int16Ty | Int32Ty | Int64Ty -> true 132 | | _ -> false 133 | 134 | let private (|AnySIntTy|_|) (ty:System.Type) = 135 | match ty with 136 | | Int64Ty _ | Int32Ty _ | Int16Ty _ | Int8Ty _ -> Some AnySIntTy 137 | | _ -> None 138 | let private (|AnyUIntTy|_|) (ty:System.Type) = 139 | match ty with 140 | | UInt64Ty _ | UInt32Ty _ | UInt16Ty _ | UInt8Ty _ -> Some AnyUIntTy 141 | | _ -> None 142 | let private (|AnyIntTy|_|) (ty:System.Type) = 143 | match ty with 144 | | AnySIntTy _ | AnyUIntTy _ -> Some AnyIntTy 145 | | _ -> None 146 | let private (|AnyFloatTy|_|) (ty:System.Type) = 147 | match ty with 148 | | DoubleTy _ | SingleTy _ -> Some AnyFloatTy 149 | | _ -> None 150 | 151 | let private (|ArrayTy|_|) (ty:System.Type) = 152 | if typesGenEq ty typeof> then 153 | Some <| ArrayTy (ty.GetGenericArguments().[0]) 154 | else 155 | None 156 | 157 | // matches any tuple type returning the list of generic type args 158 | // TODO: F# uses a recursive tuple param in the 8th generic param 159 | // to represent tuples with more than 8 components. We 160 | // may have to make some code changes to accomodate this 161 | let private (|TupleTy|_|) (ty:System.Type) = 162 | let sysTupTys = [| 163 | typeof> 164 | typeof> 165 | typeof> 166 | typeof> 167 | typeof> 168 | typeof> 169 | typeof> 170 | typeof> 171 | |] 172 | 173 | let rec anyMatch (i:int) = 174 | if i >= sysTupTys.Length then 175 | false 176 | elif typesGenEq ty sysTupTys.[i] then 177 | true 178 | else 179 | anyMatch (i + 1) 180 | 181 | if anyMatch 0 then 182 | Some (TupleTy (ty.GetGenericArguments())) 183 | else 184 | None 185 | 186 | // The LLVM type that we should "malloc" corresponding to the given .NET type 187 | let rec private allocableLLVMTyOf (ty:System.Type) : LGC.TypeRef = 188 | match ty with 189 | | TupleTy elemTys -> LC.structType (Array.map llvmTyOf elemTys) false 190 | | _ -> failwithf "No support for type %A" ty 191 | // The LLVM type that corresponds to the given .NET type 192 | and private llvmTyOf (ty:System.Type) : LGC.TypeRef = 193 | match ty with 194 | | DoubleTy -> LGC.doubleType() 195 | | SingleTy -> LGC.floatType() 196 | | Int64Ty | UInt64Ty -> LGC.int64Type() 197 | | Int32Ty | UInt32Ty -> LGC.int32Type() 198 | | Int16Ty | UInt16Ty -> LGC.int16Type() 199 | | Int8Ty | UInt8Ty -> LGC.int8Type() 200 | | BoolTy -> LGC.int1Type() 201 | | UnitTy -> LGC.voidType() 202 | | ArrayTy elemTy -> LGC.pointerType (llvmTyOf elemTy) 0u 203 | | _ -> LGC.pointerType (allocableLLVMTyOf ty) 0u 204 | let private llvmTyOfVar (var:Var) : LGC.TypeRef = llvmTyOf var.Type 205 | let private llvmTyOfExpr (expr:Expr) : LGC.TypeRef = llvmTyOf expr.Type 206 | 207 | let private isUnitExpr (expr:Expr) : bool = expr.Type = typeof 208 | 209 | let private llvmFunTyOf (def:Def) : LGC.TypeRef = 210 | if def.funParams.IsEmpty then 211 | failwithf "top level definitions should be a function but \"%A\" is not" id 212 | 213 | let llvmRetTy = llvmTyOfExpr def.body 214 | match [|for p in def.funParams -> p.Type|] with 215 | | [|UnitTy|] -> LC.functionType llvmRetTy [||] 216 | | paramSysTys -> 217 | for t in paramSysTys do 218 | if t = typeof then 219 | failwithf "error: %s function uses unit parameter(s) which is not supported" def.funVar.Name 220 | let llvmParamTys = List.map llvmTyOfVar def.funParams |> Array.ofList 221 | LC.functionType llvmRetTy llvmParamTys 222 | 223 | // create an LLVM function definition from the given def 224 | let private declareFunction (moduleRef:LGC.ModuleRef) (def:Def) : LGC.ValueRef = 225 | let fn = LGC.addFunction moduleRef def.funVar.Name (llvmFunTyOf def) 226 | def.funParams |> List.iteri ( 227 | fun i p -> 228 | if p.Type <> typeof then 229 | LGC.setValueName (LGC.getParam fn (uint32 i)) p.Name 230 | ) 231 | fn 232 | 233 | // matches a "full application" meaning that all consecutive applications are 234 | // appended into a list of applications 235 | let private (|FullAppl|_|) (expr:Expr) = 236 | let rec go expr = 237 | match expr with 238 | | Application (f, x) -> 239 | match go f with 240 | | Some (g, xs) -> Some (g, x :: xs) 241 | | None -> Some (f, [x]) 242 | | _ -> 243 | None 244 | 245 | match go expr with 246 | | None -> None 247 | | Some (f, xs) -> Some (FullAppl (f, List.rev xs)) 248 | 249 | // this function builds LLVM code to implement the given fnDef 250 | let private implementFunction 251 | (modRef:LGC.ModuleRef) 252 | (valMap:Map) 253 | (fnVal:LGC.ValueRef) 254 | (fnDef:Def) 255 | : unit = 256 | 257 | // NOTE: putting all alloca's in an entry block is important to LLVM's 258 | // mem2reg optimization pass so you'll notice that we add all 259 | // allocas using the entryBldr below 260 | let entryBlock = LGC.appendBasicBlock fnVal "entry" 261 | use entryBldr = new LC.Builder(entryBlock) 262 | 263 | // add all of the args to valMap 264 | let valMap = ref valMap 265 | fnDef.funParams |> List.iteri ( 266 | fun i p -> 267 | if p.IsMutable then 268 | failwithf "error in function %s: mutable parameters are not supported" fnDef.funVar.Name 269 | valMap := (!valMap).Add(p.Name, LGC.getParam fnVal (uint32 i)) 270 | ) 271 | 272 | // This function will implement the given Expr by writing LLVM code to the given 273 | // basic block. The ValueRef option in the returned tuple represents the value 274 | // of the expression which will be None for unit expressions. The basic block in 275 | // the return tuple represents the single exit block for the expression (which 276 | // in many cases is the same as the block passed in). 277 | let rec implementExpr 278 | (bb:LGC.BasicBlockRef) 279 | (valMap:Map) 280 | (expr:Expr) 281 | : LGC.ValueRef option * LGC.BasicBlockRef = 282 | 283 | let noImpl() = 284 | match expr with 285 | | Call (_, methInfo, _) -> 286 | failwithf 287 | "error in function %s: call to %s.%s not supported. The full expression is: %A" 288 | fnDef.funVar.Name 289 | methInfo.DeclaringType.FullName 290 | methInfo.Name 291 | expr 292 | | _ -> 293 | failwithf "error in function %s: expression type not supported %A" fnDef.funVar.Name expr 294 | 295 | // convenience function for implementing binary operators 296 | let implBinOp bb llvmBinOp lhsExpr rhsExpr : LGC.ValueRef option * LGC.BasicBlockRef = 297 | let lhsVal, bb = implementSomeExpr bb valMap lhsExpr 298 | let rhsVal, bb = implementSomeExpr bb valMap rhsExpr 299 | use bldr = new LC.Builder(bb) 300 | let resultVal = llvmBinOp bldr lhsVal rhsVal 301 | 302 | Some resultVal, bb 303 | 304 | // this function is used to build short-circuit instructions for && and || operators 305 | let shortCircuit isAndOp lhsExpr rhsExpr = 306 | let lhsVal, lhsBB = implementSomeExpr bb valMap lhsExpr 307 | 308 | let shortCircuitFailedBB = LGC.appendBasicBlock fnVal "shortCircuitFailed" 309 | let shortCircuitExitBB = LGC.appendBasicBlock fnVal "shortCircuitExit" 310 | 311 | // build the short-circuit conditional branch 312 | use bldr = new LC.Builder(lhsBB) 313 | if isAndOp then 314 | LGC.buildCondBr bldr lhsVal shortCircuitFailedBB shortCircuitExitBB |> ignore 315 | else 316 | LGC.buildCondBr bldr lhsVal shortCircuitExitBB shortCircuitFailedBB |> ignore 317 | 318 | // we need to build the block that executes when short-circuit fails 319 | let rhsVal, rhsBB = implementSomeExpr shortCircuitFailedBB valMap rhsExpr 320 | use bldr = new LC.Builder(rhsBB) 321 | LGC.buildBr bldr shortCircuitExitBB |> ignore 322 | 323 | // the exit point just works as a phi for the LHS and RHS 324 | use bldr = new LC.Builder(shortCircuitExitBB) 325 | let result = 326 | LC.buildPhiWithIncoming 327 | bldr 328 | (LGC.int1Type()) 329 | [|(lhsVal, lhsBB); (rhsVal, rhsBB)|] 330 | (if isAndOp then "andResult" else "orResult") 331 | 332 | (Some result, shortCircuitExitBB) 333 | 334 | match expr with 335 | | Sequential (expr1, expr2) -> 336 | let _, bb = implementExpr bb valMap expr1 337 | implementExpr bb valMap expr2 338 | | Let (var, expr1, expr2) -> 339 | match implementExpr bb valMap expr1 with 340 | | None, _ -> 341 | failwithf 342 | "error in function %s for variable %s: unit let-bound expressions are not supported" 343 | fnDef.funVar.Name 344 | var.Name 345 | | Some expr1Val, bb -> 346 | let letVal = 347 | if var.IsMutable then 348 | let alloca = LGC.buildAlloca entryBldr (llvmTyOfVar var) var.Name 349 | use bldr = new LC.Builder(bb) 350 | LGC.buildStore bldr expr1Val alloca |> ignore 351 | alloca 352 | else 353 | LGC.setValueName expr1Val var.Name 354 | expr1Val 355 | implementExpr bb (valMap.Add(var.Name, letVal)) expr2 356 | | IfThenElse (ifExpr, thenExpr, elseExpr) -> 357 | let ifVal, ifBB = implementExpr bb valMap ifExpr 358 | 359 | match ifVal with 360 | | None -> failwith "internal error: unexpected None in \"if value\"" 361 | | Some ifVal -> 362 | let thenBB = LGC.appendBasicBlock fnVal "then" 363 | let elseBB = LGC.appendBasicBlock fnVal "else" 364 | use ifBldr = new LC.Builder(ifBB) 365 | LGC.buildCondBr ifBldr ifVal thenBB elseBB |> ignore 366 | 367 | let thenVal, thenBB = implementExpr thenBB valMap thenExpr 368 | let elseVal, elseBB = implementExpr elseBB valMap elseExpr 369 | 370 | let ifElseJoinBlock = LGC.appendBasicBlock fnVal "ifElseJoin" 371 | use thenBldr = new LC.Builder(thenBB) 372 | LGC.buildBr thenBldr ifElseJoinBlock |> ignore 373 | use elseBldr = new LC.Builder(elseBB) 374 | LGC.buildBr elseBldr ifElseJoinBlock |> ignore 375 | 376 | match thenVal, elseVal with 377 | | None, None -> 378 | None, ifElseJoinBlock 379 | | Some thenVal, Some elseVal -> 380 | use ifElseJoinBldr = new LC.Builder(ifElseJoinBlock) 381 | let ifElsePhi = 382 | LC.buildPhiWithIncoming 383 | ifElseJoinBldr 384 | (llvmTyOfExpr expr) 385 | [|thenVal, thenBB; elseVal, elseBB|] 386 | "ifElsePhi" 387 | Some ifElsePhi, ifElseJoinBlock 388 | | _ -> 389 | failwith "internal error: if/else types don't agree" 390 | | WhileLoop (condExpr, bodyExpr) -> 391 | use bldr = new LC.Builder(bb) 392 | let whileCondBB = LGC.appendBasicBlock fnVal "whileCondition" 393 | LGC.buildBr bldr whileCondBB |> ignore 394 | match implementExpr whileCondBB valMap condExpr with 395 | | None, _ -> failwith "internal error: while condition evaluated as unit" 396 | | Some contLoopVal, whileCondBB -> 397 | use bldr = new LC.Builder(whileCondBB) 398 | let whileBodyBB = LGC.appendBasicBlock fnVal "whileBody" 399 | let loopBreakBB = LGC.appendBasicBlock fnVal "loopExit" 400 | LGC.buildCondBr bldr contLoopVal whileBodyBB loopBreakBB |> ignore 401 | let _, whileBodyBB = implementExpr whileBodyBB valMap bodyExpr 402 | use bldr = new LC.Builder(whileBodyBB) 403 | LGC.buildBr bldr whileCondBB |> ignore 404 | 405 | None, loopBreakBB 406 | | ForIntegerRangeLoop (iVar, startExpr, endExpr, bodyExpr) -> 407 | match implementExpr bb valMap startExpr with 408 | | None, _ -> failwith "internal error: for loop iterator evaluated to unit" 409 | | Some startVal, bb -> 410 | // create the iterator value 411 | LGC.setValueName startVal iVar.Name 412 | let iAlloca = LGC.buildAlloca entryBldr (llvmTyOfVar iVar) iVar.Name 413 | use bldr = new LC.Builder(bb) 414 | LGC.buildStore bldr startVal iAlloca |> ignore 415 | 416 | // create the end value 417 | match implementExpr bb valMap endExpr with 418 | | None, _ -> failwith "internal error: for loop limit expression evaluated to unit" 419 | | Some endVal, bb -> 420 | 421 | // the for loop test block 422 | let forTestBB = LGC.appendBasicBlock fnVal "forTest" 423 | use bldr = new LC.Builder(bb) 424 | LGC.buildBr bldr forTestBB |> ignore 425 | use forTestBldr = new LC.Builder(forTestBB) 426 | let currVal = LGC.buildLoad forTestBldr iAlloca iVar.Name 427 | let forBB = LGC.appendBasicBlock fnVal "forBody" 428 | let loopBreakBB = LGC.appendBasicBlock fnVal "loopExit" 429 | let contLoopVal = LGC.buildICmp forTestBldr LGC.IntPredicate.IntSLE currVal endVal "contLoop" 430 | LGC.buildCondBr forTestBldr contLoopVal forBB loopBreakBB |> ignore 431 | 432 | // create the body of the loop 433 | use forBldr = new LC.Builder(forBB) 434 | let valMap = valMap.Add(iVar.Name, currVal) 435 | let _, forBB = implementExpr forBB valMap bodyExpr 436 | 437 | // increment the var and break to for test block 438 | use forBldr = new LC.Builder(forBB) 439 | let incVal = LGC.buildAdd forBldr currVal (LC.constInt32 1) (iVar.Name + "Incr") 440 | LGC.buildStore forBldr incVal iAlloca |> ignore 441 | LGC.buildBr forBldr forTestBB |> ignore 442 | 443 | None, loopBreakBB 444 | | Var v -> 445 | let valRef = valMap.[v.Name] 446 | if v.IsMutable then 447 | use bldr = new LC.Builder(bb) 448 | Some (LGC.buildLoad bldr valRef v.Name), bb 449 | else 450 | Some valRef, bb 451 | | VarSet (v, expr) -> 452 | match implementExpr bb valMap expr with 453 | | None, _ -> 454 | failwithf 455 | "error in function %s: unit type not supported as a first class value" 456 | fnDef.funVar.Name 457 | | Some valToSet, bb -> 458 | use bldr = new LC.Builder(bb) 459 | LGC.buildStore bldr valToSet valMap.[v.Name] |> ignore 460 | None, bb 461 | | Value (v, ty) -> 462 | match v with 463 | | :? unit -> 464 | None, bb 465 | | _ -> 466 | let valVal = 467 | match v with 468 | | :? bool as v -> LC.constInt1 v 469 | | :? int8 as v -> LC.constInt8 v 470 | | :? uint8 as v -> LC.constUInt8 v 471 | | :? int16 as v -> LC.constInt16 v 472 | | :? uint16 as v -> LC.constUInt16 v 473 | | :? int32 as v -> LC.constInt32 v 474 | | :? uint32 as v -> LC.constUInt32 v 475 | | :? int64 as v -> LC.constInt64 v 476 | | :? uint64 as v -> LC.constUInt64 v 477 | | :? single as v -> LC.constFloat v 478 | | :? double as v -> LC.constDouble v 479 | | _ -> failwithf "error in function %s: type %A not supported" fnDef.funVar.Name ty 480 | Some valVal, bb 481 | | SpecificCall <@@ ignore @@> (_, _, [exprToIgnore]) -> 482 | let _, bb = implementExpr bb valMap exprToIgnore 483 | None, bb 484 | 485 | // boolean ops 486 | | SpecificCall <@@ not @@> (_, _, [exprToNot]) 487 | | SpecificCall <@@ (~~~) @@> (_, _, [exprToNot]) -> 488 | let valToNot, bb = implementSomeExpr bb valMap exprToNot 489 | use bldr = new LC.Builder(bb) 490 | let notVal = LGC.buildNot bldr valToNot "notVal" 491 | Some notVal, bb 492 | | SpecificCall <@@ (=) @@> (_, _, [lhsExpr; rhsExpr]) -> 493 | let binOp bldr lhs rhs = 494 | match lhsExpr.Type, rhsExpr.Type with 495 | | AnyIntTy, AnyIntTy -> 496 | LGC.buildICmp bldr LGC.IntPredicate.IntEQ lhs rhs "tempEq" 497 | | AnyFloatTy, AnyFloatTy -> 498 | LGC.buildFCmp bldr LGC.RealPredicate.RealOEQ lhs rhs "tempFEq" 499 | | _ -> 500 | failwith "internal error: bad args for (=)" 501 | implBinOp bb binOp lhsExpr rhsExpr 502 | | SpecificCall <@@ (<>) @@> (_, _, [lhsExpr; rhsExpr]) -> 503 | let binOp bldr lhs rhs = 504 | match lhsExpr.Type, rhsExpr.Type with 505 | | AnyIntTy, AnyIntTy -> 506 | LGC.buildICmp bldr LGC.IntPredicate.IntNE lhs rhs "tempNEq" 507 | | AnyFloatTy, AnyFloatTy -> 508 | LGC.buildFCmp bldr LGC.RealPredicate.RealONE lhs rhs "tempFNEq" 509 | | _ -> 510 | failwith "internal error: bad args for (=)" 511 | implBinOp bb binOp lhsExpr rhsExpr 512 | | SpecificCall <@@ (>) @@> (_, _, [lhsExpr; rhsExpr]) -> 513 | let binOp bldr lhs rhs = 514 | match lhsExpr.Type, rhsExpr.Type with 515 | | AnySIntTy, AnySIntTy -> 516 | LGC.buildICmp bldr LGC.IntPredicate.IntSGT lhs rhs "tempSGT" 517 | | AnyUIntTy, AnyUIntTy -> 518 | LGC.buildICmp bldr LGC.IntPredicate.IntUGT lhs rhs "tempUGT" 519 | | AnyFloatTy, AnyFloatTy -> 520 | LGC.buildFCmp bldr LGC.RealPredicate.RealOGT lhs rhs "tempFGT" 521 | | _ -> 522 | failwith "internal error: bad args for (>)" 523 | implBinOp bb binOp lhsExpr rhsExpr 524 | | SpecificCall <@@ (>=) @@> (_, _, [lhsExpr; rhsExpr]) -> 525 | let binOp bldr lhs rhs = 526 | match lhsExpr.Type, rhsExpr.Type with 527 | | AnySIntTy, AnySIntTy -> 528 | LGC.buildICmp bldr LGC.IntPredicate.IntSGE lhs rhs "tempSGE" 529 | | AnyUIntTy, AnyUIntTy -> 530 | LGC.buildICmp bldr LGC.IntPredicate.IntUGE lhs rhs "tempUGE" 531 | | AnyFloatTy, AnyFloatTy -> 532 | LGC.buildFCmp bldr LGC.RealPredicate.RealOGE lhs rhs "tempFGE" 533 | | _ -> 534 | failwith "internal error: bad args for (>=)" 535 | implBinOp bb binOp lhsExpr rhsExpr 536 | | SpecificCall <@@ (<) @@> (_, _, [lhsExpr; rhsExpr]) -> 537 | let binOp bldr lhs rhs = 538 | match lhsExpr.Type, rhsExpr.Type with 539 | | AnySIntTy, AnySIntTy -> 540 | LGC.buildICmp bldr LGC.IntPredicate.IntSLT lhs rhs "tempSLT" 541 | | AnyUIntTy, AnyUIntTy -> 542 | LGC.buildICmp bldr LGC.IntPredicate.IntULT lhs rhs "tempULT" 543 | | AnyFloatTy, AnyFloatTy -> 544 | LGC.buildFCmp bldr LGC.RealPredicate.RealOLT lhs rhs "tempFLT" 545 | | _ -> 546 | failwith "internal error: bad args for (<)" 547 | implBinOp bb binOp lhsExpr rhsExpr 548 | | SpecificCall <@@ (<=) @@> (_, _, [lhsExpr; rhsExpr]) -> 549 | let binOp bldr lhs rhs = 550 | match lhsExpr.Type, rhsExpr.Type with 551 | | AnySIntTy, AnySIntTy -> 552 | LGC.buildICmp bldr LGC.IntPredicate.IntSLE lhs rhs "tempSLE" 553 | | AnyUIntTy, AnyUIntTy -> 554 | LGC.buildICmp bldr LGC.IntPredicate.IntULE lhs rhs "tempULE" 555 | | AnyFloatTy, AnyFloatTy -> 556 | LGC.buildFCmp bldr LGC.RealPredicate.RealOLE lhs rhs "tempFLE" 557 | | _ -> 558 | failwith "internal error: bad args for (<=)" 559 | implBinOp bb binOp lhsExpr rhsExpr 560 | | SpecificCall <@@ (&&) @@> (_, _, [lhsExpr; rhsExpr]) -> 561 | shortCircuit true lhsExpr rhsExpr 562 | | SpecificCall <@@ (||) @@> (_, _, [lhsExpr; rhsExpr]) -> 563 | shortCircuit false lhsExpr rhsExpr 564 | 565 | // bitwise ops (other than ~~~) 566 | | SpecificCall <@@ (&&&) @@> (_, _, [lhsExpr; rhsExpr]) -> 567 | let binOp bldr lhs rhs = 568 | LGC.buildAnd bldr lhs rhs "tempAnd" 569 | implBinOp bb binOp lhsExpr rhsExpr 570 | | SpecificCall <@@ (|||) @@> (_, _, [lhsExpr; rhsExpr]) -> 571 | let binOp bldr lhs rhs = 572 | LGC.buildOr bldr lhs rhs "tempOr" 573 | implBinOp bb binOp lhsExpr rhsExpr 574 | | SpecificCall <@@ (^^^) @@> (_, _, [lhsExpr; rhsExpr]) -> 575 | let binOp bldr lhs rhs = 576 | LGC.buildXor bldr lhs rhs "tempXOr" 577 | implBinOp bb binOp lhsExpr rhsExpr 578 | | SpecificCall <@@ (>>>) @@> (_, _, [lhsExpr; rhsExpr]) -> 579 | let binOp bldr lhs rhs = 580 | // both arguments to the shift instruction must be the same integer or 581 | // vector of integer type. 582 | let lhsSize = intTySize lhsExpr.Type 583 | let rhsSize = intTySize rhsExpr.Type 584 | let rhs = 585 | if lhsSize > rhsSize then 586 | // we must extend the LHS 587 | LGC.buildZExt bldr rhs (LGC.typeOf lhs) "" 588 | elif lhsSize < rhsSize then 589 | // we must truncate the RHS 590 | LGC.buildTrunc bldr rhs (LGC.typeOf lhs) "" 591 | else 592 | rhs 593 | 594 | // if it's a signed type in F# then we need to use "arithmetic" shift 595 | if isSignedInt lhsExpr.Type then 596 | LGC.buildAShr bldr lhs rhs "" 597 | else 598 | LGC.buildLShr bldr lhs rhs "" 599 | 600 | implBinOp bb binOp lhsExpr rhsExpr 601 | | SpecificCall <@@ (<<<) @@> (_, _, [lhsExpr; rhsExpr]) -> 602 | let binOp bldr lhs rhs = 603 | // both arguments to the shift instruction must be the same integer or 604 | // vector of integer type. 605 | let lhsSize = intTySize lhsExpr.Type 606 | let rhsSize = intTySize rhsExpr.Type 607 | let rhs = 608 | if lhsSize > rhsSize then 609 | // we must extend the LHS 610 | LGC.buildZExt bldr rhs (LGC.typeOf lhs) "" 611 | elif lhsSize < rhsSize then 612 | // we must truncate the RHS 613 | LGC.buildTrunc bldr rhs (LGC.typeOf lhs) "" 614 | else 615 | rhs 616 | 617 | LGC.buildShl bldr lhs rhs "" 618 | 619 | implBinOp bb binOp lhsExpr rhsExpr 620 | 621 | // arithmetic operations 622 | | SpecificCall <@@ op_UnaryNegation @@> (_, _, [exprToNegate]) -> 623 | let valToNeg, bb = implementSomeExpr bb valMap exprToNegate 624 | use bldr = new LC.Builder(bb) 625 | let negVal = 626 | match exprToNegate.Type with 627 | | AnyIntTy -> LGC.buildNeg bldr valToNeg "tempNeg" 628 | | AnyFloatTy -> LGC.buildFNeg bldr valToNeg "tempFNeg" 629 | | _ -> failwith "internal error: bad args for unary (-)" 630 | Some negVal, bb 631 | | SpecificCall <@@ (-) @@> (_, _, [lhsExpr; rhsExpr]) -> 632 | let binOp bldr lhs rhs = 633 | match lhsExpr.Type, rhsExpr.Type with 634 | | AnyIntTy, AnyIntTy -> LGC.buildSub bldr lhs rhs "tempSub" 635 | | AnyFloatTy, AnyFloatTy -> LGC.buildFSub bldr lhs rhs "tempFSub" 636 | | _ -> failwith "internal error: bad args for (-)" 637 | implBinOp bb binOp lhsExpr rhsExpr 638 | | SpecificCall <@@ (+) @@> (_, _, [lhsExpr; rhsExpr]) -> 639 | let binOp bldr lhs rhs = 640 | match lhsExpr.Type, rhsExpr.Type with 641 | | AnyIntTy, AnyIntTy -> LGC.buildAdd bldr lhs rhs "tempAdd" 642 | | AnyFloatTy, AnyFloatTy -> LGC.buildFAdd bldr lhs rhs "tempFAdd" 643 | | _ -> failwith "internal error: bad args for (+)" 644 | implBinOp bb binOp lhsExpr rhsExpr 645 | | SpecificCall <@@ (*) @@> (_, _, [lhsExpr; rhsExpr]) -> 646 | let binOp bldr lhs rhs = 647 | match lhsExpr.Type, rhsExpr.Type with 648 | | AnyIntTy, AnyIntTy -> LGC.buildMul bldr lhs rhs "tempSMul" 649 | | AnyFloatTy, AnyFloatTy -> LGC.buildFMul bldr lhs rhs "tempFMul" 650 | | _ -> failwith "internal error: bad args for (*)" 651 | implBinOp bb binOp lhsExpr rhsExpr 652 | | SpecificCall <@@ (/) @@> (_, _, [lhsExpr; rhsExpr]) -> 653 | let binOp bldr lhs rhs = 654 | match lhsExpr.Type, rhsExpr.Type with 655 | | AnySIntTy, AnySIntTy -> LGC.buildSDiv bldr lhs rhs "tempSDiv" 656 | | AnyUIntTy, AnyUIntTy -> LGC.buildUDiv bldr lhs rhs "tempUDiv" 657 | | AnyFloatTy, AnyFloatTy -> LGC.buildFDiv bldr lhs rhs "tempFDiv" 658 | | _ -> failwith "internal error: bad args for (/)" 659 | implBinOp bb binOp lhsExpr rhsExpr 660 | | SpecificCall <@@ (%) @@> (_, _, [lhsExpr; rhsExpr]) -> 661 | let binOp bldr lhs rhs = 662 | match lhsExpr.Type, rhsExpr.Type with 663 | | AnySIntTy, AnySIntTy -> LGC.buildSRem bldr lhs rhs "tempSRem" 664 | | AnyUIntTy, AnyUIntTy -> LGC.buildURem bldr lhs rhs "tempURem" 665 | | AnyFloatTy, AnyFloatTy -> LGC.buildFRem bldr lhs rhs "tempFRem" 666 | | _ -> failwith "internal error: bad args for (>)" 667 | implBinOp bb binOp lhsExpr rhsExpr 668 | 669 | // memory management 670 | | SpecificCall <@@ free @@> (_, _, [exprToFree]) -> 671 | match implementExpr bb valMap exprToFree with 672 | | None, _ -> failwith "internal error: dealloc target evaluated as unit" 673 | | Some valToFree, bb -> 674 | use bldr = new LC.Builder(bb) 675 | LGC.buildFree bldr valToFree |> ignore 676 | None, bb 677 | | SpecificCall <@@ heapAllocRawArray @@> (_, _, [sizeExpr]) -> 678 | match implementExpr bb valMap sizeExpr with 679 | | None, _ -> failwith "internal error: array size parameter evaluated as unit" 680 | | Some sizeVal, bb -> 681 | use bldr = new LC.Builder(bb) 682 | let llvmElemTy = llvmTyOf (expr.Type.GetGenericArguments().[0]) 683 | let arr = LGC.buildArrayMalloc bldr llvmElemTy sizeVal "arr" 684 | Some arr, bb 685 | | SpecificCall <@@ stackAllocRawArray @@> (_, _, [sizeExpr]) -> 686 | match implementExpr bb valMap sizeExpr with 687 | | None, _ -> failwith "internal error: array size parameter evaluated as unit" 688 | | Some sizeVal, bb -> 689 | use bldr = new LC.Builder(bb) 690 | let llvmElemTy = llvmTyOf (expr.Type.GetGenericArguments().[0]) 691 | let arr = LGC.buildArrayAlloca bldr llvmElemTy sizeVal "arr" 692 | Some arr, bb 693 | 694 | // array item getter and setter 695 | | PropertyGet (Some instExpr, prop, indexArgExprs) -> 696 | match instExpr.Type, prop.Name, indexArgExprs with 697 | | ArrayTy _, "Item", [iExpr] -> 698 | match implementExpr bb valMap instExpr with 699 | | None, _ -> failwith "internal error: RawArray instance evaluated as unit" 700 | | Some arrVal, bb -> 701 | match implementExpr bb valMap iExpr with 702 | | None, _ -> failwith "internal error: index param of RawArray.Item evaluated as unit" 703 | | Some iVal, bb -> 704 | use bldr = new LC.Builder(bb) 705 | 706 | let itemAddr = LC.buildGEP bldr arrVal [|iVal|] "itemAddr" 707 | let itemVal = LGC.buildLoad bldr itemAddr "itemVal" 708 | Some itemVal, bb 709 | | _ -> 710 | noImpl() 711 | | PropertySet (Some instExpr, prop, indexArgExprs, valExpr) -> 712 | match instExpr.Type, prop.Name, indexArgExprs with 713 | | ArrayTy _, "Item", [iExpr] -> 714 | match implementExpr bb valMap instExpr with 715 | | None, _ -> failwith "internal error: RawArray instance evaluated as unit" 716 | | Some arrVal, bb -> 717 | match implementExpr bb valMap valExpr with 718 | | None, _ -> failwith "internal error: value param of RawArray.Item evaluated as unit" 719 | | Some valVal, bb -> 720 | match implementExpr bb valMap iExpr with 721 | | None, _ -> failwith "internal error: index param of RawArray.Item evaluated as unit" 722 | | Some iVal, bb -> 723 | use bldr = new LC.Builder(bb) 724 | 725 | let itemAddr = LC.buildGEP bldr arrVal [|iVal|] "itemAddr" 726 | LGC.buildStore bldr valVal itemAddr |> ignore 727 | None, bb 728 | | _ -> 729 | noImpl() 730 | 731 | // a function call 732 | | FullAppl (Var f, xs) -> 733 | let argVals, bb = implementExprs bb valMap xs 734 | use bldr = new LC.Builder(bb) 735 | 736 | if expr.Type = typeof then 737 | LC.buildCall bldr valMap.[f.Name] (Array.ofList argVals) "" |> ignore 738 | None, bb 739 | else 740 | let callVal = LC.buildCall bldr valMap.[f.Name] (Array.ofList argVals) (f.Name + "Result") 741 | Some callVal, bb 742 | 743 | // tuple construction and get (tuples are allocated on the heap) 744 | | NewTuple exprs -> 745 | let llvmTupleTy = allocableLLVMTyOf expr.Type 746 | let tupVals, bb = implementExprs bb valMap exprs 747 | use bldr = new LC.Builder(bb) 748 | let tupleVal = LGC.buildMalloc bldr llvmTupleTy "tuple" 749 | 750 | tupVals |> List.iteri ( 751 | fun i currVal -> 752 | let tupItemAddr = LGC.buildStructGEP bldr tupleVal (uint32 i) "" 753 | LGC.buildStore bldr currVal tupItemAddr |> ignore 754 | ) 755 | 756 | Some tupleVal, bb 757 | | TupleGet (tupExpr, i) -> 758 | let tupVal, bb = implementSomeExpr bb valMap tupExpr 759 | use bldr = new LC.Builder(bb) 760 | let tupItemAddr = LGC.buildStructGEP bldr tupVal (uint32 i) "" 761 | let itemVal = LGC.buildLoad bldr tupItemAddr ("tupleItem" + string i) 762 | 763 | Some itemVal, bb 764 | | _ -> 765 | noImpl() 766 | 767 | // a convenience function for calling implementExpr when where a 768 | // None returned ValueRef (ie: unit type value) should be treated as an error 769 | and implementSomeExpr 770 | (bb:LGC.BasicBlockRef) 771 | (valMap:Map) 772 | (expr:Expr) 773 | : LGC.ValueRef * LGC.BasicBlockRef = 774 | match implementExpr bb valMap expr with 775 | | None, _ -> failwith "internal error: expression unexpectedly evaluated as unit" 776 | | Some exprVal, bb -> 777 | exprVal, bb 778 | 779 | // implement many expressions (eg: a parameter list) where none has a unit type 780 | and implementExprs 781 | (bb:LGC.BasicBlockRef) 782 | (valMap:Map) 783 | (exprs:Expr list) 784 | : list * LGC.BasicBlockRef = 785 | let bb = ref bb 786 | let argVals = [ 787 | for expr in exprs -> 788 | let xVal, newBB = implementSomeExpr !bb valMap expr 789 | bb := newBB 790 | xVal 791 | ] 792 | 793 | argVals, !bb 794 | 795 | // the start block imediately follows the entry block 796 | let startBlock = LGC.appendBasicBlock fnVal "start" 797 | ignore <| 798 | match implementExpr startBlock !valMap fnDef.body with 799 | | None, bb -> 800 | use bldr = new LC.Builder(bb) 801 | LGC.buildRetVoid bldr 802 | | Some retVal, bb -> 803 | use bldr = new LC.Builder(bb) 804 | LGC.buildRet bldr retVal 805 | LGC.buildBr entryBldr startBlock |> ignore 806 | 807 | /// Compiles the given quotations into the LLVM module and returns a mapping of function 808 | /// name to LLVM ValueRef. Consult the project README for limitations on what kind 809 | /// of quotations are valid input. 810 | let compileQuote (moduleRef:LGC.ModuleRef) (expr:Expr) : Map = 811 | let funcDefs, endExpr = allLetFuncDefs expr 812 | match endExpr with 813 | | Value (:? unit, _) -> () 814 | | _ -> failwithf "expected the final expression to be unit but it is %A" endExpr 815 | 816 | let mutable varMap = Map.empty 817 | for fd in funcDefs do 818 | //printfn "@@@@ FUNCTION GROUP @@@@" 819 | //printfn "%A" fd 820 | 821 | match fd with 822 | | LetDef def -> 823 | // for non-recursive defs we bind the function variable after it's implemented 824 | let fn = declareFunction moduleRef def 825 | implementFunction moduleRef varMap fn def 826 | varMap <- varMap.Add(def.funVar.Name, fn) 827 | | LetRecDefs defs -> 828 | // for recursive defs we bind the function variable before it's implemented 829 | for def in defs do 830 | let fn = declareFunction moduleRef def 831 | varMap <- varMap.Add(def.funVar.Name, fn) 832 | for def in defs do 833 | implementFunction moduleRef varMap varMap.[def.funVar.Name] def 834 | 835 | varMap 836 | -------------------------------------------------------------------------------- /src/LLVM/Target.fs: -------------------------------------------------------------------------------- 1 | module LLVM.Target 2 | 3 | open System.Runtime.InteropServices 4 | 5 | // Using LLVMInitializeX86Target in this way is kind of a hack. Ideally we would 6 | // just be using LLVMInitializeNativeTarget but unfortunately the symbol for 7 | // LLVMInitializeNativeTarget never makes it into the LLVM shared library since 8 | // it is declared static. See: 9 | // http://llvm.org/docs/doxygen/html/Target_8h_source.html#l00133 10 | [] 11 | extern void private initializeX86TargetInfoNative() 12 | [] 13 | extern void private initializeX86TargetNative() 14 | [] 15 | extern void private initializeX86TargetMCNative() 16 | 17 | let initializeX86Target() = 18 | initializeX86TargetInfoNative() 19 | initializeX86TargetNative() 20 | initializeX86TargetMCNative() 21 | -------------------------------------------------------------------------------- /test/CSSimpleTest2.cs: -------------------------------------------------------------------------------- 1 | using Gen = LLVM.Generated; 2 | using LLVM; 3 | 4 | using System.Runtime.InteropServices; 5 | 6 | public class SimpleTest2 7 | { 8 | // a C# example adapted from http://www.mdevan.org/llvm-py/examples.html 9 | 10 | public static int Main() 11 | { 12 | //Target.initializeX86Target(); 13 | 14 | var myModule = Gen.Core.moduleCreateWithName("tut2"); 15 | 16 | // create a function type taking 2 integers, return a 32-bit integer 17 | var tyInt = Gen.Core.int32Type(); 18 | var funcType = Core.functionType(tyInt, new Gen.Core.TypeRef[] {tyInt, tyInt}); 19 | 20 | // create a function of that type 21 | var gcd = Gen.Core.addFunction(myModule, "gcd", funcType); 22 | 23 | var x = Gen.Core.getParam(gcd, 0u); 24 | var y = Gen.Core.getParam(gcd, 1u); 25 | Gen.Core.setValueName(x, "x"); 26 | Gen.Core.setValueName(y, "y"); 27 | 28 | // implement the function 29 | 30 | // blocks... 31 | var entry = Gen.Core.appendBasicBlock(gcd, "entry"); 32 | var ret = Gen.Core.appendBasicBlock(gcd, "return"); 33 | var condFalse = Gen.Core.appendBasicBlock(gcd, "cond_false"); 34 | var condTrue = Gen.Core.appendBasicBlock(gcd, "cond_true"); 35 | var condFalse2 = Gen.Core.appendBasicBlock(gcd, "cond_false_2"); 36 | 37 | // create a builder 38 | var bldr = new Core.Builder(); 39 | Gen.Core.positionBuilderAtEnd(bldr, entry); 40 | var xEqY = Gen.Core.buildICmp(bldr, Gen.Core.IntPredicate.IntEQ, x, y, "tmp"); 41 | Gen.Core.buildCondBr(bldr, xEqY, ret, condFalse); 42 | 43 | Gen.Core.positionBuilderAtEnd(bldr, ret); 44 | Gen.Core.buildRet(bldr, x); 45 | 46 | Gen.Core.positionBuilderAtEnd(bldr, condFalse); 47 | var xLtY = Gen.Core.buildICmp(bldr, Gen.Core.IntPredicate.IntULT, x, y, "tmp"); 48 | Gen.Core.buildCondBr(bldr, xLtY, condTrue, condFalse2); 49 | 50 | Gen.Core.positionBuilderAtEnd(bldr, condTrue); 51 | var ySubX = Gen.Core.buildSub(bldr, y, x, "tmp"); 52 | var recur1 = Core.buildCall(bldr, gcd, new Gen.Core.ValueRef[] {x, ySubX}, "tmp"); 53 | Gen.Core.buildRet(bldr, recur1); 54 | 55 | Gen.Core.positionBuilderAtEnd(bldr, condFalse2); 56 | var xSubY = Gen.Core.buildSub(bldr, x, y, "x_sub_y"); 57 | var recur2 = Core.buildCall(bldr, gcd, new Gen.Core.ValueRef[] {xSubY, y}, "tmp"); 58 | Gen.Core.buildRet(bldr, recur2); 59 | 60 | Gen.Core.dumpModule(myModule); 61 | Gen.BitWriter.writeBitcodeToFile(myModule, "tut2.bc"); 62 | 63 | var myEng = ExecutionEngine.createExecutionEngineForModule(myModule); 64 | 65 | var _36 = Gen.ExecutionEngine.createGenericValueOfInt(tyInt, 36UL, false); 66 | var _81 = Gen.ExecutionEngine.createGenericValueOfInt(tyInt, 81UL, false); 67 | var result1 = ExecutionEngine.runFunction( 68 | myEng, 69 | gcd, 70 | new Gen.ExecutionEngine.GenericValueRef[] {_36, _81}); 71 | 72 | System.Console.WriteLine( 73 | "gcd(36, 81) -> " + 74 | Gen.ExecutionEngine.genericValueToInt(result1, false)); 75 | 76 | // exit code 77 | return 0; 78 | } 79 | } 80 | 81 | -------------------------------------------------------------------------------- /test/add.fs: -------------------------------------------------------------------------------- 1 | open LLVM.Generated.Core 2 | open LLVM.Core 3 | open LLVM.Generated.BitWriter 4 | 5 | // an F# example adapted from http://www.mdevan.org/llvm-py/examples.html 6 | 7 | [] 8 | let main _ = 9 | 10 | let myModule = moduleCreateWithName "addModule" 11 | 12 | // build a function that adds 2 integers (uses unnecessary load/stores) 13 | let makeAdd1 () = 14 | 15 | // create a function type taking 2 integers, return a 32-bit integer 16 | let tyInt = int32Type () 17 | let funcType = functionType tyInt [|tyInt; tyInt|] 18 | 19 | // create a function of that type 20 | let add = addFunction myModule "add1" funcType 21 | 22 | // name function args 23 | let x = getParam add 0u 24 | let y = getParam add 1u 25 | setValueName x "x" 26 | setValueName y "y" 27 | 28 | // blocks... 29 | let entry = appendBasicBlock add "entry" 30 | let ret = appendBasicBlock add "return" 31 | 32 | // create a builder 33 | use bldr = new Builder () 34 | positionBuilderAtEnd bldr entry 35 | let xAlloca = buildAlloca bldr (int32Type ()) "xAlloca" 36 | let yAlloca = buildAlloca bldr (int32Type ()) "yAlloca" 37 | buildStore bldr x xAlloca |> ignore 38 | buildStore bldr y yAlloca |> ignore 39 | buildBr bldr ret |> ignore 40 | 41 | positionBuilderAtEnd bldr ret 42 | let xLoad = buildLoad bldr xAlloca "xLoad" 43 | let yLoad = buildLoad bldr yAlloca "yLoad" 44 | buildRet bldr (buildAdd bldr xLoad yLoad "retVal") |> ignore 45 | 46 | // build an add function (without the unnecessary load/stores) 47 | let makeAdd2 () = 48 | 49 | // create a function type taking 2 integers, return a 32-bit integer 50 | let tyInt = int32Type () 51 | let funcType = functionType tyInt [|tyInt; tyInt|] 52 | 53 | // create a function of that type 54 | let add = addFunction myModule "add2" funcType 55 | 56 | // name function args 57 | let x = getParam add 0u 58 | let y = getParam add 1u 59 | setValueName x "x" 60 | setValueName y "y" 61 | 62 | // blocks... 63 | let entry = appendBasicBlock add "entry" 64 | use bldr = new Builder () 65 | positionBuilderAtEnd bldr entry 66 | buildRet bldr (buildAdd bldr x y "retVal") |> ignore 67 | 68 | makeAdd1 () 69 | makeAdd2 () 70 | dumpModule myModule 71 | writeBitcodeToFile myModule "addModule.bc" |> ignore 72 | 73 | // exit code 74 | 0 75 | 76 | -------------------------------------------------------------------------------- /test/metadatatest.fs: -------------------------------------------------------------------------------- 1 | open LLVM.Core 2 | open LLVM.Generated.Core 3 | open LLVM.Generated.BitWriter 4 | 5 | let i32 = int32Type () 6 | let i32zero = constInt i32 0UL false 7 | 8 | [] 9 | let main argv = 10 | // Set up the module/function 11 | let module_ = moduleCreateWithName "foobar" 12 | let funcTy = functionType i32 [||] 13 | let func = addFunction module_ "main" funcTy 14 | let bldr = createBuilder () 15 | 16 | let entry = appendBasicBlock func "entry" 17 | positionBuilderAtEnd bldr entry 18 | 19 | // Make a Metadata node and try and attach it to a ret 20 | let mdstring = mDString "bazquux" 7u 21 | let ret = buildRet bldr i32zero 22 | // From http://llvm.org/docs/doxygen/html/classllvm_1_1LLVMContext.html 23 | // MD_dbg = 0, MD_tbaa = 1, MD_prof = 2, MD_fpmath = 3, MD_range = 4, MD_tbaa_struct = 5 24 | // Fails here 25 | let myMDName = "my_MD_kind" 26 | setMetadata ret (getMDKindID myMDName (uint32 myMDName.Length)) (mdNode [|mdstring|]) 27 | 28 | // Save bitcode to file 29 | writeBitcodeToFile module_ "metadatatest.bc" 30 | -------------------------------------------------------------------------------- /test/printadds.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern int add1(int, int); 5 | extern int add2(int, int); 6 | 7 | int main(int argc, const char* argv[]) 8 | { 9 | printf("add1(3, 8) -> %i\n", add1(3, 8)); 10 | printf("add2(3, 8) -> %i\n", add2(3, 8)); 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /test/quotetest.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | //#include 4 | 5 | extern int sum869(); 6 | extern int sum(int*, int); 7 | extern int sumUsingWhile(int*, int); 8 | extern double sumDoublesOnStack(); 9 | extern int* makeArr(); 10 | extern double* transpose(double*, int); 11 | extern double* matMult(double*, int, int, double*, int); 12 | extern double* solveWithGaussAndBackSub(double*, double*, int); 13 | extern int shl3(int); 14 | extern int sshr(int, int); 15 | extern int ushr(int, int); 16 | extern short shortshr(short, int); 17 | 18 | void printMat(double* mat, int rowCount, int colCount) { 19 | int row; 20 | int col; 21 | for(row = 0; row < rowCount; row++) { 22 | for(col = 0; col < colCount; col++) { 23 | printf("%f\t", mat[row * colCount + col]); 24 | } 25 | printf("\n"); 26 | } 27 | } 28 | 29 | int main(int argc, const char* argv[]) 30 | { 31 | int i; 32 | int* arr = makeArr(); 33 | printf("makeArr() -> [%i, %i, %i]\n", arr[0], arr[1], arr[2]); 34 | 35 | int xs[] = {8, 6, 9}; 36 | printf("xs -> [%i, %i, %i]\n", xs[0], xs[1], xs[2]); 37 | printf("sum() -> %i\n", sum(xs, 3)); 38 | printf("sum869() -> %i\n", sum869()); 39 | printf("sumUsingWhile() -> %i\n", sumUsingWhile(xs, 3)); 40 | printf("sumDoublesOnStack() -> %f\n", sumDoublesOnStack()); 41 | printf("shl3(1) -> %i\n", shl3(1)); 42 | printf("sshr(shl3(1), 2) -> %i\n", sshr(shl3(1), 2)); 43 | printf("sshr(-16, 2) -> %i\n", sshr(-16, 2)); 44 | printf("ushr(-16, 2) -> %i\n", ushr(-16, 2)); 45 | printf("shortshr(16, 2) -> %i\n", shortshr((short)16, 2)); 46 | 47 | double sqMat[] = { 48 | 1.0, 2.0, 3.0, 49 | 4.0, 5.0, 6.0, 50 | 7.0, 8.0, 9.0}; 51 | printf("before transpose:\n"); 52 | printMat(sqMat, 3, 3); 53 | transpose(sqMat, 3); 54 | printf("after transpose:\n"); 55 | printMat(sqMat, 3, 3); 56 | printf("\n"); 57 | 58 | double testMat1[] = { 59 | 2, 0, -1, 1, 60 | 1, 2, 0, 1}; 61 | printMat(testMat1, 2, 4); 62 | printf("X\n"); 63 | 64 | double testMat2[] = { 65 | 1, 5, -7, 66 | 1, 1, 0, 67 | 0, -1, 1, 68 | 2, 0, 0}; 69 | printMat(testMat2, 4, 3); 70 | printf("=\n"); 71 | double* mmResult = matMult(testMat1, 2, 4, testMat2, 3); 72 | printMat(mmResult, 2, 3); 73 | printf("\n"); 74 | 75 | free(mmResult); 76 | 77 | double mCoefMatrix[] = { 78 | 2.0, 1.0, 1.0, 79 | 6.0, 3.0, 1.0, 80 | -2.0, 2.0, 1.0 81 | }; 82 | printf("Coefficient Matrix:\n"); 83 | printMat(mCoefMatrix, 3, 3); 84 | double mRHSVector[] = {1.0, -1.0, 7.0}; 85 | printf("Right Hand Side Vector:\n"); 86 | for(i = 0; i < 3; i++) { 87 | printf("%f\n", mRHSVector[i]); 88 | } 89 | printf("Equation solution:\n"); 90 | double* solution = solveWithGaussAndBackSub(mCoefMatrix, mRHSVector, 3); 91 | for(i = 0; i < 3; i++) { 92 | printf("%f\n", solution[i]); 93 | } 94 | free(solution); 95 | 96 | return 0; 97 | } 98 | -------------------------------------------------------------------------------- /test/quotetest.fs: -------------------------------------------------------------------------------- 1 | open LLVM.Quote 2 | open LLVM.Generated.Core 3 | open LLVM.Core 4 | open LLVM.Generated.ExecutionEngine 5 | open LLVM.ExecutionEngine 6 | open LLVM.Generated.Target 7 | open LLVM.Generated.BitWriter 8 | open LLVM.BitReader 9 | 10 | // first create some simple quotations for testing 11 | let testQuote = 12 | <@ 13 | // let's start with some super-simple functions 14 | let isEven x = x % 2 = 0 15 | 16 | // simple recursion 17 | let rec fib = function 18 | | 0 -> 0 19 | | 1 -> 1 20 | | n -> fib (n - 1) + fib (n - 2) 21 | 22 | // mutually recursive function def 23 | let rec mutRecIsEven = function 24 | | 0u -> true 25 | | n -> mutRecIsOdd (n - 1u) 26 | and mutRecIsOdd = function 27 | | 0u -> false 28 | | n -> mutRecIsEven (n - 1u) 29 | 30 | // for loop with a mutable 31 | let fac x : int = 32 | let mutable accum = 1 33 | for i = 2 to x do 34 | accum <- accum * i 35 | accum 36 | 37 | // simple array with for loop 38 | let sum (xs:RawArray) (size:int) : int = 39 | let mutable sum = 0 40 | for i = 0 to size - 1 do 41 | sum <- sum + xs.[i] 42 | sum 43 | 44 | // simple array with while loop 45 | let sumUsingWhile (xs:RawArray) (size:int) : int = 46 | let mutable sum = 0 47 | let mutable i = 0 48 | while i < size do 49 | sum <- sum + xs.[i] 50 | i <- i + 1 51 | sum 52 | 53 | let sum869() : int = 54 | 55 | // some pointless tuple code 56 | let tup = (8, 6, 9) 57 | let x, y, z = tup 58 | free tup 59 | 60 | // build the array and call sum 61 | let size = 3 62 | let arr = heapAllocRawArray size 63 | arr.[0] <- x 64 | arr.[1] <- y 65 | arr.[2] <- z 66 | let result = sum arr size 67 | free arr 68 | 69 | result 70 | 71 | // simple array with for loop 72 | let sumDoubles (xs:RawArray) (size:int) : double = 73 | let mutable sum = 0.0 74 | for i = 0 to size - 1 do 75 | sum <- sum + xs.[i] 76 | sum 77 | 78 | let sumDoublesOnStack() : double = 79 | 80 | // build the array and call sum 81 | let size = 3 82 | let arr = stackAllocRawArray size 83 | arr.[0] <- 8.5 84 | arr.[1] <- 6.5 85 | arr.[2] <- 9.5 86 | let result = sumDoubles arr size 87 | 88 | result 89 | 90 | let makeArr() : RawArray = 91 | 92 | // some pointless tuple code 93 | let tup = (8, 6, 9) 94 | let x, y, z = tup 95 | free tup 96 | 97 | // build the array 98 | let size = 3 99 | let arr = heapAllocRawArray size 100 | arr.[0] <- x 101 | arr.[1] <- y 102 | arr.[2] <- z 103 | arr 104 | 105 | let shl3 (x:int) : int = 106 | x <<< 3 107 | let sshr (x:int) (bits:int) : int = 108 | x >>> bits 109 | let ushr (x:uint32) (bits:int) : uint32 = 110 | x >>> bits 111 | let shortshr (x:int16) (bits:int) : int16 = 112 | x >>> bits 113 | 114 | () 115 | @> 116 | 117 | // now create a quotation with more complex linear algebra code 118 | let linAlgQuote = 119 | <@ 120 | let transpose (squareMat:RawArray) (rowColCount:int) : unit = 121 | for row = 0 to rowColCount - 1 do 122 | for col = row + 1 to rowColCount - 1 do 123 | let index1 = row * rowColCount + col 124 | let index2 = col * rowColCount + row 125 | 126 | let tmp = squareMat.[index1] 127 | squareMat.[index1] <- squareMat.[index2] 128 | squareMat.[index2] <- tmp 129 | 130 | let dotProdRowCol 131 | (m1:RawArray) numCols1 132 | (m2:RawArray) numCols2 133 | row col = 134 | let mutable dotProd = 0.0 135 | for i = 0 to numCols1 - 1 do 136 | dotProd <- dotProd + m1.[row * numCols1 + i] * m2.[i * numCols2 + col] 137 | dotProd 138 | 139 | let matMult (m1:RawArray) numRows1 numCols1 (m2:RawArray) numCols2 = 140 | let matMulResult = heapAllocRawArray (numRows1 * numCols2) 141 | for row = 0 to numRows1 - 1 do 142 | let rowOffset = row * numCols2 143 | for col = 0 to numCols2 - 1 do 144 | matMulResult.[rowOffset + col] <- dotProdRowCol m1 numCols1 m2 numCols2 row col 145 | matMulResult 146 | 147 | let reorderArray (arr : RawArray) (order : RawArray) (len:int) = 148 | let tempArr = heapAllocRawArray len 149 | for i = 0 to len - 1 do 150 | tempArr.[i] <- arr.[order.[i]] 151 | for i = 0 to len - 1 do 152 | arr.[i] <- tempArr.[i] 153 | free tempArr 154 | 155 | let reorderMatrixRows (matrix:RawArray) (rowOrder:RawArray) size : unit = 156 | let sizeSq = size * size 157 | let tempMat = heapAllocRawArray sizeSq 158 | for i = 0 to sizeSq - 1 do 159 | tempMat.[i] <- matrix.[i] 160 | for row = 0 to size - 1 do 161 | let row2 = rowOrder.[row] 162 | if row <> row2 then 163 | let offset1 = row * size 164 | let offset2 = row2 * size 165 | for col = 0 to size - 1 do 166 | matrix.[offset1 + col] <- tempMat.[offset2 + col] 167 | free tempMat 168 | 169 | let abs x = if x >= 0.0 then x else -x 170 | let isNearZero x = 171 | let nearZero = 1e-8 172 | x < nearZero && x > -(nearZero) 173 | 174 | /// 175 | /// Use guassian elimination with pivoting to calculate LU decomposition for the 176 | /// given matrix. Since pivoting changes row ordering the reordered indices are 177 | /// returned. 178 | /// 179 | /// 180 | /// the coefficient matrix (must be square). This matrix is destructively 181 | /// updated resulting in the upper triangle containing U and the 182 | /// lower triangle containing L for the LU decomposition 183 | /// 184 | /// the row and column counts of matrix 185 | /// 186 | /// the row order array of the matrix resulting from all of the pivoting 187 | /// operations 188 | /// 189 | let luDecompose (matrix:RawArray) (size:int) : RawArray = 190 | //let size = Array2D.length1 matrix 191 | 192 | //let rowOrder = [|0 .. size - 1|] 193 | let rowOrder = heapAllocRawArray size 194 | for i = 0 to size - 1 do 195 | rowOrder.[i] <- i 196 | 197 | for diagIndex = 0 to size - 2 do 198 | // perform "partial pivoting" which bubbles the max absolute coefficient 199 | // to the top (improves algorithm's accuracy) 200 | let mutable maxIndex = diagIndex 201 | let mutable maxAbsCoef = abs matrix.[rowOrder.[diagIndex] * size + diagIndex] 202 | for j = diagIndex + 1 to size - 1 do 203 | let currAbsVal = abs matrix.[rowOrder.[j] * size + diagIndex] 204 | if currAbsVal > maxAbsCoef then 205 | maxAbsCoef <- currAbsVal 206 | maxIndex <- j 207 | 208 | // now swap the max row with the current 209 | if maxIndex <> diagIndex then 210 | let tmp = rowOrder.[diagIndex] 211 | rowOrder.[diagIndex] <- rowOrder.[maxIndex] 212 | rowOrder.[maxIndex] <- tmp 213 | 214 | // now "zero out" the coefficients below the diagonal 215 | let diagCoef = matrix.[rowOrder.[diagIndex] * size + diagIndex] 216 | for row = diagIndex + 1 to size - 1 do 217 | let orderedRow = rowOrder.[row] 218 | let currCoef = matrix.[orderedRow * size + diagIndex] 219 | let zeroFactor = currCoef / diagCoef 220 | if not (isNearZero zeroFactor) then 221 | for col = diagIndex + 1 to size - 1 do 222 | matrix.[orderedRow * size + col] <- 223 | matrix.[orderedRow * size + col] - 224 | (zeroFactor * matrix.[rowOrder.[diagIndex] * size + col]) 225 | matrix.[orderedRow * size + diagIndex] <- zeroFactor 226 | 227 | reorderMatrixRows matrix rowOrder size 228 | rowOrder 229 | 230 | // solve a matrix that is zeroed out below the diagonal using 231 | // back substitution 232 | let backSubstituteUpper 233 | (upperTriangleMat:RawArray) 234 | (rhsVec:RawArray) 235 | (size:int) 236 | : RawArray = 237 | 238 | let solution = heapAllocRawArray size 239 | for i = 0 to size - 1 do 240 | solution.[i] <- 0.0 241 | 242 | //for i = size - 1 downto 0 do 243 | let mutable i = size - 1 244 | while i >= 0 do 245 | let rowOffset = i * size 246 | let mutable sum = 0.0 247 | //for j = n - 1 downto i + 1 do 248 | let mutable j = size - 1 249 | while j >= i + 1 do 250 | sum <- sum + (upperTriangleMat.[rowOffset + j] * solution.[j]) 251 | j <- j - 1 252 | solution.[i] <- ((rhsVec.[i] - sum) / upperTriangleMat.[rowOffset + i] : double) 253 | i <- i - 1 254 | solution 255 | 256 | let solveLU (luMatrix:RawArray) (rhsVec:RawArray) (size:int) : RawArray = 257 | for col = 0 to size - 2 do 258 | for row = col + 1 to size - 1 do 259 | rhsVec.[row] <- rhsVec.[row] - (rhsVec.[col] * luMatrix.[row * size + col]) 260 | backSubstituteUpper luMatrix rhsVec size 261 | 262 | let solveWithGaussAndBackSub 263 | (coefMat:RawArray) 264 | (rhsVec:RawArray) 265 | (size:int) 266 | : RawArray = 267 | 268 | let rowOrder = luDecompose coefMat size 269 | reorderArray rhsVec rowOrder size 270 | free rowOrder 271 | solveLU coefMat rhsVec size 272 | 273 | () 274 | @> 275 | 276 | [] 277 | let main _ = 278 | 279 | let llvmModuleRef = moduleCreateWithName "quote-module" 280 | compileQuote llvmModuleRef testQuote |> ignore 281 | compileQuote llvmModuleRef linAlgQuote |> ignore 282 | dumpModule llvmModuleRef 283 | writeBitcodeToFile llvmModuleRef "quotemodule.bc" |> ignore 284 | 285 | // exit success 286 | 0 287 | 288 | -------------------------------------------------------------------------------- /test/simpletest.fs: -------------------------------------------------------------------------------- 1 | open LLVM.Generated.Core 2 | open LLVM.Core 3 | open LLVM.Generated.BitWriter 4 | 5 | // an F# example adapted from http://www.mdevan.org/llvm-py/examples.html 6 | 7 | [] 8 | let main _ = 9 | 10 | let myModule = moduleCreateWithName "my_module" 11 | let tyInt = int32Type () 12 | let tyFunc = functionType tyInt [|tyInt; tyInt|] 13 | let fSum = addFunction myModule "sum" tyFunc 14 | 15 | setValueName (getParam fSum 0u) "a" 16 | setValueName (getParam fSum 1u) "b" 17 | let builder = createBuilder () 18 | positionBuilderAtEnd builder (appendBasicBlock fSum "entry") 19 | buildAdd builder (getParam fSum 0u) (getParam fSum 1u) "tmp" 20 | |> buildRet builder 21 | |> ignore 22 | 23 | writeBitcodeToFile myModule "my-module.bc" 24 | 25 | -------------------------------------------------------------------------------- /test/simpletest2.fs: -------------------------------------------------------------------------------- 1 | open LLVM.Generated.Core 2 | open LLVM.Core 3 | open LLVM.Generated.BitWriter 4 | open LLVM.Generated.ExecutionEngine 5 | open LLVM.ExecutionEngine 6 | open LLVM.Generated.Target 7 | //open LLVM.Target 8 | 9 | // an F# example adapted from http://www.mdevan.org/llvm-py/examples.html 10 | 11 | [] 12 | let main _ = 13 | 14 | //initializeX86Target() 15 | 16 | let myModule = moduleCreateWithName "tut2" 17 | 18 | // create a function type taking 2 integers, return a 32-bit integer 19 | let tyInt = int32Type() 20 | let funcType = functionType tyInt [|tyInt; tyInt|] 21 | 22 | // create a function of that type 23 | let gcd = addFunction myModule "gcd" funcType 24 | 25 | // name function args 26 | let x = getParam gcd 0u 27 | let y = getParam gcd 1u 28 | setValueName x "x" 29 | setValueName y "y" 30 | 31 | // implement the function 32 | 33 | // blocks... 34 | let entry = appendBasicBlock gcd "entry" 35 | let ret = appendBasicBlock gcd "return" 36 | let condFalse = appendBasicBlock gcd "cond_false" 37 | let condTrue = appendBasicBlock gcd "cond_true" 38 | let condFalse2 = appendBasicBlock gcd "cond_false_2" 39 | 40 | // create a builder 41 | use bldr = new Builder() 42 | positionBuilderAtEnd bldr entry 43 | let xEqY = buildICmp bldr IntPredicate.IntEQ x y "tmp" 44 | buildCondBr bldr xEqY ret condFalse |> ignore 45 | 46 | positionBuilderAtEnd bldr ret 47 | buildRet bldr x |> ignore 48 | 49 | positionBuilderAtEnd bldr condFalse 50 | let xLtY = buildICmp bldr IntPredicate.IntULT x y "tmp" 51 | buildCondBr bldr xLtY condTrue condFalse2 |> ignore 52 | 53 | positionBuilderAtEnd bldr condTrue 54 | let ySubX = buildSub bldr y x "tmp" 55 | let recur1 = buildCall bldr gcd [|x; ySubX|] "tmp" 56 | buildRet bldr recur1 |> ignore 57 | 58 | positionBuilderAtEnd bldr condFalse2 59 | let xSubY = buildSub bldr x y "x_sub_y" 60 | let recur2 = buildCall bldr gcd [|xSubY; y|] "tmp" 61 | buildRet bldr recur2 |> ignore 62 | 63 | dumpModule myModule 64 | writeBitcodeToFile myModule "tut2.bc" |> ignore 65 | 66 | let myEng = createExecutionEngineForModule myModule 67 | 68 | let _36 = createGenericValueOfInt tyInt 36UL false 69 | let _81 = createGenericValueOfInt tyInt 81UL false 70 | let result1 = runFunction myEng gcd [|_36; _81|] 71 | 72 | printfn "gcd(36, 81) -> %i" (genericValueToInt result1 false) 73 | 74 | // exit code 75 | 0 76 | 77 | --------------------------------------------------------------------------------