├── .github └── workflows │ └── ci.yml ├── .gitignore ├── GNUmakefile ├── LICENSE ├── Papyrus.lean ├── Papyrus ├── Builders.lean ├── Context.lean ├── ExecutionEngineRef.lean ├── FFI.lean ├── GenericValueRef.lean ├── IR.lean ├── IR │ ├── AddressSpace.lean │ ├── Align.lean │ ├── ArgumentRef.lean │ ├── BasicBlockRef.lean │ ├── CallingConvention.lean │ ├── ConstantRef.lean │ ├── ConstantRefs.lean │ ├── FunctionRef.lean │ ├── GlobalModifiers.lean │ ├── GlobalRefs.lean │ ├── GlobalVariableRef.lean │ ├── InstructionKind.lean │ ├── InstructionModifiers.lean │ ├── InstructionRef.lean │ ├── InstructionRefs.lean │ ├── ModuleRef.lean │ ├── Type.lean │ ├── TypeBases.lean │ ├── TypeID.lean │ ├── TypeRef.lean │ ├── TypeRefs.lean │ ├── Types.lean │ ├── ValueKind.lean │ └── ValueRef.lean ├── Init.lean ├── Internal │ └── Enum.lean ├── MemoryBufferRef.lean ├── Script.lean └── Script │ ├── AddressSpace.lean │ ├── Do.lean │ ├── Dump.lean │ ├── Function.lean │ ├── GlobalModifiers.lean │ ├── Instructions.lean │ ├── IntegerType.lean │ ├── Jit.lean │ ├── Label.lean │ ├── Module.lean │ ├── ParserUtil.lean │ ├── SyntaxUtil.lean │ ├── Type.lean │ ├── Value.lean │ └── Verify.lean ├── README.md ├── c ├── Makefile ├── include │ ├── papyrus.h │ └── papyrus_ffi.h └── src │ ├── adt.cpp │ ├── basic_block.cpp │ ├── bitcode.cpp │ ├── constant.cpp │ ├── context.cpp │ ├── execution_engine.cpp │ ├── function.cpp │ ├── generic_value.cpp │ ├── global.cpp │ ├── global_variable.cpp │ ├── init.cpp │ ├── instruction.cpp │ ├── memory_buffer.cpp │ ├── module.cpp │ ├── type.cpp │ └── value.cpp ├── leanWithPlugin.sh ├── leanpkg.toml ├── plugin ├── Makefile └── PapyrusPlugin.lean └── test ├── .gitignore ├── Makefile ├── common.sh ├── main └── program.lean ├── out └── script │ ├── dump.lean │ ├── dump.lean.expected.out │ ├── jit.lean │ ├── jit.lean.expected.out │ ├── program.lean │ ├── program.lean.expected.out │ ├── type.lean │ ├── type.lean.expected.out │ ├── value.lean │ ├── value.lean.expected.out │ ├── verify.lean │ └── verify.lean.expected.out ├── run └── ir │ ├── basicBlockRef.lean │ ├── constantRefs.lean │ ├── functionRef.lean │ ├── globalVariableRef.lean │ ├── instructionRefs.lean │ ├── moduleRef.lean │ └── types.lean ├── test_main.sh ├── test_out.sh └── test_run.sh /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.name }} 12 | runs-on: ${{ matrix.os }} 13 | defaults: 14 | run: 15 | shell: ${{ matrix.shell || 'sh' }} 16 | strategy: 17 | matrix: 18 | include: 19 | - name: Ubuntu 20 | os: ubuntu-latest 21 | - name: MacOS 22 | os: macos-latest 23 | - name: Windows 24 | os: windows-latest 25 | shell: msys2 {0} 26 | # complete all jobs 27 | fail-fast: false 28 | steps: 29 | - name: Install MSYS2 w/ LLVM (Windows) 30 | if: matrix.os == 'windows-latest' 31 | uses: msys2/setup-msys2@v2 32 | with: 33 | path-type: inherit 34 | install: curl unzip make mingw-w64-x86_64-llvm mingw-w64-x86_64-gcc diffutils 35 | - name: Install Elan (Ubuntu) 36 | if: matrix.os == 'ubuntu-latest' 37 | run: | 38 | curl -sSL https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh > elan-init.sh 39 | chmod +x elan-init.sh 40 | ./elan-init.sh -y 41 | echo "$HOME/.elan/bin" >> $GITHUB_PATH 42 | - name: Install Elan (Windows) 43 | if: matrix.os == 'windows-latest' 44 | run: | 45 | curl -sSL https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh > elan-init.sh 46 | ./elan-init.sh -y 47 | cygpath -w "$USERPROFILE/.elan/bin" >> $GITHUB_PATH 48 | - name: Install Elan (MacOS) 49 | if: matrix.os == 'macOS-latest' 50 | run: brew install elan 51 | - name: Install LLVM (MacOS) 52 | if: matrix.os == 'macOS-latest' 53 | run: | 54 | brew install llvm@12 55 | echo "$(brew --prefix)/opt/llvm@12/bin" >> $GITHUB_PATH 56 | - name: Install LLVM (Ubuntu) 57 | if: matrix.os == 'ubuntu-latest' 58 | run: | 59 | sudo apt-get install llvm-12 60 | llvm-config-12 --bindir >> $GITHUB_PATH 61 | - name: Checkout 62 | uses: actions/checkout@v2 63 | - name: Check Lean 64 | run: lean --version 65 | - name: Build C Lib 66 | run: make -C c -j4 67 | - name: Build Lean Lib 68 | run: make lib -j4 69 | - name: Build Lean Plugin 70 | run: make -C plugin -j4 71 | - name: Test 72 | run: make -C test -j4 73 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | ifndef LEAN_HOME 2 | LEAN ?= lean 3 | LEAN_HOME := $(shell $(LEAN) --print-prefix) 4 | endif 5 | 6 | OS_NAME := ${OS} 7 | ifneq ($(OS_NAME),Windows_NT) 8 | OS_NAME := $(shell uname -s) 9 | endif 10 | 11 | RMPATH := rm -rf 12 | LEANMAKEFILE := ${LEAN_HOME}/share/lean/lean.mk 13 | LEANMAKE := $(MAKE) -f $(LEANMAKEFILE) 14 | 15 | all: plugin 16 | 17 | clean: clean-c clean-lib clean-plugin clean-test 18 | 19 | .PHONY: c lib plugin test clean 20 | 21 | c: 22 | $(MAKE) -C c 23 | 24 | clean-c: 25 | $(MAKE) -C c clean 26 | 27 | lib: 28 | +$(LEANMAKE) lib PKG=Papyrus MORE_DEPS=leanpkg.toml OUT=build/$(OS_NAME) 29 | 30 | clean-lib: 31 | $(RMPATH) build 32 | 33 | plugin: lib c 34 | $(MAKE) -C plugin 35 | 36 | clean-plugin: 37 | $(MAKE) -C plugin clean 38 | 39 | test: plugin 40 | $(MAKE) -C test 41 | 42 | clean-test: 43 | $(MAKE) -C test clean 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2.0 (Apache) 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. 13 | 14 | "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. 15 | 16 | "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. 17 | 18 | "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. 19 | 20 | "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. 21 | 22 | "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). 23 | 24 | "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. 25 | 26 | "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." 27 | 28 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 29 | 30 | 2. Grant of Copyright License. 31 | 32 | Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 33 | 34 | 3. Grant of Patent License. 35 | 36 | Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 37 | 38 | 4. Redistribution. 39 | 40 | You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: 41 | 42 | 1. You must give any other recipients of the Work or Derivative Works a copy of this License; and 43 | 44 | 2. You must cause any modified files to carry prominent notices stating that You changed the files; and 45 | 46 | 3. You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and 47 | 48 | 4. If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. 49 | 50 | You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 51 | 52 | 5. Submission of Contributions. 53 | 54 | Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 55 | 56 | 6. Trademarks. 57 | 58 | This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 59 | 60 | 7. Disclaimer of Warranty. 61 | 62 | Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 63 | 64 | 8. Limitation of Liability. 65 | 66 | In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 67 | 68 | 9. Accepting Warranty or Additional Liability. 69 | 70 | While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. 71 | -------------------------------------------------------------------------------- /Papyrus.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Init 2 | import Papyrus.Context 3 | import Papyrus.MemoryBufferRef 4 | import Papyrus.ExecutionEngineRef 5 | import Papyrus.GenericValueRef 6 | import Papyrus.IR 7 | import Papyrus.Builders 8 | import Papyrus.Script 9 | -------------------------------------------------------------------------------- /Papyrus/Builders.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.ModuleRef 3 | import Papyrus.IR.FunctionRef 4 | import Papyrus.IR.GlobalVariableRef 5 | import Papyrus.IR.InstructionRefs 6 | 7 | namespace Papyrus 8 | 9 | -- # Module Builder 10 | 11 | abbrev ModuleM := ReaderT ModuleRef LlvmM 12 | 13 | protected def ModuleM.runIn (mod : ModuleRef) (self : ModuleM α) : LlvmM α := 14 | self mod 15 | 16 | -- # Basic Block Builder 17 | 18 | structure BasicBlockContext where 19 | modRef : ModuleRef 20 | funRef : FunctionRef 21 | bbRef : BasicBlockRef 22 | 23 | abbrev BasicBlockM := ReaderT BasicBlockContext LlvmM 24 | 25 | instance : MonadLift ModuleM BasicBlockM where 26 | monadLift m := fun ctx => m ctx.modRef 27 | 28 | protected def BasicBlockM.runIn (ctx : BasicBlockContext) (self : BasicBlockM α) : LlvmM α := 29 | self ctx 30 | 31 | namespace Builder 32 | 33 | def module (name : String) (builder : ModuleM PUnit) : LlvmM ModuleRef := do 34 | let modRef ← ModuleRef.new name 35 | builder.runIn modRef 36 | return modRef 37 | 38 | -- ## Module Builder Actions 39 | 40 | /-- Add a global variable to the module. -/ 41 | def globalVar (type : TypeRef) 42 | (isConstant := false) (linkage := Linkage.external) (name : @& String := "") 43 | (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) (isExternallyInitialized := false) 44 | : ModuleM GlobalVariableRef := do 45 | let gblRef ← GlobalVariableRef.new type isConstant linkage name tlm addrSpace isExternallyInitialized 46 | (← read).appendGlobalVariable gblRef 47 | return gblRef 48 | 49 | /-- Add a global variable with an initializer to the module. -/ 50 | def globalVarInit (init : ConstantRef) 51 | (isConstant := false) (linkage := Linkage.external) (name : @& String := "") 52 | (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) 53 | : ModuleM GlobalVariableRef := do 54 | let gblRef ← GlobalVariableRef.ofConstant init isConstant linkage name tlm addrSpace 55 | (← read).appendGlobalVariable gblRef 56 | return gblRef 57 | 58 | /-- Add a string constant to the module. -/ 59 | def string (str : String) 60 | (addrSpace := AddressSpace.default) (withNull := true) (name := "") 61 | : ModuleM GlobalVariableRef := do 62 | let gblRef ← GlobalVariableRef.ofString str addrSpace withNull name 63 | (← read).appendGlobalVariable gblRef 64 | return gblRef 65 | 66 | /-- Add a string constant to the module and return a constant pointer to its head. -/ 67 | def stringPtr (str : String) 68 | (addrSpace := AddressSpace.default) (withNull := true) (name := "") 69 | : ModuleM ConstantRef := do 70 | let gblRef ← string str addrSpace withNull name 71 | let zeroRef ← ConstantIntRef.ofUInt32 0 72 | let ptrRef ← ConstantExprRef.getGetElementPtr gblRef #[zeroRef, zeroRef] true 73 | return ptrRef 74 | 75 | /-- Add a arbitrary constant to the module. -/ 76 | def globalConst (init : ConstantRef) 77 | (linkage := Linkage.linkOnceODR) (name := "") 78 | (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) : ModuleM GlobalVariableRef := do 79 | let gblRef ← GlobalVariableRef.ofConstant init true linkage name tlm addrSpace 80 | (← read).appendGlobalVariable gblRef 81 | return gblRef 82 | 83 | /-- Add a function declaration to the module. -/ 84 | def declare (type : FunctionTypeRef) (name : String) 85 | (linkage := Linkage.external) (addrSpace := AddressSpace.default) : ModuleM FunctionRef := do 86 | let funRef ← FunctionRef.create type name linkage addrSpace 87 | (← read).appendFunction funRef 88 | return funRef 89 | 90 | /-- Define a new a function in the module. -/ 91 | def define (type : FunctionTypeRef) (builder : BasicBlockM PUnit) (name : String := "") 92 | (linkage := Linkage.external) (addrSpace := AddressSpace.default) (entry : String := "") : ModuleM FunctionRef := do 93 | let funRef ← FunctionRef.create type name linkage addrSpace 94 | let bbRef ← BasicBlockRef.create entry 95 | funRef.appendBasicBlock bbRef 96 | let modRef ← read 97 | modRef.appendFunction funRef 98 | builder.runIn {modRef, funRef, bbRef} 99 | return funRef 100 | 101 | -- ## Basic Block Builder Actions 102 | 103 | def getArg (argNo : UInt32) : BasicBlockM ArgumentRef := do 104 | (← read).funRef.getArg argNo 105 | 106 | def label (name : String) (builder : BasicBlockM PUnit) : BasicBlockM BasicBlockRef := do 107 | let ctx ← read 108 | let bb ← BasicBlockRef.create name 109 | ctx.funRef.appendBasicBlock bb 110 | builder.runIn {ctx with bbRef := bb} 111 | return bb 112 | 113 | -- ### `ret` 114 | 115 | def retVoid : BasicBlockM PUnit := do 116 | (← read).bbRef.appendInstruction <| ← ReturnInstRef.createVoid 117 | 118 | def ret (val : ValueRef) : BasicBlockM PUnit := do 119 | (← read).bbRef.appendInstruction <| ← ReturnInstRef.create val 120 | 121 | -- ### `br` 122 | 123 | def condBr (cond : ValueRef) (ifTrue ifFalse : BasicBlockRef) : BasicBlockM PUnit := do 124 | (← read).bbRef.appendInstruction <| ← CondBrInstRef.create ifTrue ifFalse cond 125 | 126 | def br (bb : BasicBlockRef) : BasicBlockM PUnit := do 127 | (← read).bbRef.appendInstruction <| ← BrInstRef.create bb 128 | 129 | -- ### `load` 130 | 131 | def load (type : TypeRef) (ptr : ValueRef) (name := "") (isVolatile := false) 132 | (align : Align := 1) (order := AtomicOrdering.notAtomic) (ssid := SyncScopeID.system) 133 | : BasicBlockM InstructionRef := do 134 | let inst ← LoadInstRef.create type ptr name isVolatile align order ssid 135 | (← read).bbRef.appendInstruction inst 136 | return inst 137 | 138 | -- ### `store` 139 | 140 | def store (val : ValueRef) (ptr : ValueRef) (isVolatile := false) 141 | (align : Align := 1) (order := AtomicOrdering.notAtomic) (ssid := SyncScopeID.system) 142 | : BasicBlockM InstructionRef := do 143 | let inst ← StoreInstRef.create val ptr isVolatile align order ssid 144 | (← read).bbRef.appendInstruction inst 145 | return inst 146 | 147 | -- ### `getelementptr` 148 | 149 | def getElementPtr 150 | (pointeeType : TypeRef) (ptr : ValueRef) (indices : Array ValueRef := #[]) 151 | (name : String := "") : BasicBlockM InstructionRef := do 152 | let inst ← GetElementPtrInstRef.create pointeeType ptr indices name 153 | (← read).bbRef.appendInstruction inst 154 | return inst 155 | 156 | def getElementPtrInbounds 157 | (pointeeType : TypeRef) (ptr : ValueRef) (indices : Array ValueRef := #[]) 158 | (name : String := "") : BasicBlockM InstructionRef := do 159 | let inst ← GetElementPtrInstRef.createInbounds pointeeType ptr indices name 160 | (← read).bbRef.appendInstruction inst 161 | return inst 162 | 163 | -- ### `call` 164 | 165 | def call (fn : FunctionRef) (args : Array ValueRef := #[]) (name : String := "") : BasicBlockM InstructionRef := do 166 | let inst ← fn.createCall args name 167 | (← read).bbRef.appendInstruction inst 168 | return inst 169 | 170 | def callAs (type : FunctionTypeRef) (fn : ValueRef) (args : Array ValueRef := #[]) (name : String := "") : BasicBlockM InstructionRef := do 171 | let inst ← CallInstRef.create type fn args name 172 | (← read).bbRef.appendInstruction inst 173 | return inst 174 | -------------------------------------------------------------------------------- /Papyrus/Context.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.FFI 2 | 3 | namespace Papyrus 4 | 5 | /-- 6 | An opaque type representing an external 7 | [LLVMContext](https://llvm.org/doxygen/classllvm_1_1LLVMContext.html). 8 | -/ 9 | constant LLVMContext : Type := Unit 10 | 11 | /-- 12 | A reference to an external 13 | [LLVMContext](https://llvm.org/doxygen/classllvm_1_1LLVMContext.html). 14 | -/ 15 | def ContextRef := OwnedPtr LLVMContext 16 | 17 | /-- Create a new LLVM context. -/ 18 | @[extern "papyrus_context_new"] 19 | constant ContextRef.new : IO ContextRef 20 | 21 | /-- The LLVM Monad. -/ 22 | abbrev LlvmM := ReaderT ContextRef IO 23 | 24 | namespace LlvmM 25 | 26 | protected def runIn (ctx : ContextRef) (self : LlvmM α) : IO α := 27 | self ctx 28 | 29 | protected def run (self : LlvmM α) : IO α := do 30 | self (← ContextRef.new) 31 | -------------------------------------------------------------------------------- /Papyrus/ExecutionEngineRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.IR.ModuleRef 2 | import Papyrus.IR.FunctionRef 3 | import Papyrus.GenericValueRef 4 | 5 | namespace Papyrus 6 | 7 | /-- A desired execution engine kind. -/ 8 | inductive EngineKind 9 | | either 10 | | jit 11 | | interpreter 12 | deriving BEq, DecidableEq, Repr 13 | 14 | attribute [unbox] EngineKind 15 | instance : Inhabited EngineKind := ⟨EngineKind.either⟩ 16 | 17 | namespace EngineKind 18 | 19 | def isJit (self : EngineKind) : Bool := 20 | self matches jit 21 | 22 | def allowsJit : (self : EngineKind) → Bool 23 | | jit => true 24 | | interpreter => false 25 | | either => true 26 | 27 | def isInterpreter (self : EngineKind) : Bool := 28 | self matches interpreter 29 | 30 | def allowsInterpreter : (self : EngineKind) → Bool 31 | | jit => false 32 | | interpreter => true 33 | | either => true 34 | 35 | def isEither (self : EngineKind) : Bool := 36 | self matches either 37 | 38 | def ofUInt8 (value : UInt8) : EngineKind := 39 | if value == 0b01 then jit else 40 | if value == 0b10 then interpreter else 41 | either 42 | 43 | def toUInt8 : (self : EngineKind) → UInt8 44 | | jit => 0b01 45 | | interpreter => 0b10 46 | | either => 0b11 47 | 48 | end EngineKind 49 | 50 | /-- Optimization level for generated code. -/ 51 | inductive OptLevel 52 | | /-- -O0 -/ none 53 | | /-- -O1 -/ less 54 | | /-- -O2 -/ default 55 | | /-- -O3 -/ aggressive 56 | deriving BEq, DecidableEq, Repr 57 | 58 | attribute [unbox] OptLevel 59 | instance : Inhabited OptLevel := ⟨OptLevel.default⟩ 60 | 61 | /-- 62 | A reference to an external LLVM 63 | [ExecutionEngine](https://llvm.org/doxygen/classllvm_1_1ExecutionEngine.html). 64 | -/ 65 | constant ExecutionEngineRef : Type := Unit 66 | 67 | namespace ExecutionEngineRef 68 | 69 | /-- Create an execution engine for the given module. -/ 70 | @[extern "papyrus_execution_engine_create_for_module"] 71 | constant createForModule (mod : @& ModuleRef) (kind : @& EngineKind := EngineKind.either) 72 | (march : @& String := "") (mcpu : @& String := "") (mattrs : @& Array String := #[]) 73 | (optLevel : @& OptLevel := OptLevel.default) (verifyModule := false) 74 | : IO ExecutionEngineRef 75 | 76 | /-- 77 | Execute the given function with the given arguments, and return the result. 78 | 79 | An MCJIT execution engine can only execute 'main-like' function. 80 | That is, those returning `void` or `int` and taking no arguments 81 | (i.e., `[]`) or `argc`/`argv` (i.e., `[i32, i8**]`). 82 | -/ 83 | @[extern "papyrus_execution_engine_run_function"] 84 | constant runFunction (fn : @& FunctionRef) (self : @& ExecutionEngineRef) 85 | (args : @& Array GenericValueRef := #[]) : IO GenericValueRef 86 | 87 | /-- 88 | A helper for `runFunction` that runs a standard `main`-like function. 89 | That is, a function that may take up to three arguments (`i32 argc`, 90 | `i8** argv`, and `i8** envp`) and return a `i32` exit code. 91 | -/ 92 | @[extern "papyrus_execution_engine_run_function_as_main"] 93 | constant runFunctionAsMain (fn : @& FunctionRef) (self : @& ExecutionEngineRef) 94 | (args : @& Array String := #[]) (env : @& Array String := #[]) : IO UInt32 95 | 96 | end ExecutionEngineRef 97 | -------------------------------------------------------------------------------- /Papyrus/FFI.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | /-- An object which defines the kind of an external pointer. -/ 4 | constant ExternalPtrClass : Type := Unit 5 | 6 | /-- A Lean object which contains an external pointer. -/ 7 | constant ExternalPtr : ExternalPtrClass → Type → Type := fun _ _ => Unit 8 | 9 | /-- The external class of LoosePtr. -/ 10 | axiom LoosePtr.class : ExternalPtrClass 11 | noncomputable instance : Inhabited ExternalPtrClass := ⟨LoosePtr.class⟩ 12 | 13 | /-- An external pointer with no memory management. -/ 14 | abbrev LoosePtr (α) := ExternalPtr Papyrus.LoosePtr.class α 15 | 16 | /-- The external class of LoosePtr. -/ 17 | axiom OwnedPtr.class : ExternalPtrClass 18 | 19 | /-- 20 | A external pointer that is deleted upon being garbage collected 21 | (i.e., it is owned by Lean). 22 | -/ 23 | abbrev OwnedPtr (α) := ExternalPtr Papyrus.OwnedPtr.class α 24 | 25 | /-- The actual implementation of `LinkedPtr`. -/ 26 | structure LinkedPtrImpl (k : ExternalPtrClass) (σ) (α) where 27 | link : σ 28 | this : ExternalPtr k α 29 | 30 | /-- 31 | A external pointer whose lifetime is linked to some other external object 32 | that should not be deleted until this one is garbage collected by Lean. 33 | 34 | It as an opaque definition to prevent access to the internal `ExternalPtr`, 35 | which could create memory mismanagement (e.g., if a reference to it is kept 36 | without keeping a reference to the `LinkedPtr`). 37 | -/ 38 | constant LinkedPtr (k : ExternalPtrClass) (σ : Type) (α : Type) : Type := 39 | LinkedPtrImpl k σ α 40 | 41 | /-- A linked external pointer that should not be managed by Lean. -/ 42 | abbrev LinkedLoosePtr := LinkedPtr LoosePtr.class 43 | 44 | /-- A linked external pointer that can be deleted independently by Lean. -/ 45 | abbrev LinkedOwnedPtr := LinkedPtr OwnedPtr.class 46 | -------------------------------------------------------------------------------- /Papyrus/GenericValueRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.FFI 2 | import Papyrus.IR.TypeRefs 3 | 4 | namespace Papyrus 5 | 6 | /-- 7 | An opaque type representing an external 8 | [GenericValue](https://llvm.org/doxygen/structllvm_1_1GenericValue.html). 9 | -/ 10 | constant Llvm.GenericValue : Type := Unit 11 | 12 | /-- 13 | A reference to an external LLVM 14 | [GenericValue](https://llvm.org/doxygen/structllvm_1_1GenericValue.html). 15 | -/ 16 | def GenericValueRef := OwnedPtr Llvm.GenericValue 17 | 18 | namespace GenericValueRef 19 | 20 | /-- 21 | Create a integer generic of the given width with the given `Int` value. 22 | The value will be truncated and/or extended as necessary to make it fit. 23 | -/ 24 | @[extern "papyrus_generic_value_of_int"] 25 | constant ofInt (numBits : UInt32) (value : @& Int) : IO GenericValueRef 26 | 27 | /-- Get the value of this generic as an `Int` by treating its integer bits as signed. -/ 28 | @[extern "papyrus_generic_value_to_int"] 29 | constant toInt (self : @& GenericValueRef) : IO Int 30 | 31 | /-- 32 | Create a integer generic of the given width with the given `Nat` value. 33 | The value will be truncated and/or extended as necessary to make it fit. 34 | -/ 35 | @[extern "papyrus_generic_value_of_nat"] 36 | constant ofNat (numBits : UInt32) (value : @& Nat) : IO GenericValueRef 37 | 38 | /-- Get the integer value of this generic as a `Nat` by treating its integer bits as unsigned. -/ 39 | @[extern "papyrus_generic_value_to_nat"] 40 | constant toNat (self : @& GenericValueRef) : IO Nat 41 | 42 | /-- Create a `double` generic from a `Float`. -/ 43 | @[extern "papyrus_generic_value_of_float"] 44 | constant ofFloat (value : @& Float) : IO GenericValueRef 45 | 46 | /-- Get the `double` value of this generic as a `Float`. -/ 47 | @[extern "papyrus_generic_value_to_float"] 48 | constant toFloat (self : @& GenericValueRef) : IO Float 49 | 50 | /-- Create an aggregate generic from an `Array`. -/ 51 | @[extern "papyrus_generic_value_of_array"] 52 | constant ofArray (value : @& Array GenericValueRef) : IO GenericValueRef 53 | 54 | /-- Get the aggregate value of this generic as an `Array`. -/ 55 | @[extern "papyrus_generic_value_to_array"] 56 | constant toArray (self : @& GenericValueRef) : IO (Array GenericValueRef) 57 | 58 | end GenericValueRef 59 | 60 | namespace IntegerTypeRef 61 | 62 | /-- Get a reference to a generic of this type with the value of `Int`. -/ 63 | def getGenericValueOfInt (value : @& Int) (self : @& IntegerTypeRef) : IO GenericValueRef := do 64 | GenericValueRef.ofInt (← self.getBitWidth) value 65 | 66 | /-- Get a reference to a generic of this type with the value of `Nat`. -/ 67 | constant getGenericValueOfNat (value : @& Nat) (self : @& IntegerTypeRef) : IO GenericValueRef := do 68 | GenericValueRef.ofNat (← self.getBitWidth) value 69 | 70 | end IntegerTypeRef 71 | -------------------------------------------------------------------------------- /Papyrus/IR.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.IR.Align 2 | import Papyrus.IR.AddressSpace 3 | import Papyrus.IR.TypeID 4 | import Papyrus.IR.TypeRef 5 | import Papyrus.IR.TypeRefs 6 | import Papyrus.IR.TypeBases 7 | import Papyrus.IR.Type 8 | import Papyrus.IR.Types 9 | import Papyrus.IR.ValueKind 10 | import Papyrus.IR.ValueRef 11 | import Papyrus.IR.ConstantRef 12 | import Papyrus.IR.ConstantRefs 13 | import Papyrus.IR.InstructionKind 14 | import Papyrus.IR.InstructionModifiers 15 | import Papyrus.IR.InstructionRef 16 | import Papyrus.IR.InstructionRefs 17 | import Papyrus.IR.BasicBlockRef 18 | import Papyrus.IR.GlobalModifiers 19 | import Papyrus.IR.FunctionRef 20 | import Papyrus.IR.GlobalVariableRef 21 | import Papyrus.IR.ModuleRef 22 | -------------------------------------------------------------------------------- /Papyrus/IR/AddressSpace.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | /-- A numerically indexed address space. -/ 4 | structure AddressSpace where 5 | index : UInt32 6 | deriving BEq, Repr 7 | 8 | namespace AddressSpace 9 | 10 | /-- The default address space (i.e., 0). -/ 11 | def default := mk 0 12 | 13 | /-- Make an address space from a `Nat`. -/ 14 | def ofNat (n : Nat) := mk n.toUInt32 15 | 16 | /-- Make an address space from a `UInt32`. -/ 17 | def ofUInt32 (n : UInt32) := mk n 18 | 19 | /-- Convert an address space tp a `Nat`. -/ 20 | def toNat (self : AddressSpace) : Nat := self.index.toNat 21 | 22 | /-- Convert an address space to a `UInt32`. -/ 23 | def toUInt32 (self : AddressSpace) : UInt32 := self.index 24 | 25 | end AddressSpace 26 | 27 | instance : Inhabited AddressSpace := ⟨AddressSpace.default⟩ 28 | instance {n} : OfNat AddressSpace n := ⟨AddressSpace.ofNat n⟩ 29 | -------------------------------------------------------------------------------- /Papyrus/IR/Align.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | /-- 4 | A valid (non-zero power of two) alignment. 5 | 6 | LLVM alignments are in terms of bytes (i.e. an alignment of 1 is byte-aligned). 7 | -/ 8 | structure Align where 9 | shiftVal : UInt8 10 | h : shiftVal < 64 11 | deriving Repr 12 | 13 | -- TODO: Add way to compute `Align` from a raw alignment. 14 | namespace Align 15 | 16 | def val (self : Align) : UInt64 := 17 | (1 : UInt64) <<< self.shiftVal.toUInt64 18 | 19 | partial def ofValAux (i : UInt8) (n : UInt64) : UInt8 := 20 | if n < 2 then i else ofValAux (i + 1) (n / 2) 21 | 22 | def ofVal (n : UInt64) : Align := 23 | mk (ofValAux 0 n % (64 : Nat)) <| Fin.modn_lt _ (Nat.zero_lt_succ _) 24 | 25 | -- ## OfNat Instances 26 | 27 | section 28 | open Lean 29 | 30 | local macro "gen_ofNat_instances" : command => do 31 | let mut instances := Array.mkEmpty 64 32 | for i in [0:64] do 33 | let shiftVal := quote i 34 | let val := quote <| 1 <<< i 35 | instances := instances.push <| ← 36 | `(instance : OfNat Align (nat_lit $val) := ⟨⟨$shiftVal, by decide⟩⟩) 37 | mkNullNode instances 38 | 39 | gen_ofNat_instances 40 | end 41 | 42 | /-- The default is byte-aligned. -/ 43 | def default : Align := 1 44 | 45 | instance : Inhabited Align := ⟨Align.default⟩ 46 | 47 | -- ## Propositional Relations 48 | 49 | theorem eq_of_shiftVal_eq : {a b : Align} → a.shiftVal = b.shiftVal → a = b 50 | | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl 51 | 52 | theorem shiftVal_eq_of_eq {a b : Align} (h : a = b) : a.shiftVal = b.shiftVal := 53 | h ▸ rfl 54 | 55 | theorem ne_of_shiftVal_ne {a b : Align} (h : a.shiftVal ≠ b.shiftVal) : a ≠ b := 56 | fun h' => absurd (shiftVal_eq_of_eq h') h 57 | 58 | instance decEq : DecidableEq Align := 59 | fun a b => 60 | if h : a.shiftVal = b.shiftVal 61 | then isTrue (eq_of_shiftVal_eq h) 62 | else isFalse (ne_of_shiftVal_ne h) 63 | 64 | instance : LT Align := ⟨fun a b => a.shiftVal < b.shiftVal⟩ 65 | instance : LE Align := ⟨fun a b => a.shiftVal <= b.shiftVal⟩ 66 | 67 | instance decLt (a b : Align) : Decidable (a < b) := UInt8.decLt .. 68 | instance decLe (a b : Align) : Decidable (a <= b) := UInt8.decLe .. 69 | -------------------------------------------------------------------------------- /Papyrus/IR/ArgumentRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.ValueRef 3 | 4 | namespace Papyrus 5 | 6 | /-- 7 | A reference to an external LLVM 8 | [Argument](https://llvm.org/doxygen/classllvm_1_1Argument.html). 9 | -/ 10 | structure ArgumentRef extends ValueRef where 11 | is_argument : toValueRef.valueKind = ValueKind.argument 12 | 13 | instance : Coe ArgumentRef ValueRef := ⟨(·.toValueRef)⟩ 14 | 15 | namespace ArgumentRef 16 | 17 | /-- Cast a general `ValueRef` to a `ArgumentRef` given proof it is one. -/ 18 | def cast (val : ValueRef) (h : val.valueKind = ValueKind.argument) : ArgumentRef := 19 | {toValueRef := val, is_argument := h} 20 | -------------------------------------------------------------------------------- /Papyrus/IR/BasicBlockRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.ValueRef 3 | import Papyrus.IR.InstructionRef 4 | 5 | namespace Papyrus 6 | 7 | /-- 8 | A reference to an external LLVM 9 | [BasicBlock](https://llvm.org/doxygen/classllvm_1_1BasicBlock.html). 10 | -/ 11 | structure BasicBlockRef extends ValueRef where 12 | is_basic_block : toValueRef.valueKind = ValueKind.basicBlock 13 | 14 | instance : Coe BasicBlockRef ValueRef := ⟨(·.toValueRef)⟩ 15 | 16 | namespace BasicBlockRef 17 | 18 | /-- Cast a general `ValueRef` to a `BasicBlockRef` given proof it is one. -/ 19 | def cast (val : ValueRef) (h : val.valueKind = ValueKind.basicBlock) : BasicBlockRef := 20 | {toValueRef := val, is_basic_block := h} 21 | 22 | /-- Create a new unlinked basic block with given label/name (or none if empty). -/ 23 | @[extern "papyrus_basic_block_create"] 24 | constant create (name : @& String := "") : LlvmM BasicBlockRef 25 | 26 | /-- Get the array of references to the instructions of this basic block. -/ 27 | @[extern "papyrus_basic_block_get_instructions"] 28 | constant getInstructions (self : @& BasicBlockRef) : IO (Array InstructionRef) 29 | 30 | /-- Add an instruction to the end of the basic block. -/ 31 | @[extern "papyrus_basic_block_append_instruction"] 32 | constant appendInstruction (inst : @& InstructionRef) (self : @& BasicBlockRef) : IO PUnit 33 | -------------------------------------------------------------------------------- /Papyrus/IR/ConstantRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.ValueRef 3 | 4 | namespace Papyrus 5 | 6 | /-- 7 | A reference to an external LLVM 8 | [Constant](https://llvm.org/doxygen/classllvm_1_1Constant.html). 9 | -/ 10 | structure ConstantRef extends UserRef 11 | instance : Coe ConstantRef UserRef := ⟨(·.toUserRef)⟩ 12 | -------------------------------------------------------------------------------- /Papyrus/IR/FunctionRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.AddressSpace 3 | import Papyrus.IR.CallingConvention 4 | import Papyrus.IR.BasicBlockRef 5 | import Papyrus.IR.GlobalRefs 6 | import Papyrus.IR.ArgumentRef 7 | import Papyrus.IR.TypeRefs 8 | 9 | namespace Papyrus 10 | 11 | /-- 12 | A reference to an external LLVM 13 | [Function](https://llvm.org/doxygen/classllvm_1_1Function.html). 14 | -/ 15 | structure FunctionRef extends GlobalObjectRef where 16 | is_function : toValueRef.valueKind = ValueKind.function 17 | 18 | instance : Coe FunctionRef GlobalObjectRef := ⟨(·.toGlobalObjectRef)⟩ 19 | 20 | namespace FunctionRef 21 | 22 | /-- Cast a general `ValueRef` to a `FunctionRef` given proof it is one. -/ 23 | def cast (val : ValueRef) (h : val.valueKind = ValueKind.function) : FunctionRef := 24 | {toValueRef := val, is_function := h} 25 | 26 | /-- 27 | Create a new unlinked function with the given type, the optional given name, 28 | and the given linkage in the given address space. 29 | -/ 30 | @[extern "papyrus_function_create"] 31 | constant create (type : @& FunctionTypeRef) (name : @& String := "") 32 | (linkage := Linkage.external) (addrSpace := AddressSpace.default) 33 | : IO FunctionRef 34 | 35 | /-- Get the function type of this function. -/ 36 | @[extern "papyrus_global_value_get_value_type"] 37 | constant getValueType (self : @& FunctionRef) : IO FunctionTypeRef 38 | 39 | /-- Get the function type of this function. -/ 40 | abbrev getFunctionType (self : FunctionRef) := self.getValueType 41 | 42 | /-- Get the nth argument of thee this function. -/ 43 | @[extern "papyrus_function_get_arg"] 44 | constant getArg (argNo : @& UInt32) (self : @& FunctionRef) : IO ArgumentRef 45 | 46 | /-- Get the array of references to the basic blocks of this function. -/ 47 | @[extern "papyrus_function_get_basic_blocks"] 48 | constant getBasicBlocks (self : @& FunctionRef) : IO (Array BasicBlockRef) 49 | 50 | /-- Add a basic block to the end of this function. -/ 51 | @[extern "papyrus_function_append_basic_block"] 52 | constant appendBasicBlock (bb : @& BasicBlockRef) (self : @& FunctionRef) : IO PUnit 53 | 54 | /-- Check this function for errors. Errors are reported inside the `IO` monad. -/ 55 | @[extern "papyrus_function_verify"] 56 | constant verify (self : @& FunctionRef) : IO PUnit 57 | 58 | /-- Get whether this function has a specified garbage collection algorithm. -/ 59 | @[extern "papyrus_function_has_gc"] 60 | constant hasGC (self : @& FunctionRef) : IO Bool 61 | 62 | /-- 63 | Get the name of the garbage collection algorithm used in code generation. 64 | It is only legal to call this if a garbage collection algorithm has been 65 | specified (i.e., `hasGC` returns true). 66 | -/ 67 | @[extern "papyrus_function_get_gc"] 68 | constant getGC (self : @& FunctionRef) : IO String 69 | 70 | /-- Set the name of the garbage collection algorithm used in code generation. -/ 71 | @[extern "papyrus_function_set_gc"] 72 | constant setGC (gc : @& String) (self : @& FunctionRef) : IO PUnit 73 | 74 | /-- Remove any specified garbage collection algorithm for this function. -/ 75 | @[extern "papyrus_function_clear_gc"] 76 | constant clearGC (self : @& FunctionRef) : IO PUnit 77 | 78 | /-- Get the calling convention of this function. -/ 79 | @[extern "papyrus_function_get_calling_convention"] 80 | constant getCallingConvention (self : @& FunctionRef) : IO CallingConvention 81 | 82 | /-- Set the calling convention of this function. -/ 83 | @[extern "papyrus_function_set_calling_convention"] 84 | constant setCallingConvention (cc : CallingConvention) 85 | (self : @& FunctionRef) : IO PUnit 86 | 87 | end FunctionRef 88 | -------------------------------------------------------------------------------- /Papyrus/IR/GlobalModifiers.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | -------------------------------------------------------------------------------- 4 | -- # Linkage 5 | -------------------------------------------------------------------------------- 6 | 7 | /-- 8 | The linkage kind of a global. 9 | It is illegal for a global variable or function *declaration* to have any 10 | linkage type other than `external` or `externalWeak`. 11 | -/ 12 | inductive Linkage 13 | | /-- 14 | Externally visible value (the default). 15 | It participates in linkage and can be used to resolve 16 | external symbol references. 17 | -/ 18 | external 19 | | /-- 20 | Available for inspection, not emission. 21 | -/ 22 | availableExternally 23 | | /-- 24 | Keep any one copy of the value when linking. 25 | Unreferenced globals are allowed to be discarded. 26 | -/ 27 | linkOnceAny 28 | | /-- 29 | Same as `LinkOnceAny`, but only replaced by something equivalent 30 | That is, it follows the "one definition rule" (ODR) ala C++. 31 | -/ 32 | linkOnceODR 33 | | /-- 34 | Keep one copy of the value when linking. 35 | Unreferenced globals are *not* allowed to be discarded. 36 | This is corresponds to `weak` in C. 37 | -/ 38 | weakAny 39 | | /-- 40 | Same as `WeakAny`, but only replaced by something equivalent. 41 | That is, it follows the "one definition rule" (ODR) ala C++. 42 | -/ 43 | weakODR 44 | | /-- 45 | **Only applies to global variables of a pointer to array type.** 46 | When two global variables with appending linkage are linked together, 47 | the two global arrays are appended together. 48 | This is the types safe LLVM equivalent of having the system linker append 49 | together “sections” with identical names when .o files are linked. 50 | -/ 51 | appending 52 | | /-- Rename collisions when linking (e.g., `static` in C). -/ 53 | internal 54 | | /-- Like `Internal`, but omit from symbol table. -/ 55 | «private» 56 | | /-- 57 | The symbol is weak until linked. 58 | If not linked, the symbol becomes null 59 | instead of being an undefined reference. 60 | That is, it follows ELF object file model. 61 | -/ 62 | externalWeak 63 | | /-- 64 | Similar to `WeakAny`. They are use for global tentative definitions in C. 65 | Common symbols may not have an explicit section, must have a zero initializer, 66 | and may not be marked ‘constant’. 67 | **Functions and aliases may not have this linkage.** 68 | -/ 69 | common 70 | deriving BEq, DecidableEq, Repr 71 | 72 | attribute [unbox] Linkage 73 | instance : Inhabited Linkage := ⟨Linkage.external⟩ 74 | 75 | -------------------------------------------------------------------------------- 76 | -- # Visibility 77 | -------------------------------------------------------------------------------- 78 | 79 | /-- The visibility kind of a global. -/ 80 | inductive Visibility 81 | | /-- 82 | The global is visible. 83 | On both ELF and Darwin, default visibility means that 84 | the declaration is visible to other modules. 85 | On ELF it also means that, in shared libraries, 86 | the declared entity may be overridden. 87 | -/ 88 | protected 89 | default 90 | | /-- 91 | The global is hidden. 92 | Two declarations of an object with hidden visibility refer to the same object 93 | if they are in the same shared object. 94 | Usually, hidden visibility indicates that the symbol will not be placed into 95 | the dynamic symbol table, so no other module (executable or shared library) 96 | can reference it directly. 97 | -/ 98 | hidden 99 | | /-- 100 | The global is protected. 101 | On ELF, protected visibility indicates that the symbol will be placed in 102 | the dynamic symbol table, but that references within the defining module 103 | will bind to the local symbol. 104 | That is, the symbol cannot be overridden by another module. 105 | -/ 106 | «protected» 107 | deriving BEq, DecidableEq, Repr 108 | 109 | attribute [unbox] Visibility 110 | instance : Inhabited Visibility := ⟨Visibility.default⟩ 111 | 112 | -------------------------------------------------------------------------------- 113 | -- # DLL Storage Class 114 | -------------------------------------------------------------------------------- 115 | 116 | /-- The storage class kind of a global for PE targets. -/ 117 | inductive DLLStorageClass 118 | | protected 119 | default 120 | | /-- Imported from a DLL. -/ 121 | dllImport 122 | | /-- Accessible from within a DLL. -/ 123 | dllExport 124 | deriving BEq, DecidableEq, Repr 125 | 126 | attribute [unbox] DLLStorageClass 127 | export DLLStorageClass (dllImport dllExport) 128 | instance : Inhabited DLLStorageClass := ⟨DLLStorageClass.default⟩ 129 | 130 | -------------------------------------------------------------------------------- 131 | -- # Thread Local Mode 132 | -------------------------------------------------------------------------------- 133 | 134 | /-- 135 | A global may be defined as thread local, which means that it will not be 136 | shared by threads (each thread will have a separated copy of the variable). 137 | 138 | A thread local global can define a preferred thread local storage model, see 139 | [ELF Handling for Thread-Local Storage](http://people.redhat.com/drepper/tls.pdf) 140 | for more information on the how they be used. 141 | 142 | Not all targets support thread-local variables. 143 | -/ 144 | inductive ThreadLocalMode 145 | | /-- Global is not thread local. -/ 146 | notLocal 147 | | /-- General case, the default for a thread local global. -/ 148 | generalDynamic 149 | | /-- Only used within the current shared library. -/ 150 | localDynamic 151 | | /-- Not loaded dynamically. -/ 152 | initialExec 153 | | /-- Defined in the executable and only used within it. -/ 154 | localExec 155 | deriving BEq, DecidableEq, Repr 156 | 157 | attribute [unbox] ThreadLocalMode 158 | instance : Inhabited ThreadLocalMode := ⟨ThreadLocalMode.notLocal⟩ 159 | 160 | -------------------------------------------------------------------------------- 161 | -- # Address Significance 162 | -------------------------------------------------------------------------------- 163 | 164 | /-- 165 | The significance of a global's address in memory. 166 | A global with an insignificant address can be merged with an equivalent global. 167 | 168 | This is conceptually the opposite of LLVM's 169 | [UnnamedAddr](https://llvm.org/doxygen/classllvm_1_1GlobalValue.html#ae8df4be75bfc50b1eadd74e85c25fa45), 170 | enumeration, but order is preserved across the two by reversing the enumeration. 171 | It has been renamed to make its use clearer. 172 | -/ 173 | inductive AddressSignificance 174 | | /-- Significant everywhere (the default). -/ 175 | total 176 | | /-- Significant only outside the current module. -/ 177 | external 178 | | /-- Insignificant everywhere. -/ 179 | protected none 180 | deriving BEq, DecidableEq, Repr 181 | 182 | attribute [unbox] AddressSignificance 183 | instance : Inhabited AddressSignificance := ⟨AddressSignificance.total⟩ 184 | -------------------------------------------------------------------------------- /Papyrus/IR/GlobalRefs.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.TypeRefs 3 | import Papyrus.IR.ConstantRef 4 | import Papyrus.IR.AddressSpace 5 | import Papyrus.IR.GlobalModifiers 6 | 7 | namespace Papyrus 8 | 9 | -------------------------------------------------------------------------------- 10 | -- # Global Value References 11 | -------------------------------------------------------------------------------- 12 | 13 | /-- 14 | A reference to an external LLVM 15 | [GlobalValue](https://llvm.org/doxygen/classllvm_1_1GlobalValue.html). 16 | -/ 17 | structure GlobalValueRef extends ConstantRef 18 | instance : Coe GlobalValueRef ConstantRef := ⟨(·.toConstantRef)⟩ 19 | 20 | namespace GlobalValueRef 21 | 22 | /-- Get the type of this global. All globals are pointers to some value. -/ 23 | @[extern "papyrus_value_get_type"] 24 | constant getType (self : @& GlobalValueRef) : IO PointerTypeRef 25 | 26 | /-- Get the type of this global's value. -/ 27 | @[extern "papyrus_global_value_get_value_type"] 28 | constant getValueType (self : @& GlobalValueRef) : IO TypeRef 29 | 30 | /-- Get the address space of this global. -/ 31 | @[extern "papyrus_global_value_get_address_space"] 32 | constant getAddressSpace (self : @& GlobalValueRef) : IO AddressSpace 33 | 34 | /-- Get the linkage kind of this global. -/ 35 | @[extern "papyrus_global_value_get_linkage"] 36 | constant getLinkage (self : @& GlobalValueRef) : IO Linkage 37 | 38 | /-- Set the linkage kind of this global. -/ 39 | @[extern "papyrus_global_value_set_linkage"] 40 | constant setLinkage (linkage : Linkage) 41 | 42 | (self : @& GlobalValueRef) : IO PUnit 43 | /-- Get the visibility of this global. -/ 44 | @[extern "papyrus_global_value_get_visibility"] 45 | constant getVisibility (self : @& GlobalValueRef) : IO Visibility 46 | 47 | /-- Set the visibility of this global. -/ 48 | @[extern "papyrus_global_value_set_visibility"] 49 | constant setVisibility (visibility : Visibility) 50 | (self : @& GlobalValueRef) : IO PUnit 51 | 52 | /-- Get the DLL storage class of this global. -/ 53 | @[extern "papyrus_global_value_get_dll_storage_class"] 54 | constant getDLLStorageClass (self : @& GlobalValueRef) 55 | : IO DLLStorageClass 56 | 57 | /-- Set the DLL storage class of this global. -/ 58 | @[extern "papyrus_global_value_set_dll_storage_class"] 59 | constant setDLLStorageClass (dllStorageClass : DLLStorageClass) 60 | (self : @& GlobalValueRef) : IO PUnit 61 | 62 | /-- Get the thread local mode of this global. -/ 63 | @[extern "papyrus_global_value_get_dll_storage_class"] 64 | constant getThreadLocalMode (self : @& GlobalValueRef) 65 | : IO ThreadLocalMode 66 | 67 | /-- Set the thread local mode of this global. -/ 68 | @[extern "papyrus_global_value_set_dll_storage_class"] 69 | constant setThreadLocalMode (tlm : ThreadLocalMode) 70 | (self : @& GlobalValueRef) : IO PUnit 71 | 72 | /-- Get the address significance of this global. -/ 73 | @[extern "papyrus_global_value_get_address_significance"] 74 | constant getAddressSignificance (self : @& GlobalValueRef) 75 | : IO AddressSignificance 76 | 77 | /-- Set the address significance of this global. -/ 78 | @[extern "papyrus_global_value_set_address_significance"] 79 | constant setAddressSignificance (addrSig : AddressSignificance) 80 | (self : @& GlobalValueRef) : IO PUnit 81 | 82 | end GlobalValueRef 83 | 84 | -------------------------------------------------------------------------------- 85 | -- # Global Object References 86 | -------------------------------------------------------------------------------- 87 | 88 | /-- 89 | A reference to an external LLVM 90 | [GlobalObject](https://llvm.org/doxygen/classllvm_1_1GlobalObject.html). 91 | -/ 92 | structure GlobalObjectRef extends GlobalValueRef 93 | instance : Coe GlobalObjectRef GlobalValueRef := ⟨(·.toGlobalValueRef)⟩ 94 | 95 | namespace GlobalObjectRef 96 | 97 | /-- Get whether this value has a explicitly specified linker section. -/ 98 | @[extern "papyrus_global_object_has_section"] 99 | constant hasSection (self : @& GlobalObjectRef) : IO Bool 100 | 101 | /-- Get the explicit linker section of this value (or the empty string if none). -/ 102 | @[extern "papyrus_global_object_get_section"] 103 | constant getSection (self : @& GlobalObjectRef) : IO String 104 | 105 | /-- 106 | Set the explicit linker section of this value 107 | (or remove it by passing the empty string). 108 | -/ 109 | @[extern "papyrus_global_object_set_section"] 110 | constant setSection (sect : @& String) (self : @& GlobalObjectRef) : IO PUnit 111 | 112 | /-- 113 | Get the explicit power of two alignment of this value (or 0 if undefined). 114 | Note that for functions this is the alignment of the code, 115 | not the alignment of a function pointer. 116 | -/ 117 | @[extern "papyrus_global_object_get_alignment"] 118 | constant getRawAlignment (self : @& GlobalObjectRef) : IO UInt64 119 | 120 | /-- Set the explicit power of two alignment of this value (or pass 0 to remove it). -/ 121 | @[extern "papyrus_global_object_set_alignment"] 122 | constant setRawAlignment (align : UInt64) (self : @& GlobalObjectRef) : IO PUnit 123 | 124 | end GlobalObjectRef 125 | -------------------------------------------------------------------------------- /Papyrus/IR/GlobalVariableRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.GlobalRefs 3 | import Papyrus.IR.AddressSpace 4 | import Papyrus.IR.ConstantRef 5 | import Papyrus.IR.ConstantRefs 6 | import Papyrus.IR.TypeRef 7 | 8 | namespace Papyrus 9 | 10 | /-- 11 | A reference to an external LLVM 12 | [GlobalVariable](https://llvm.org/doxygen/classllvm_1_1GlobalVariable.html). 13 | -/ 14 | structure GlobalVariableRef extends GlobalObjectRef where 15 | is_global_variable : toValueRef.valueKind = ValueKind.globalVariable 16 | 17 | instance : Coe GlobalVariableRef GlobalObjectRef := ⟨(·.toGlobalObjectRef)⟩ 18 | 19 | namespace GlobalVariableRef 20 | 21 | /-- Cast a general `ValueRef` to a `GlobalVariableRef` given proof it is one. -/ 22 | def cast (val : ValueRef) (h : val.valueKind = ValueKind.globalVariable) : GlobalVariableRef := 23 | {toValueRef := val, is_global_variable := h} 24 | 25 | /-- Create a new unlinked global variable. -/ 26 | @[extern "papyrus_global_variable_new"] 27 | constant new (type : @& TypeRef) 28 | (isConstant := false) (linkage := Linkage.external) 29 | (name : @& String := "") (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) 30 | (isExternallyInitialized := false) : IO GlobalVariableRef 31 | 32 | /-- Create a new unlinked global variable with an initializer. -/ 33 | @[extern "papyrus_global_variable_new_with_init"] 34 | constant newWithInit (type : @& TypeRef) (isConstant := false) 35 | (linkage := Linkage.external) (init : @& ConstantRef) (name : @& String := "") 36 | (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) 37 | (isExternallyInitialized := false) : IO GlobalVariableRef 38 | 39 | /-- Create a new unlinked global constant with the given value. -/ 40 | def ofConstant (init : ConstantRef) 41 | (isConstant := true) (linkage := Linkage.external) (name := "") 42 | (tlm := ThreadLocalMode.notLocal) (addrSpace := AddressSpace.default) 43 | : IO GlobalVariableRef := do 44 | newWithInit (← init.getType) true linkage init name tlm addrSpace false 45 | 46 | /-- 47 | Create a new unlinked global string constant with the given value. 48 | If `withNull` is true, the string will be null terminated. 49 | 50 | Such constants have private linkage, single byte alignment, 51 | are not thread local, and their addresses are insignificant. 52 | -/ 53 | def ofString (value : String) 54 | (addrSpace := AddressSpace.default) (withNull := true) (name := "") 55 | : LlvmM GlobalVariableRef := do 56 | let var ← ofConstant (← ConstantDataArrayRef.ofString value withNull) 57 | true Linkage.private name ThreadLocalMode.notLocal addrSpace 58 | var.setAddressSignificance AddressSignificance.none 59 | var.setRawAlignment 1 60 | var 61 | 62 | /-- 63 | Get whether the this global variable is constant 64 | (i.e., its value does not change at runtime). 65 | -/ 66 | @[extern "papyrus_global_variable_is_constant"] 67 | constant isConstant (self : @& GlobalValueRef) : IO Bool 68 | 69 | /-- 70 | Set whether the this global variable is constant 71 | (i.e., its value does not change at runtime). 72 | -/ 73 | @[extern "papyrus_global_variable_set_constant"] 74 | constant setConstant (isConstant : Bool) (self : @& GlobalVariableRef) : IO PUnit 75 | 76 | /-- Get whether the this global variable has an initializer. -/ 77 | @[extern "papyrus_global_variable_has_initializer"] 78 | constant hasInitializer (self : @& GlobalVariableRef) : IO Bool 79 | 80 | /-- 81 | Get the initializer of this global variable. 82 | Only call this if it is know to have one (i.e., `hasInitializer` returned true). 83 | -/ 84 | @[extern "papyrus_global_variable_get_initializer"] 85 | constant getInitializer (self : @& GlobalVariableRef) 86 | : IO ConstantRef 87 | 88 | /-- Set the initializer of this global variable. -/ 89 | @[extern "papyrus_global_variable_set_initializer"] 90 | constant setInitializer (init : @& ConstantRef) 91 | (self : @& GlobalVariableRef) : IO PUnit 92 | 93 | /-- Remove the initializer of this global variable. -/ 94 | @[extern "papyrus_global_variable_remove_initializer"] 95 | constant removeInitializer (self : @& GlobalVariableRef) : IO PUnit 96 | 97 | /-- Get whether the this global variable is externally initialized. -/ 98 | @[extern "papyrus_global_variable_is_externally_initialized"] 99 | constant isExternallyInitialized (self : @& GlobalVariableRef) : IO Bool 100 | 101 | /-- Set whether the this global variable is externally initialized. -/ 102 | @[extern "papyrus_global_variable_set_externally_initialized"] 103 | constant setExternallyInitialized (externallyInitialized : Bool) 104 | (self : @& GlobalVariableRef) : IO Bool 105 | 106 | end GlobalVariableRef 107 | -------------------------------------------------------------------------------- /Papyrus/IR/InstructionKind.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Internal.Enum 2 | 3 | namespace Papyrus 4 | 5 | open Internal 6 | 7 | /-- Tags for all of the instruction types of LLVM (v12) IR. -/ 8 | sealed-enum InstructionKind : UInt8 9 | -- terminator 10 | | ret 11 | | branch 12 | | switch 13 | | indirectBr 14 | | invoke 15 | | resume 16 | | unreachable 17 | | cleanupRet 18 | | catchRet 19 | | catchSwitch 20 | | callBr 21 | -- unary 22 | | fneg 23 | -- binary 24 | | add 25 | | fadd 26 | | sub 27 | | fsub 28 | | mul 29 | | fmul 30 | | udiv 31 | | sdiv 32 | | fdiv 33 | | urem 34 | | srem 35 | | frem 36 | -- bitwise 37 | | shl 38 | | lshr 39 | | ashr 40 | | and 41 | | or 42 | | xor 43 | -- memory 44 | | alloca 45 | | load 46 | | store 47 | | getElementPtr 48 | | fence 49 | | atomicCmpXchg 50 | | atomicRMW 51 | -- casts 52 | | trunc 53 | | zext 54 | | sext 55 | | fpToUI 56 | | fpToSI 57 | | uiToFP 58 | | siToFP 59 | | fpTrunc 60 | | fpExt 61 | | ptrToInt 62 | | intToPtr 63 | | bitcast 64 | | addrSpaceCast 65 | -- pad 66 | | cleanupPad 67 | | catchPad 68 | -- other 69 | | icmp 70 | | fcmp 71 | | phi 72 | | call 73 | | select 74 | | userOp1 75 | | userOp2 76 | | vaarg 77 | | extractElement 78 | | insertElement 79 | | shuffleVector 80 | | extractValue 81 | | insertValue 82 | | landingPad 83 | | freeze 84 | deriving Inhabited, BEq, DecidableEq, Repr 85 | 86 | namespace InstructionKind 87 | 88 | def ofOpcode! (opcode : UInt32) : InstructionKind := 89 | let id := opcode - 1 |>.toUInt8 90 | if h : id ≤ maxVal then 91 | mk id h 92 | else 93 | panic! s!"unknown LLVM opcode {opcode}" 94 | 95 | def toOpcode (self : InstructionKind) : UInt32 := 96 | self.val.toUInt32 + 1 97 | -------------------------------------------------------------------------------- /Papyrus/IR/InstructionModifiers.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Internal.Enum 2 | 3 | namespace Papyrus 4 | 5 | open Internal 6 | 7 | /-- 8 | Atomic ordering for LLVM's memory model. 9 | 10 | C++ defines ordering as a lattice. 11 | LLVM supplements this with NotAtomic and Unordered, 12 | which are both below the C++ orders. 13 | 14 | `not_atomic` --> `unordered` --> `relaxed` --> `release` ------------—> 15 | `acq_rel` --> `seq_cst` --> `consume` --> `acquire` 16 | -/ 17 | inductive AtomicOrdering 18 | | notAtomic 19 | | unordered 20 | | monotonic 21 | | consume 22 | | acquire 23 | | release 24 | | acquireRelease 25 | | sequentiallyConsistent 26 | deriving BEq, DecidableEq, Repr 27 | 28 | attribute [unbox] AtomicOrdering 29 | instance : Inhabited AtomicOrdering := ⟨AtomicOrdering.notAtomic⟩ 30 | 31 | /-- 32 | Synchronization scope IDs. 33 | 34 | All synchronization scope IDs that LLVM has special knowledge of are listed here. 35 | However, there can be additional synchronization scopes not defined here. 36 | -/ 37 | enum SyncScopeID : UInt32 38 | | /-- Synchronized with respect to signal handlers executing in the same thread. -/ 39 | singleThread := 0 40 | | /-- Synchronized with respect to all concurrently executing threads (the default). -/ 41 | system := 1 42 | deriving BEq, DecidableEq, Repr 43 | 44 | instance : Inhabited SyncScopeID := ⟨SyncScopeID.system⟩ 45 | -------------------------------------------------------------------------------- /Papyrus/IR/InstructionRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.ValueRef 3 | import Papyrus.IR.ValueKind 4 | import Papyrus.IR.InstructionKind 5 | 6 | namespace Papyrus 7 | 8 | /-- 9 | A reference to an external LLVM 10 | [Instruction](https://llvm.org/doxygen/classllvm_1_1Instruction.html). 11 | -/ 12 | structure InstructionRef extends UserRef where 13 | is_instruction : toValueRef.valueKind = ValueKind.instruction 14 | 15 | instance : Coe InstructionRef UserRef := ⟨(·.toUserRef)⟩ 16 | 17 | namespace InstructionRef 18 | 19 | /-- Cast a general `ValueRef` to a `InstructionRef` given proof it is one. -/ 20 | def cast (val : ValueRef) (h : val.valueKind = ValueKind.instruction) : InstructionRef := 21 | {toValueRef := val, is_instruction := h} 22 | 23 | /-- The LLVM opcode of this instruction. -/ 24 | def opcode (self : InstructionRef) : UInt32 := 25 | (· - ValueKind.instruction.toValueID) self.valueID 26 | 27 | /-- The kind of this instruction. -/ 28 | def instructionKind (self : InstructionRef) : InstructionKind := 29 | InstructionKind.ofOpcode! self.opcode 30 | -------------------------------------------------------------------------------- /Papyrus/IR/ModuleRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.FFI 2 | import Papyrus.Context 3 | import Papyrus.MemoryBufferRef 4 | import Papyrus.IR.GlobalVariableRef 5 | import Papyrus.IR.FunctionRef 6 | 7 | namespace Papyrus 8 | 9 | /-- 10 | A opaque type representing an external LLVM 11 | [Module](https://llvm.org/doxygen/classllvm_1_1Module.html). 12 | -/ 13 | constant Llvm.Module : Type := Unit 14 | 15 | /-- 16 | A reference to an external LLVM 17 | [Module](https://llvm.org/doxygen/classllvm_1_1Module.html). 18 | -/ 19 | def ModuleRef := LinkedLoosePtr ContextRef Llvm.Module 20 | 21 | namespace ModuleRef 22 | 23 | /-- Create a new module. -/ 24 | @[extern "papyrus_module_new"] 25 | constant new (modID : @& String) : LlvmM ModuleRef 26 | 27 | /-- Load module from a bitcode memory buffer. -/ 28 | @[extern "papyrus_module_parse_bitcode_from_buffer"] 29 | constant parseBitcodeFromBuffer (self : @& MemoryBufferRef) : LlvmM ModuleRef 30 | 31 | /-- Load module from a bitcode file. -/ 32 | def parseBitcodeFromFile (file : System.FilePath) : LlvmM ModuleRef := do 33 | parseBitcodeFromBuffer (← MemoryBufferRef.fromFile file) 34 | 35 | /-- 36 | Write the bitcode of the module to a file. 37 | If `preserveUseListOrder` is set, the use-list order for each 38 | Value in the module will be encoded in the bitcode. 39 | These will then be reconstructed exactly when it is deserialized. 40 | -/ 41 | @[extern "papyrus_module_write_bitcode_to_file"] 42 | constant writeBitcodeToFile (file : @& System.FilePath) (self : @& ModuleRef) 43 | (preserveUseListOrder := false) : IO PUnit 44 | 45 | /-- Get the module's identifier (which is, essentially, its name). -/ 46 | @[extern "papyrus_module_get_id"] 47 | constant getModuleID (self : @& ModuleRef) : IO String 48 | 49 | /-- Set the module's identifier. -/ 50 | @[extern "papyrus_module_set_id"] 51 | constant setModuleID (self : @& ModuleRef) (modID : @& String) : IO PUnit 52 | 53 | /-- 54 | Get the function of the given name in this module. 55 | Throws an error if no such function exist. 56 | 57 | If `allowInternal` is set to true, this function will return globals 58 | that have internal linkage. By default, they are not returned. 59 | -/ 60 | @[extern "papyrus_module_get_global_variable"] 61 | constant getGlobalVariable (name : @& String) (self : @& ModuleRef) 62 | (allowInternal := false) : IO GlobalVariableRef 63 | 64 | /-- 65 | Get the function of the given name in this module (if it exists). 66 | 67 | If `allowInternal` is set to true, this function will return globals 68 | that have internal linkage. By default, they are not returned. 69 | -/ 70 | @[extern "papyrus_module_get_global_variable_opt"] 71 | constant getGlobalVariable? (name : @& String) (self : @& ModuleRef) 72 | (allowInternal := false) : IO (Option GlobalVariableRef) 73 | 74 | /-- Get an array of references to the global variables of this module. -/ 75 | @[extern "papyrus_module_get_global_variables"] 76 | constant getGlobalVariables (self : @& ModuleRef) : IO (Array GlobalVariableRef) 77 | 78 | /-- Add a global variable to the end of this module . -/ 79 | @[extern "papyrus_module_append_global_variable"] 80 | constant appendGlobalVariable (var : @& GlobalVariableRef) (self : @& ModuleRef) : IO PUnit 81 | 82 | /-- 83 | Get the function of the given name in this module. 84 | Throws and error if no such function exists. 85 | -/ 86 | @[extern "papyrus_module_get_function"] 87 | constant getFunction (name : @& String) (self : @& ModuleRef) : IO FunctionRef 88 | 89 | /-- Get the function of the given name in this module (if it exists). -/ 90 | @[extern "papyrus_module_get_function_opt"] 91 | constant getFunction? (name : @& String) (self : @& ModuleRef) : IO (Option FunctionRef) 92 | 93 | /-- Get an array of references to the functions of this module. -/ 94 | @[extern "papyrus_module_get_functions"] 95 | constant getFunctions (self : @& ModuleRef) : IO (Array FunctionRef) 96 | 97 | /-- Add a function to the end of this module . -/ 98 | @[extern "papyrus_module_append_function"] 99 | constant appendFunction (fn : @& FunctionRef) (self : @& ModuleRef) : IO PUnit 100 | 101 | /-- 102 | Check the module for errors. Errors are reported inside the `IO` monad. 103 | 104 | If `warnBrokenDebugInfo` is `true`, DebugInfo verification failures 105 | won't be considered as an error and instead the function will return `true`. 106 | Otherwise, the function will always return `false`. 107 | -/ 108 | @[extern "papyrus_module_verify"] 109 | constant verify (self : @& ModuleRef) (warnBrokenDebugInfo := false) : IO Bool 110 | 111 | /-- 112 | Print this module to LLVM's standard output (which may not correspond to Lean's). 113 | 114 | If`shouldPreserveUseListOrder`, the output will include `uselistorder` 115 | directives so that use-lists can be recreated when reading the assembly. 116 | -/ 117 | @[extern "papyrus_module_print"] 118 | constant print (self : @& ModuleRef) 119 | (shouldPreserveUseListOrder := false) (isForDebug := false) : IO PUnit 120 | 121 | /-- 122 | Print this module to LLVM's standard error (which may not correspond to Lean's). 123 | 124 | If`shouldPreserveUseListOrder`, the output will include `uselistorder` 125 | directives so that use-lists can be recreated when reading the assembly. 126 | -/ 127 | @[extern "papyrus_module_eprint"] 128 | constant eprint (self : @& ModuleRef) 129 | (shouldPreserveUseListOrder := false) (isForDebug := false) : IO PUnit 130 | 131 | /-- 132 | Print this module to a String. 133 | 134 | If`shouldPreserveUseListOrder`, the output will include `uselistorder` 135 | directives so that use-lists can be recreated when reading the assembly. 136 | -/ 137 | @[extern "papyrus_module_sprint"] 138 | constant sprint (self : @& ModuleRef) 139 | (shouldPreserveUseListOrder := false) (isForDebug := false) : IO String 140 | 141 | /-- Print this module to Lean's standard output for debugging. -/ 142 | def dump (self : @& ModuleRef) : IO PUnit := do 143 | IO.print (← self.sprint (isForDebug := true)) 144 | 145 | end ModuleRef 146 | -------------------------------------------------------------------------------- /Papyrus/IR/Type.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.IR.TypeID 2 | import Papyrus.IR.TypeRefs 3 | import Papyrus.IR.TypeBases 4 | import Papyrus.IR.AddressSpace 5 | 6 | namespace Papyrus 7 | 8 | -- # The LLVM Type Inductive 9 | 10 | /-- 11 | A pure representation of an LLVM 12 | [Type](https://llvm.org/doxygen/classllvm_1_1Type.html). 13 | -/ 14 | inductive «Type» 15 | | half 16 | | bfloat 17 | | float 18 | | double 19 | | x86FP80 20 | | fp128 21 | | ppcFP128 22 | | void 23 | | label 24 | | metadata 25 | | x86MMX 26 | | x86AMX 27 | | token 28 | | integer (type : IntegerType) 29 | | function (type : BaseFunctionType «Type») 30 | | pointer (type : BasePointerType «Type») 31 | | struct (type : BaseStructType «Type») 32 | | array (type : BaseArrayType «Type») 33 | | fixedVector (type : BaseFixedVectorType «Type») 34 | | scalableVector (type : BaseScalableVectorType «Type») 35 | deriving BEq, Repr 36 | 37 | /-- The LLVM type ID of this type. -/ 38 | @[extern "lean_ptr_tag"] 39 | def Type.typeID : (self : @& «Type») → TypeID 40 | | half => TypeID.half 41 | | bfloat => TypeID.bfloat 42 | | float => TypeID.float 43 | | double => TypeID.double 44 | | x86FP80 => TypeID.x86FP80 45 | | fp128 => TypeID.fp128 46 | | ppcFP128 => TypeID.ppcFP128 47 | | void => TypeID.void 48 | | label => TypeID.label 49 | | metadata => TypeID.metadata 50 | | x86MMX => TypeID.x86MMX 51 | | x86AMX => TypeID.x86AMX 52 | | token => TypeID.token 53 | | integer .. => TypeID.integer 54 | | function .. => TypeID.function 55 | | pointer .. => TypeID.pointer 56 | | struct .. => TypeID.struct 57 | | array .. => TypeID.array 58 | | fixedVector .. => TypeID.fixedVector 59 | | scalableVector .. => TypeID.scalableVector 60 | 61 | -- # Type -> TypeRef 62 | 63 | open BaseStructType in 64 | /-- Get a reference to an external LLVM representation of this type. -/ 65 | partial def Type.getRef : (type : «Type») → LlvmM TypeRef 66 | | half => HalfTypeRef.get 67 | | bfloat => BFloatTypeRef.get 68 | | float => FloatTypeRef.get 69 | | double => DoubleTypeRef.get 70 | | x86FP80 => X86FP80TypeRef.get 71 | | fp128 => FP128TypeRef.get 72 | | ppcFP128 => PPCFP128TypeRef.get 73 | | void => VoidTypeRef.get 74 | | label => LabelTypeRef.get 75 | | metadata => MetadataTypeRef.get 76 | | x86MMX => X86MMXTypeRef.get 77 | | x86AMX => X86AMXTypeRef.get 78 | | token => TokenTypeRef.get 79 | | integer ⟨bitWidth⟩ => 80 | IntegerTypeRef.get bitWidth 81 | | function ⟨retType, paramTypes, isVarArg⟩ => do 82 | FunctionTypeRef.get (← getRef retType) (← paramTypes.mapM getRef) isVarArg 83 | | pointer ⟨pointeeType, addrSpace⟩ => do 84 | PointerTypeRef.get (← getRef pointeeType) addrSpace 85 | | struct type => 86 | match type with 87 | | literal ⟨elemTypes, isPacked⟩ => do 88 | LiteralStructTypeRef.get (← elemTypes.mapM getRef) isPacked 89 | | complete name ⟨elemTypes, isPacked⟩ => do 90 | IdentifiedStructTypeRef.getOrCreate name (← elemTypes.mapM getRef) isPacked 91 | | opaque name => 92 | IdentifiedStructTypeRef.getOrCreateOpaque name 93 | | array ⟨elemType, numElems⟩ => do 94 | ArrayTypeRef.get (← getRef elemType) numElems 95 | | fixedVector ⟨elemType, numElems⟩ => do 96 | FixedVectorTypeRef.get (← getRef elemType) numElems 97 | | scalableVector ⟨elemType, minNumElems⟩ => do 98 | ScalableVectorTypeRef.get (← getRef elemType) minNumElems 99 | 100 | -- # TypeRef -> Type 101 | 102 | open TypeID in 103 | /-- Lift this reference to a pure `Type`. -/ 104 | partial def TypeRef.purify (self : TypeRef) : IO «Type» := do 105 | match h:self.typeID with 106 | | half => Type.half 107 | | bfloat => Type.bfloat 108 | | float => Type.float 109 | | double => Type.double 110 | | x86FP80 => Type.x86FP80 111 | | fp128 => Type.fp128 112 | | ppcFP128 => Type.ppcFP128 113 | | void => Type.void 114 | | label => Type.label 115 | | metadata => Type.metadata 116 | | x86MMX => Type.x86MMX 117 | | x86AMX => Type.x86AMX 118 | | token => Type.token 119 | | integer => 120 | let self := IntegerTypeRef.cast self h 121 | Type.integer ⟨← self.getBitWidth⟩ 122 | | function => 123 | let self := FunctionTypeRef.cast self h 124 | Type.function ⟨← purify <| ← self.getReturnType, 125 | ← Array.mapM purify <| ← self.getParameterTypes, ← self.isVarArg⟩ 126 | | pointer => 127 | let self := PointerTypeRef.cast self h 128 | Type.pointer ⟨← purify <| ← self.getPointeeType, ← self.getAddressSpace⟩ 129 | | struct => 130 | let self := StructTypeRef.cast self h 131 | if h : self.isLiteral then 132 | let self := LiteralStructTypeRef.cast self h 133 | Type.struct <| BaseStructType.literal 134 | ⟨← Array.mapM purify <| ← self.getElementTypes, ← self.isPacked⟩ 135 | else 136 | let self := IdentifiedStructTypeRef.cast self h 137 | if (← self.isOpaque) then 138 | Type.struct <| BaseStructType.opaque (← self.getName) 139 | else 140 | Type.struct <| BaseStructType.complete (← self.getName) 141 | ⟨← Array.mapM purify <| ← self.getElementTypes, ← self.isPacked⟩ 142 | | array => 143 | let self := ArrayTypeRef.cast self h 144 | Type.array ⟨← purify <| ← self.getElementType, ← self.getSize⟩ 145 | | fixedVector => 146 | let self := FixedVectorTypeRef.cast self h 147 | Type.fixedVector ⟨← purify <| ← self.getElementType, ← self.getSize⟩ 148 | | scalableVector => 149 | let self := ScalableVectorTypeRef.cast self h 150 | Type.scalableVector ⟨← purify <| ← self.getElementType, ← self.getMinSize⟩ 151 | -------------------------------------------------------------------------------- /Papyrus/IR/TypeID.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | /-- Identifiers for all of the base types of the LLVM (v12) type system. -/ 4 | inductive TypeID 5 | -- Primitive types 6 | | /-- 16-bit floating point type -/ 7 | half 8 | | /-- 16-bit floating point type (7-bit significand) -/ 9 | bfloat 10 | | /-- 32-bit floating point type -/ 11 | float 12 | | /-- 64-bit floating point type -/ 13 | double 14 | | /-- 80-bit floating point type (X87) -/ 15 | x86FP80 16 | | /-- 128-bit floating point type (112-bit significand) -/ 17 | fp128 18 | | /-- 128-bit floating point type -/ 19 | ppcFP128 20 | | /-- type with no size -/ 21 | void 22 | | label 23 | | metadata 24 | | /-- MMX vectors (64 bits, X86 specific) -/ 25 | x86MMX 26 | | /-- AMX vectors (8192 bits, X86 specific) -/ 27 | x86AMX 28 | | token 29 | -- Derived types 30 | | /-- Arbitrary bit width integers -/ 31 | integer 32 | | function 33 | | pointer 34 | | struct 35 | | array 36 | | /-- Fixed width SIMD vector type -/ 37 | fixedVector 38 | | /-- Scalable SIMD vector type -/ 39 | scalableVector 40 | deriving Inhabited, BEq, DecidableEq, Repr 41 | 42 | attribute [unbox] TypeID 43 | -------------------------------------------------------------------------------- /Papyrus/IR/TypeRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.FFI 2 | import Papyrus.Context 3 | import Papyrus.IR.TypeID 4 | 5 | namespace Papyrus 6 | 7 | /-- 8 | An opaque type representing and external LLVM 9 | [Type](https://llvm.org/doxygen/classllvm_1_1Type.html). 10 | -/ 11 | constant Llvm.Type : Type := Unit 12 | 13 | /-- 14 | A reference to an external LLVM 15 | [Type](https://llvm.org/doxygen/classllvm_1_1Type.html). 16 | -/ 17 | structure TypeRef where 18 | ptr : LinkedLoosePtr ContextRef Llvm.Type 19 | 20 | namespace TypeRef 21 | 22 | /-- The `TypeID` of this type. -/ 23 | @[extern "papyrus_type_id"] 24 | constant typeID (self : TypeRef) : TypeID 25 | 26 | /-- Get the owning LLVM context of this type. -/ 27 | @[extern "papyrus_type_get_context"] 28 | constant getContext (self : TypeRef) : IO ContextRef 29 | 30 | /-- 31 | Print this type (without a newline) to 32 | LLVM's standard output (which may not correspond to Lean's). 33 | 34 | If `noDetails`, print just the name of identified struct types. 35 | -/ 36 | @[extern "papyrus_type_print"] 37 | constant print (self : @& TypeRef) (isForDebug := false) (noDetails := false) : IO PUnit 38 | 39 | /-- 40 | Print this type (without a newline) 41 | to LLVM's standard error (which may not correspond to Lean's). 42 | 43 | If `noDetails`, print just the name of identified struct types. 44 | -/ 45 | @[extern "papyrus_type_eprint"] 46 | constant eprint (self : @& TypeRef) (isForDebug := false) (noDetails := false) : IO PUnit 47 | 48 | /-- 49 | Print this type to a string (without a newline). 50 | 51 | If `noDetails`, print just the name of identified struct types. 52 | -/ 53 | @[extern "papyrus_type_sprint"] 54 | constant sprint (self : @& TypeRef) (isForDebug := false) (noDetails := false) : IO String 55 | 56 | /-- Print this type to Lean's standard output for debugging (with a newline). -/ 57 | def dump (self : @& TypeRef) : IO PUnit := do 58 | IO.println (← self.sprint (isForDebug := true)) 59 | -------------------------------------------------------------------------------- /Papyrus/IR/ValueKind.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Internal.Enum 2 | 3 | namespace Papyrus 4 | 5 | open Internal 6 | 7 | /-- Tags for all of LLVM (v12) IR value types. -/ 8 | sealed-enum ValueKind : UInt8 9 | | function 10 | | globalAlias 11 | | globalIFunc 12 | | globalVariable 13 | | blockAddress 14 | | constantExpr 15 | | dsoLocalEquivalent 16 | | constantArray 17 | | constantStruct 18 | | constantVector 19 | | undef 20 | | poison 21 | | constantAggregateZero 22 | | constantDataArray 23 | | constantDataVector 24 | | constantInt 25 | | constantFP 26 | | constantPointerNull 27 | | constantTokenNone 28 | | argument 29 | | basicBlock 30 | | metadataAsValue 31 | | inlineAsm 32 | | memoryUse 33 | | memoryDef 34 | | memoryPhi 35 | | instruction 36 | deriving Inhabited, BEq, DecidableEq, Repr 37 | 38 | namespace ValueKind 39 | 40 | def ofValueID (id : UInt32) : ValueKind := 41 | let id := id.toUInt8 42 | if h : id ≤ maxVal then 43 | mk id h 44 | else 45 | instruction 46 | 47 | def toValueID (self : ValueKind) : UInt32 := 48 | self.val.toUInt32 49 | -------------------------------------------------------------------------------- /Papyrus/IR/ValueRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Context 2 | import Papyrus.IR.TypeRef 3 | import Papyrus.IR.ValueKind 4 | 5 | namespace Papyrus 6 | 7 | /-- 8 | An opaque type representing an external LLVM 9 | [Value](https://llvm.org/doxygen/classllvm_1_1Value.html). 10 | -/ 11 | constant Llvm.Value : Type := Unit 12 | 13 | /-- 14 | A reference to an external LLVM 15 | [Value](https://llvm.org/doxygen/classllvm_1_1Value.html). 16 | -/ 17 | structure ValueRef where 18 | ptr : LinkedLoosePtr ContextRef Llvm.Value 19 | 20 | namespace ValueRef 21 | 22 | /-- The raw ID of this value. -/ 23 | @[extern "papyrus_value_id"] 24 | constant valueID (self : @& ValueRef) : UInt32 25 | 26 | /-- The `ValueKind` of this value. -/ 27 | def valueKind (self : ValueRef) : ValueKind := 28 | ValueKind.ofValueID self.valueID 29 | 30 | /-- Get a reference to this value's type. -/ 31 | @[extern "papyrus_value_get_type"] 32 | constant getType (self : @& ValueRef) : IO TypeRef 33 | 34 | /-- Get whether this value has a name. -/ 35 | @[extern "papyrus_value_has_name"] 36 | constant hasName (self : @& ValueRef) : IO Bool 37 | 38 | /-- Get the name of this value (or the empty string if none). -/ 39 | @[extern "papyrus_value_get_name"] 40 | constant getName (self : @& ValueRef) : IO String 41 | 42 | /-- 43 | Set the name of this value. 44 | Passing the empty string will remove the value's name. 45 | -/ 46 | @[extern "papyrus_value_set_name"] 47 | constant setName (name : @& String) (self : @& ValueRef) : IO PUnit 48 | 49 | /-- 50 | Print this value (without a newline) 51 | to LLVM's standard output (which may not correspond to Lean's). 52 | -/ 53 | @[extern "papyrus_value_print"] 54 | constant print (self : @& ValueRef) (isForDebug := false) : IO PUnit 55 | 56 | /-- 57 | Print this value (without a newline) 58 | to LLVM's standard error (which may not correspond to Lean's). 59 | -/ 60 | @[extern "papyrus_value_eprint"] 61 | constant eprint (self : @& ValueRef) (isForDebug := false) : IO PUnit 62 | 63 | /-- Print this value to a string (without a newline). -/ 64 | @[extern "papyrus_value_sprint"] 65 | constant sprint (self : @& ValueRef) (isForDebug := false) : IO String 66 | 67 | /-- Print this value to Lean's standard output for debugging (with a newline). -/ 68 | def dump (self : @& ValueRef) : IO PUnit := do 69 | IO.println (← self.sprint (isForDebug := true)) 70 | 71 | end ValueRef 72 | 73 | /-- 74 | A reference to an external LLVM 75 | [User](https://llvm.org/doxygen/classllvm_1_1User.html). 76 | -/ 77 | structure UserRef extends ValueRef 78 | instance : Coe UserRef ValueRef := ⟨(·.toValueRef)⟩ 79 | -------------------------------------------------------------------------------- /Papyrus/Init.lean: -------------------------------------------------------------------------------- 1 | namespace Papyrus 2 | 3 | -- # All Target Initialization 4 | 5 | /-- Initializes all LLVM supported targets. -/ 6 | @[extern "papyrus_init_all_targets"] 7 | constant initAllTargets : IO PUnit 8 | 9 | /-- Initializes all LLVM supported target MCs. -/ 10 | @[extern "papyrus_init_all_target_mcs"] 11 | constant initAllTargetMCs : IO PUnit 12 | 13 | /-- Initializes all LLVM supported target infos. -/ 14 | @[extern "papyrus_init_all_target_infos"] 15 | constant initAllTargetInfos : IO PUnit 16 | 17 | /-- Initializes all LLVM supported target assembly parsers. -/ 18 | @[extern "papyrus_init_all_asm_parsers"] 19 | constant initAllAsmParsers : IO PUnit 20 | 21 | /-- Initializes all LLVM supported target assembly printers. -/ 22 | @[extern "papyrus_init_all_asm_printers"] 23 | constant initAllAsmPrinters : IO PUnit 24 | 25 | /-- Initializes all LLVM supported target disassemblers. -/ 26 | @[extern "papyrus_init_all_disassemblers"] 27 | constant initAllDisassemblers : IO PUnit 28 | 29 | -- # Native Target Initialization 30 | 31 | /-- 32 | Initializes the native target along with its MC and Info. 33 | Returns true if no native target exists, false otherwise. 34 | -/ 35 | @[extern "papyrus_init_native_target"] 36 | constant initNativeTarget : IO Bool 37 | 38 | /-- 39 | Initializes the native target's ASM parser. 40 | Returns true if no native target exists, false otherwise. 41 | -/ 42 | @[extern "papyrus_init_native_asm_parser"] 43 | constant initNativeAsmParser : IO Bool 44 | 45 | 46 | /-- 47 | Initializes the native target's ASM printer. 48 | Returns true if no native target exists, false otherwise. 49 | -/ 50 | @[extern "papyrus_init_native_asm_printer"] 51 | constant initNativeAsmPrinter : IO Bool 52 | 53 | 54 | /-- 55 | Initializes the native target's disassembler. 56 | Returns true if no native target exists, false otherwise. 57 | -/ 58 | @[extern "papyrus_init_native_disassembler"] 59 | constant initNativeDisassembler : IO Bool 60 | -------------------------------------------------------------------------------- /Papyrus/Internal/Enum.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser.Command 2 | 3 | open Lean Parser Command 4 | 5 | namespace Papyrus.Internal 6 | 7 | def mkSealedEnumReprInst (ty : Syntax) (ctors : Array Syntax) : MacroM Syntax := do 8 | let currNamespace ← Macro.getCurrNamespace 9 | let ctorFmts ← ctors.mapM fun ctor => 10 | `(Std.format $(quote <| toString (currNamespace ++ ctor[2].getId))) 11 | `(def reprFormats : Array Std.Format := #[$[$ctorFmts],*] 12 | instance : Repr $ty := ⟨fun e _ => reprFormats[e.val.val]⟩) 13 | 14 | def unpackOptDeriving : (stx : Syntax) → (Array Syntax × Array (Option Syntax)) 15 | | `(optDeriving| deriving $[$clss $[with $argss?]?],*) => (clss, argss?) 16 | | _ => (#[], #[]) 17 | 18 | 19 | set_option hygiene false 20 | 21 | -------------------------------------------------------------------------------- 22 | -- # Open Enums 23 | -------------------------------------------------------------------------------- 24 | 25 | syntax enumCtor := "\n| " declModifiers ident " := " term 26 | 27 | scoped macro (name := enumDecl) 28 | mods:declModifiers 29 | "enum " id:ident " : " type:term optional(" := " <|> " where ") 30 | ctors:many(enumCtor) 31 | deriv?:optDeriving 32 | : command => do 33 | let mut defs : Array Syntax := #[] 34 | -- structure 35 | defs := defs.push <| ← 36 | `($mods:declModifiers 37 | structure $id where 38 | val : $type 39 | $deriv?:optDeriving) 40 | -- constructors 41 | for ctor in ctors do 42 | let ctorId := ctor[2] 43 | let ctorQualId := mkIdentFrom ctorId <| 44 | id.getId.modifyBase (· ++ ctorId.getId) 45 | let ctorVal := ctor[4] 46 | let ctorMods := ctor[1] 47 | defs := defs.push <| ← 48 | `($ctorMods:declModifiers def $ctorQualId:ident : $id := mk $ctorVal) 49 | mkNullNode defs 50 | 51 | -------------------------------------------------------------------------------- 52 | -- # Sealed Enums 53 | -------------------------------------------------------------------------------- 54 | 55 | syntax identCtor := "\n| " declModifiers ident 56 | 57 | scoped macro (name := sealedEnumDecl) 58 | mods:declModifiers 59 | "sealed-enum " id:ident " : " type:term optional(" := " <|> " where ") 60 | ctors:many(identCtor) 61 | deriv?:optDeriving 62 | : command => do 63 | let mut innerDefs := #[] 64 | let numCtors := ctors.size 65 | let maxValLit := quote (numCtors - 1) 66 | -- filter out special deriving instances 67 | let mut derivBEq := false 68 | let mut derivDecEq := false 69 | let mut derivInhabited := false 70 | let mut derivRepr := false 71 | let mut remClasses := #[] 72 | let mut remArgss? := #[] 73 | let (classes, argss?) := unpackOptDeriving deriv? 74 | for cls in classes, args? in argss? do 75 | if cls.matchesIdent ``BEq then 76 | derivBEq := true 77 | else if cls.matchesIdent ``DecidableEq then 78 | derivDecEq := true 79 | else if cls.matchesIdent ``Inhabited then 80 | derivInhabited := true 81 | else if cls.matchesIdent ``Repr then 82 | derivRepr := true 83 | else 84 | remClasses := remClasses.push cls 85 | remArgss? := remArgss?.push args? 86 | -- structure 87 | let structDecl ← 88 | `($mods:declModifiers 89 | structure $id where 90 | val : $type 91 | h : val ≤ $maxValLit 92 | deriving $[$remClasses $[with $remArgss?]?],*) 93 | -- maximum 94 | innerDefs := innerDefs.push <| ← 95 | `(def maxVal : $type := $maxValLit) 96 | -- theorems 97 | innerDefs := innerDefs.push <| ← 98 | `(theorem eq_of_val_eq : {a b : $id} → a.val = b.val → a = b 99 | | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl 100 | theorem val_eq_of_eq {a b : $id} (h : a = b) : a.val = b.val := 101 | h ▸ rfl 102 | theorem ne_of_val_ne {a b : $id} (h : a.val ≠ b.val) : a ≠ b := 103 | fun h' => absurd (val_eq_of_eq h') h) 104 | -- constructors 105 | for ctor in ctors, i in [:numCtors] do 106 | let ctorVal := quote i 107 | let ctorMods := ctor[1] 108 | let ctorId := ctor[2] 109 | innerDefs := innerDefs.push <| ← 110 | `($ctorMods:declModifiers def $ctorId:ident : $id := mk $ctorVal (by decide)) 111 | -- derive special instance 112 | if derivBEq then 113 | innerDefs := innerDefs.push <| ← 114 | `(instance : BEq $id := ⟨fun a b => a.val == b.val⟩) 115 | if derivDecEq then 116 | innerDefs := innerDefs.push <| ← 117 | `(instance : DecidableEq $id := fun a b => 118 | if h : a.val = b.val 119 | then isTrue (eq_of_val_eq h) 120 | else isFalse (ne_of_val_ne h)) 121 | if derivInhabited then 122 | innerDefs := innerDefs.push <| ← 123 | `(instance : Inhabited $id := ⟨mk maxVal (Nat.le_refl _)⟩) 124 | if derivRepr then 125 | innerDefs := innerDefs.push <| ← mkSealedEnumReprInst id ctors 126 | -- syntax 127 | `($structDecl:command 128 | namespace $id:ident 129 | $(mkNullNode innerDefs) 130 | end $id:ident) 131 | -------------------------------------------------------------------------------- /Papyrus/MemoryBufferRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.FFI 2 | 3 | namespace Papyrus 4 | 5 | /-- 6 | An opaque type representing an LLVM 7 | [MemoryBuffer](https://llvm.org/doxygen/classllvm_1_1MemoryBuffer.html). 8 | -/ 9 | constant Llvm.MemoryBuffer : Type := Unit 10 | 11 | /-- 12 | A reference to an external LLVM 13 | [MemoryBuffer](https://llvm.org/doxygen/classllvm_1_1MemoryBuffer.html). 14 | -/ 15 | def MemoryBufferRef := OwnedPtr Llvm.MemoryBuffer 16 | 17 | /-- Construct a memory buffer from a file. -/ 18 | @[extern "papyrus_memory_buffer_from_file"] 19 | constant MemoryBufferRef.fromFile (file : @& System.FilePath) : IO MemoryBufferRef 20 | -------------------------------------------------------------------------------- /Papyrus/Script.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Script.Label 2 | import Papyrus.Script.Module 3 | import Papyrus.Script.Function 4 | import Papyrus.Script.Instructions 5 | import Papyrus.Script.Type 6 | import Papyrus.Script.Dump 7 | import Papyrus.Script.Verify 8 | import Papyrus.Script.Jit 9 | -------------------------------------------------------------------------------- /Papyrus/Script/AddressSpace.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.IR.AddressSpace 3 | 4 | namespace Papyrus.Script 5 | 6 | open Lean Parser 7 | 8 | @[runParserAttributeHooks] 9 | def addrspace := leading_parser 10 | nonReservedSymbol "addrspace" true >> "(" >> termParser >> ")" 11 | 12 | def expandAddrspace : (addrSpace : Syntax) → MacroM Syntax 13 | | `(addrspace| addrspace($x:term)) => x 14 | | stx => Macro.throwErrorAt stx "ill-formed address space" 15 | 16 | def expandOptAddrspace : (addrspace? : Option Syntax) → MacroM Syntax 17 | | some addrspace => expandAddrspace addrspace 18 | | none => mkCIdent ``AddressSpace.default 19 | -------------------------------------------------------------------------------- /Papyrus/Script/Do.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | 3 | namespace Papyrus.Script 4 | 5 | open Lean Parser 6 | 7 | -- # Module Do 8 | 9 | declare_syntax_cat modDoElem (behavior := symbol) 10 | def modDoElemParser (rbp : Nat := 0) := categoryParser `modDoElem rbp 11 | def modDoSeqItem := leading_parser ppLine >> modDoElemParser >> Parser.optional "; " 12 | def modDoSeqIndent := leading_parser many1Indent modDoSeqItem 13 | def modDoSeqBracketed := leading_parser "{" >> withoutPosition (many1 modDoSeqItem) >> ppLine >> "}" 14 | def modDoSeq := modDoSeqIndent <|> modDoSeqBracketed 15 | 16 | attribute [runParserAttributeHooks] 17 | modDoElemParser modDoSeqItem modDoSeqItem modDoSeqBracketed modDoSeq 18 | 19 | def expandModDoSeq : Syntax → MacroM (Array Syntax) 20 | | `(modDoSeq| { $[$elems:modDoElem]* }) => elems 21 | | `(modDoSeq| $[$elems:modDoElem $[;]?]*) => elems 22 | | stx => Macro.throwErrorAt stx "ill-formed module do sequence" 23 | 24 | -- # Basic Block Do 25 | 26 | declare_syntax_cat bbDoElem (behavior := symbol) 27 | def bbDoElemParser (rbp : Nat := 0) := categoryParser `bbDoElem rbp 28 | def bbDoSeqItem := leading_parser ppLine >> bbDoElemParser >> Parser.optional "; " 29 | def bbDoSeqIndent := leading_parser many1Indent bbDoSeqItem 30 | def bbDoSeqBracketed := leading_parser "{" >> withoutPosition (many1 bbDoSeqItem) >> ppLine >> "}" 31 | def bbDoSeq := bbDoSeqIndent <|> bbDoSeqBracketed 32 | 33 | attribute [runParserAttributeHooks] 34 | bbDoElemParser bbDoSeqItem bbDoSeqIndent bbDoSeqBracketed bbDoSeq 35 | 36 | def expandBbDoSeq : Syntax → MacroM (Array Syntax) 37 | | `(bbDoSeq| { $[$elems:bbDoElem]* }) => elems 38 | | `(bbDoSeq| $[$elems:bbDoElem $[;]?]*) => elems 39 | | stx => Macro.throwErrorAt stx "ill-formed basic block do sequence" 40 | 41 | -- # Nesting Lean Do Elements 42 | 43 | macro (priority := low) x:doElem : modDoElem => x 44 | macro (priority := low) x:doElem : bbDoElem => x 45 | -------------------------------------------------------------------------------- /Papyrus/Script/Dump.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.IR.Types 2 | import Papyrus.IR.TypeRefs 3 | import Papyrus.IR.ConstantRefs 4 | import Papyrus.IR.InstructionRefs 5 | import Papyrus.IR.ModuleRef 6 | import Papyrus.Script.SyntaxUtil 7 | 8 | namespace Papyrus.Script 9 | 10 | -- # Dump Class 11 | 12 | class DumpRef (α : Type u) where 13 | dumpRef : α → IO PUnit 14 | 15 | export DumpRef (dumpRef) 16 | 17 | class Dump (α : Type u) where 18 | dump : α → LlvmM PUnit 19 | 20 | export Dump (dump) 21 | 22 | instance [DumpRef α] : Dump α := ⟨liftM ∘ dumpRef⟩ 23 | 24 | instance : DumpRef TypeRef := ⟨(·.dump)⟩ 25 | instance : DumpRef VoidTypeRef := ⟨(·.dump)⟩ 26 | instance : DumpRef LabelTypeRef := ⟨(·.dump)⟩ 27 | instance : DumpRef MetadataTypeRef := ⟨(·.dump)⟩ 28 | instance : DumpRef TokenTypeRef := ⟨(·.dump)⟩ 29 | instance : DumpRef X86MMXTypeRef := ⟨(·.dump)⟩ 30 | instance : DumpRef X86AMXTypeRef := ⟨(·.dump)⟩ 31 | instance : DumpRef HalfTypeRef := ⟨(·.dump)⟩ 32 | instance : DumpRef BFloatTypeRef := ⟨(·.dump)⟩ 33 | instance : DumpRef FloatTypeRef := ⟨(·.dump)⟩ 34 | instance : DumpRef DoubleTypeRef := ⟨(·.dump)⟩ 35 | instance : DumpRef X86FP80TypeRef := ⟨(·.dump)⟩ 36 | instance : DumpRef FP128TypeRef := ⟨(·.dump)⟩ 37 | instance : DumpRef PPCFP128TypeRef := ⟨(·.dump)⟩ 38 | instance : DumpRef IntegerTypeRef := ⟨(·.dump)⟩ 39 | instance : DumpRef FunctionTypeRef := ⟨(·.dump)⟩ 40 | instance : DumpRef PointerTypeRef := ⟨(·.dump)⟩ 41 | instance : DumpRef StructTypeRef := ⟨(·.dump)⟩ 42 | instance : DumpRef LiteralStructTypeRef := ⟨(·.dump)⟩ 43 | instance : DumpRef IdentifiedStructTypeRef := ⟨(·.dump)⟩ 44 | instance : DumpRef ArrayTypeRef := ⟨(·.dump)⟩ 45 | instance : DumpRef VectorTypeRef := ⟨(·.dump)⟩ 46 | instance : DumpRef FixedVectorTypeRef := ⟨(·.dump)⟩ 47 | instance : DumpRef ScalableVectorTypeRef := ⟨(·.dump)⟩ 48 | 49 | instance : Dump «Type» := ⟨fun t => do dump <| ← t.getRef⟩ 50 | instance : Dump IntegerType := ⟨fun t => do dump <| ← t.getRef⟩ 51 | instance : Dump FunctionType := ⟨fun t => do dump <| ← t.getRef⟩ 52 | instance : Dump PointerType := ⟨fun t => do dump <| ← t.getRef⟩ 53 | instance : Dump StructType := ⟨fun t => do dump <| ← t.getRef⟩ 54 | instance : Dump ArrayType := ⟨fun t => do dump <| ← t.getRef⟩ 55 | instance : Dump VectorType := ⟨fun t => do dump <| ← t.getRef⟩ 56 | instance : Dump FixedVectorType := ⟨fun t => do dump <| ← t.getRef⟩ 57 | instance : Dump ScalableVectorType := ⟨fun t => do dump <| ← t.getRef⟩ 58 | 59 | instance : DumpRef ValueRef := ⟨(·.dump)⟩ 60 | instance : DumpRef UserRef := ⟨(·.dump)⟩ 61 | instance : DumpRef ConstantRef := ⟨(·.dump)⟩ 62 | instance : DumpRef ConstantIntRef := ⟨(·.dump)⟩ 63 | instance : DumpRef ConstantDataArrayRef := ⟨(·.dump)⟩ 64 | instance : DumpRef FunctionRef := ⟨(·.dump)⟩ 65 | instance : DumpRef GlobalValueRef := ⟨(·.dump)⟩ 66 | instance : DumpRef GlobalObjectRef := ⟨(·.dump)⟩ 67 | instance : DumpRef GlobalVariableRef := ⟨(·.dump)⟩ 68 | 69 | instance : DumpRef InstructionRef := ⟨(·.dump)⟩ 70 | instance : DumpRef ReturnInstRef := ⟨(·.dump)⟩ 71 | 72 | instance : DumpRef ModuleRef := ⟨ModuleRef.dump⟩ 73 | 74 | -- # Dump Command 75 | 76 | macro kw:"#dump " x:term : command => do 77 | mkEvalAt kw <| ← ``(LlvmM.run ($x >>= dump)) 78 | -------------------------------------------------------------------------------- /Papyrus/Script/Function.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Builders 3 | import Papyrus.Script.Do 4 | import Papyrus.Script.Type 5 | import Papyrus.Script.ParserUtil 6 | import Papyrus.Script.GlobalModifiers 7 | 8 | namespace Papyrus.Script 9 | open Builder Lean Parser Term 10 | 11 | def mkFunctionType (ret : Syntax) (params : Array Syntax) (varArg : Syntax) : MacroM Syntax := 12 | `(← functionType $ret #[$[$params:term],*] $varArg |>.getRef) 13 | 14 | -- ## Function Parameters 15 | 16 | @[runParserAttributeHooks] 17 | def paramBinder := leading_parser 18 | typeParser >> Parser.optional ("%" >> Parser.ident) 19 | 20 | @[runParserAttributeHooks] 21 | def paramBinders := leading_parser 22 | "(" >> sepBy paramBinder "," (allowTrailingSep := true) >> Parser.optional vararg >> ")" 23 | 24 | def expandParamBinder : (binder : Syntax) → MacroM (Syntax × Option Syntax) 25 | | `(paramBinder| $ty:llvmType $[ % $arg? ]?) => do (← expandType ty, arg?) 26 | | stx => Macro.throwErrorAt stx "ill-formed function parameter" 27 | 28 | def expandParamBinders (binders : Array Syntax) : MacroM (Array Syntax × Array (Option Syntax)) := do 29 | Array.unzip <| ← binders.mapM expandParamBinder 30 | 31 | -- ## Function Declaration 32 | 33 | @[runParserAttributeHooks] 34 | def llvmFunDecl := leading_parser 35 | Parser.optional linkage >> 36 | typeParser >> "@" >> Parser.ident >> paramBinders >> 37 | Parser.optional addrspace 38 | 39 | def mkArgNameSetters (fn : Syntax) (args : Array (Option Syntax)) : MacroM (Array Syntax) := do 40 | let mut stmts := #[] 41 | for argNo in [0:args.size] do 42 | if let some arg := args.get! argNo then 43 | stmts := stmts.push <| ← `(doElem| do 44 | let x ← FunctionRef.getArg $(quote argNo) $fn:ident 45 | ValueRef.setName $(identAsStrLit arg) x) 46 | return stmts 47 | 48 | 49 | def expandLlvmFunDecl : Macro 50 | | `(llvmFunDecl| $[$linkage?]? $rty:llvmType @ $id:ident ($[$bs:paramBinder],* $[$vararg?:vararg]?) $[$addrspace?:addrspace]?) => do 51 | let name := identAsStrLit id 52 | let rtyx ← expandType rty 53 | let vararg := quote vararg?.isSome 54 | let (ptys, args) ← expandParamBinders bs 55 | let type ← mkFunctionType rtyx ptys vararg 56 | let linkage ← expandOptLinkage linkage? 57 | let addrspace ← expandOptAddrspace addrspace? 58 | let stmts ← mkArgNameSetters id args 59 | `(doElem| do let $id:ident ← declare $type $name $linkage $addrspace; $[$stmts:doElem]*) 60 | | stx => Macro.throwErrorAt stx "ill-formed declare" 61 | 62 | macro "declare " d:llvmFunDecl : modDoElem => expandLlvmFunDecl d 63 | scoped macro "llvm " &"declare " d:llvmFunDecl : doElem => expandLlvmFunDecl d 64 | 65 | -- ## Function Definition 66 | 67 | @[runParserAttributeHooks] 68 | def llvmFunDef := leading_parser 69 | Parser.optional linkage >> 70 | typeParser >> "@" >> Parser.ident >> paramBinders >> 71 | Parser.optional addrspace >> 72 | " do " >> bbDoSeq 73 | 74 | def mkArgLets (args : Array (Option Syntax)) : MacroM (Array Syntax) := do 75 | let mut argLets := #[] 76 | for argNo in [0:args.size] do 77 | if let some arg := args.get! argNo then 78 | argLets := argLets.push <| ← `(doElem| do 79 | let $arg:ident ← getArg $(quote argNo) 80 | ValueRef.setName $(identAsStrLit arg) $arg:ident) 81 | return argLets 82 | 83 | def expandLlvmFunDef : Macro 84 | | `(llvmFunDef| $[$linkage?]? $rty:llvmType @ $id:ident ($[$bs:paramBinder],* $[$vararg?:vararg]?) $[$addrspace?:addrspace]? do $seq) => do 85 | let name := identAsStrLit id 86 | let rtyx ← expandType rty 87 | let vararg := quote vararg?.isSome 88 | let (ptys, args) ← expandParamBinders bs 89 | let type ← mkFunctionType rtyx ptys vararg 90 | let linkage ← expandOptLinkage linkage? 91 | let addrspace ← expandOptAddrspace addrspace? 92 | let bbDoElems ← expandBbDoSeq seq 93 | let doElems ← bbDoElems.mapM expandMacros 94 | let argLets ← mkArgLets args 95 | let stmts := argLets ++ doElems 96 | `(doElem| let $id:ident ← define $type (do {$[$stmts:doElem]*}) $name $linkage $addrspace) 97 | | stx => Macro.throwErrorAt stx "ill-formed define" 98 | 99 | macro "define " d:llvmFunDef : modDoElem => expandLlvmFunDef d 100 | scoped macro "llvm " &"define " d:llvmFunDef : doElem => expandLlvmFunDef d 101 | -------------------------------------------------------------------------------- /Papyrus/Script/GlobalModifiers.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.IR.GlobalModifiers 3 | 4 | namespace Papyrus.Script 5 | open Lean Parser Term 6 | 7 | -- ## Linkage 8 | 9 | @[runParserAttributeHooks] 10 | def linkageLit := leading_parser 11 | nonReservedSymbol "external" <|> 12 | nonReservedSymbol "available_externally" <|> 13 | nonReservedSymbol "linkonce" <|> 14 | nonReservedSymbol "linkonce_odr" <|> 15 | nonReservedSymbol "weak" <|> 16 | nonReservedSymbol "weak_odr" <|> 17 | nonReservedSymbol "appending" <|> 18 | nonReservedSymbol "internal" <|> 19 | nonReservedSymbol "private" <|> 20 | nonReservedSymbol "extern_weak" <|> 21 | nonReservedSymbol "common" 22 | 23 | @[runParserAttributeHooks] 24 | def linkageTerm := leading_parser 25 | nonReservedSymbol "linkage" >> "(" >> termParser >> ")" 26 | 27 | @[runParserAttributeHooks] 28 | def linkage := linkageTerm <|> linkageLit 29 | 30 | def expandLinkageLit (stx : Syntax) : (linkage : String) → MacroM Syntax 31 | | "external" => mkCIdent ``Linkage.external 32 | | "available_externally" => mkCIdent ``Linkage.availableExternally 33 | | "linkonce" => mkCIdent ``Linkage.linkOnceAny 34 | | "linkonce_odr" => mkCIdent ``Linkage.linkOnceODR 35 | | "weak" => mkCIdent ``Linkage.weakAny 36 | | "weak_odr" => mkCIdent ``Linkage.weakODR 37 | | "appending" => mkCIdent ``Linkage.appending 38 | | "internal" => mkCIdent ``Linkage.internal 39 | | "private" => mkCIdent ``Linkage.private 40 | | "extern_weak" => mkCIdent ``Linkage.externalWeak 41 | | "common" => mkCIdent ``Linkage.common 42 | | _ => Macro.throwErrorAt stx "unknown linkage" 43 | 44 | def expandLinkage : (linkage : Syntax) → MacroM Syntax 45 | | `(linkage| linkage($x:term)) => x 46 | | linkage => 47 | match linkage.isLit? ``Script.linkageLit with 48 | | some val => expandLinkageLit linkage val 49 | | none => Macro.throwErrorAt linkage "ill-formed linkage" 50 | 51 | def expandOptLinkage : (linkage? : Option Syntax) → MacroM Syntax 52 | | some linkage => expandLinkage linkage 53 | | none => mkCIdent ``Linkage.external 54 | -------------------------------------------------------------------------------- /Papyrus/Script/IntegerType.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Script.SyntaxUtil 3 | import Papyrus.IR.Types 4 | 5 | namespace Papyrus.Script 6 | 7 | -- # Matcher 8 | 9 | partial def isDecimalTail (str : String) (i : String.Pos) : Bool := 10 | if str.atEnd i then true else 11 | if (str.get i).isDigit then isDecimalTail str (str.next i) else 12 | false 13 | 14 | def isDecimal (str : String) (i : String.Pos) : Bool := 15 | if str.atEnd i then false else 16 | if (str.get i).isDigit then isDecimalTail str (str.next i) else false 17 | 18 | partial def decodeDecimalTail? (str : String) (i : String.Pos) (val : Nat) : Option Nat := 19 | if str.atEnd i then some val 20 | else 21 | let c := str.get i 22 | if c.isDigit then 23 | decodeDecimalTail? str (str.next i) (10*val + c.toNat - '0'.toNat) 24 | else none 25 | 26 | def decodeDecimal? (str : String) (i : String.Pos) : Option Nat := 27 | if str.atEnd i then none else let c := str.get i 28 | if c.isDigit then decodeDecimalTail? str (str.next i) (c.toNat - '0'.toNat) else none 29 | 30 | def isIntTypeLit (str : String) : Bool := 31 | let i : String.Pos := 0 32 | if str.atEnd i then false else 33 | if str.get i == 'i' then isDecimal str (str.next i) else false 34 | 35 | -- # Parser 36 | 37 | open Lean 38 | 39 | section 40 | open Parser 41 | 42 | def intTypeLitFn : ParserFn := fun c s => 43 | let errorMsg := "'intTypeLit'" 44 | let initStackSz := s.stackSize 45 | let startPos := s.pos 46 | let s := tokenFn [errorMsg] c s 47 | if s.hasError then s 48 | else 49 | match s.stxStack.back with 50 | | Syntax.ident info rawVal _ _ => 51 | let atom := rawVal.toString 52 | if isIntTypeLit atom then 53 | let s := s.popSyntax 54 | s.pushSyntax <| Syntax.mkLit `Papyrus.Script.intTypeLit atom info 55 | else 56 | s.mkErrorAt errorMsg startPos initStackSz 57 | | _ => s.mkErrorAt errorMsg startPos initStackSz 58 | 59 | @[inline] def intTypeLitNoAntiquot : Parser := { 60 | fn := intTypeLitFn 61 | info := { firstTokens := FirstTokens.tokens [ "intTypeLit", "ident" ] } 62 | } 63 | 64 | def intTypeLit : Parser := 65 | withAntiquot (mkAntiquot "intTypeLit" `Papyrus.Script.intTypeLit) intTypeLitNoAntiquot 66 | 67 | end 68 | 69 | -- # Pretty Printer 70 | 71 | section 72 | open PrettyPrinter Formatter Parenthesizer 73 | 74 | @[combinatorFormatter Papyrus.Script.intTypeLitNoAntiquot] 75 | def intTypeLitNoAntiquot.formatter := identNoAntiquot.formatter 76 | 77 | @[combinatorParenthesizer Papyrus.Script.intTypeLitNoAntiquot] 78 | def intTypeLitNoAntiquot.parenthesizer := identNoAntiquot.parenthesizer 79 | end 80 | 81 | attribute [runParserAttributeHooks] intTypeLit 82 | 83 | -- # Macro 84 | 85 | def decodeIntTypeLit? (stx : Lean.Syntax) : Option Nat := 86 | OptionM.run do decodeDecimal? (← stx.isLit? ``intTypeLit) 1 87 | 88 | def expandIntTypeLitAsNatLit (stx : Syntax) : MacroM Syntax := 89 | match stx.isLit? ``intTypeLit with 90 | | some str => mkNumLitFrom stx (str.drop 1) 91 | | none => Macro.throwErrorAt stx "ill-formed integer type literal" 92 | 93 | def expandIntTypeLitAsType (stx : Syntax) : MacroM Syntax := do 94 | mkCAppFrom stx ``integerType #[← expandIntTypeLitAsNatLit stx] 95 | 96 | def expandIntTypeLitAsRef (stx : Syntax) : MacroM Syntax := do 97 | mkCAppFrom stx ``IntegerTypeRef.get #[← expandIntTypeLitAsNatLit stx] 98 | 99 | scoped macro:max (priority := high) x:intTypeLit : term => expandIntTypeLitAsType x 100 | -------------------------------------------------------------------------------- /Papyrus/Script/Jit.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Script.SyntaxUtil 2 | import Papyrus.ExecutionEngineRef 3 | 4 | namespace Papyrus.Script 5 | 6 | /-- Run the `main` function of a module with the given arguments and environment. -/ 7 | def jitMain (mod : ModuleRef) (args : Array String := #[]) (env : Array String := #[]) 8 | : IO PUnit := do 9 | match (← mod.getFunction? "main") with 10 | | some fn => do 11 | let ee ← ExecutionEngineRef.createForModule mod 12 | let rc ← ee.runFunctionAsMain fn args env 13 | IO.println s!"Exited with code {rc}" 14 | | none => throw <| IO.userError "Module has no main function" 15 | 16 | macro kw:"#jit " mod:term:arg args?:optional(term:arg) env?:optional(term:arg) : command => do 17 | let args := args?.getD (← `(#[])); let env := env?.getD (← `(#[])) 18 | mkEvalAt kw <| ← `(LlvmM.run do jitMain (← $mod) $args $env) 19 | -------------------------------------------------------------------------------- /Papyrus/Script/Label.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Builders 3 | import Papyrus.Script.Do 4 | import Papyrus.Script.SyntaxUtil 5 | 6 | namespace Papyrus.Script 7 | 8 | open Lean Parser 9 | 10 | @[runParserAttributeHooks] 11 | def label := leading_parser 12 | ident >> ":" >> bbDoSeq 13 | 14 | def expandLabel : (stx : Syntax) → MacroM Syntax 15 | | `(label| $id:ident : $seq) => do 16 | let name := identAsStrLit id 17 | let elems ← expandBbDoSeq seq 18 | `(doElem| let $id:ident ← Builder.label $name (do {$[$elems:doElem]*})) 19 | | stx => Macro.throwErrorAt stx "ill-formed label" 20 | 21 | macro (name := bbDoLabel) x:label : bbDoElem => expandLabel x 22 | scoped macro (name := doLabel) "llvm " x:label : doElem => expandLabel x 23 | -------------------------------------------------------------------------------- /Papyrus/Script/Module.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Builders 3 | import Papyrus.Script.Do 4 | import Papyrus.Script.ParserUtil 5 | 6 | namespace Papyrus.Script 7 | open Builder Lean Parser Term 8 | 9 | @[runParserAttributeHooks] 10 | def llvmModDef := leading_parser 11 | Parser.ident >> " do " >> modDoSeq 12 | 13 | scoped syntax (name := doLlvmModDef) 14 | "llvm " &"module " llvmModDef : doElem 15 | 16 | @[macro doLlvmModDef] 17 | def expandDoLlvmModDef : Macro 18 | | `(doElem| llvm module $id:ident do $seq) => do 19 | let name := identAsStrLit id 20 | let modDoElems ← expandModDoSeq seq 21 | let doElems ← modDoElems.mapM expandMacros 22 | `(doElem| let $id:ident ← module (name := $name) do {$[$doElems:doElem]*}) 23 | | _ => Macro.throwUnsupported 24 | 25 | scoped syntax (name := cmdLlvmModDef) 26 | declModifiers "llvm " &"module " llvmModDef : command 27 | 28 | @[macro cmdLlvmModDef] 29 | def expandCmdLlvmModDef : Macro 30 | | `($mods:declModifiers llvm module $id:ident do $seq) => do 31 | let name := identAsStrLit id 32 | let modDoElems ← expandModDoSeq seq 33 | let doElems ← modDoElems.mapM expandMacros 34 | `($mods:declModifiers def $id:ident := module (name := $name) do {$[$doElems:doElem]*}) 35 | | _ => Macro.throwUnsupported 36 | -------------------------------------------------------------------------------- /Papyrus/Script/ParserUtil.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Script.SyntaxUtil 3 | 4 | open Lean Parser 5 | namespace Papyrus.Script 6 | 7 | @[runParserAttributeHooks] 8 | def negNumLit := leading_parser 9 | symbol "-" >> checkNoWsBefore >> numLit 10 | 11 | def expandNegNumLit : (stx : Syntax) → MacroM Syntax 12 | | `(negNumLit | -$n:numLit) => ``(-$n) 13 | | stx => Macro.throwErrorAt stx "ill-formed negative numeric literal" 14 | -------------------------------------------------------------------------------- /Papyrus/Script/SyntaxUtil.lean: -------------------------------------------------------------------------------- 1 | open Lean Syntax 2 | namespace Papyrus.Script 3 | 4 | def mkEvalAt (tk : Syntax) (stx : Syntax) : Syntax := 5 | mkNode `Lean.Parser.Command.eval #[mkAtomFrom tk "#eval ", stx] 6 | 7 | def identAsStrLit (id : Syntax) : Syntax := 8 | mkStrLit (info := SourceInfo.fromRef id) <| id.getId.toString (escape := false) 9 | 10 | def mkCAppFrom (src : Syntax) (fn : Name) (args : Array Syntax) : Syntax := 11 | mkApp (mkCIdentFrom src fn) args 12 | 13 | def mkNumLitFrom (src : Syntax) (val : String) := 14 | mkNumLit val (SourceInfo.fromRef src) 15 | -------------------------------------------------------------------------------- /Papyrus/Script/Type.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Script.ParserUtil 3 | import Papyrus.Script.AddressSpace 4 | import Papyrus.Script.IntegerType 5 | import Papyrus.IR.Type 6 | 7 | namespace Papyrus.Script 8 | 9 | open Lean Syntax Parser 10 | 11 | scoped postfix:max "*" => pointerType 12 | 13 | -------------------------------------------------------------------------------- 14 | -- # Type Category 15 | -------------------------------------------------------------------------------- 16 | 17 | declare_syntax_cat llvmType (behavior := symbol) 18 | def typeParser (rbp : Nat := 0) := categoryParser `llvmType rbp 19 | 20 | macro "type" "(" t:term ")" : llvmType => t 21 | macro (priority := low) t:ident : llvmType => t 22 | 23 | def expandType (stx : Syntax) : MacroM Syntax := 24 | expandMacros stx 25 | 26 | def expandTypeAsRef (stx : Syntax) : MacroM Syntax := do 27 | `(Type.getRef $(← expandType stx)) 28 | 29 | def expandTypeAsRefArrow (stx : Syntax) : MacroM Syntax := do 30 | `(← $(← expandTypeAsRef stx)) 31 | 32 | scoped macro "llvm " &"type " t:llvmType : term => expandType t 33 | 34 | -------------------------------------------------------------------------------- 35 | -- # Primitive Types 36 | -------------------------------------------------------------------------------- 37 | 38 | -- ## Floating Point Types 39 | 40 | macro t:"half" : llvmType => mkCIdentFrom t ``halfType 41 | macro t:"bfloat" : llvmType => mkCIdentFrom t ``bfloatType 42 | macro t:"float" : llvmType => mkCIdentFrom t ``floatType 43 | macro t:"double" : llvmType => mkCIdentFrom t ``doubleType 44 | macro t:"x86_fp80" : llvmType => mkCIdentFrom t ``x86FP80Type 45 | macro t:"fp128" : llvmType => mkCIdentFrom t ``fp128Type 46 | macro t:"ppc_fp128" : llvmType => mkCIdentFrom t ``ppcFP128Type 47 | 48 | -- ## Special Types 49 | 50 | macro t:"void" : llvmType => mkCIdentFrom t ``voidType 51 | macro t:"label" : llvmType => mkCIdentFrom t ``labelType 52 | macro t:"metadata" : llvmType => mkCIdentFrom t ``metadataType 53 | macro t:"x86_mmx" : llvmType => mkCIdentFrom t ``x86MMXType 54 | macro t:"x86_amx" : llvmType => mkCIdentFrom t ``x86AMXType 55 | macro t:"token" : llvmType => mkCIdentFrom t ``tokenType 56 | 57 | -------------------------------------------------------------------------------- 58 | -- # Derived Type Parsers 59 | -------------------------------------------------------------------------------- 60 | 61 | -- ## Integer Types 62 | 63 | macro t:intTypeLit : llvmType => expandIntTypeLitAsType t 64 | 65 | -- ## Function Types 66 | 67 | @[runParserAttributeHooks] 68 | def vararg := leading_parser "..." 69 | 70 | @[runParserAttributeHooks] 71 | def params := leading_parser 72 | "(" >> sepBy typeParser "," (allowTrailingSep := true) >> Parser.optional vararg >> ")" 73 | 74 | def expandParams (stx : Syntax) : MacroM (Array Syntax × Syntax) := do 75 | (← stx[1].getSepArgs.mapM expandType, (quote !stx[2].isNone)) 76 | 77 | def expandFunTypeLit (rty : Syntax) (params : Syntax) : MacroM Syntax := do 78 | let (ptys, vararg) ← expandParams params 79 | mkCAppFrom rty ``functionType #[← expandType rty, quote ptys, vararg] 80 | 81 | macro rt:llvmType ps:params : llvmType => expandFunTypeLit rt ps 82 | 83 | -- ## Pointer Types 84 | 85 | def expandPtrTypeLit (ty : Syntax) (addrspace? : Option Syntax) : MacroM Syntax := do 86 | mkCAppFrom ty ``pointerType #[← expandType ty, ← expandOptAddrspace addrspace?] 87 | 88 | macro t:llvmType a?:optional(addrspace) "*" : llvmType => expandPtrTypeLit t a? 89 | 90 | -- ## Struct Types 91 | 92 | @[runParserAttributeHooks] 93 | def packedStructTypeLit := leading_parser 94 | "<{" >> sepBy typeParser "," >> "}>" 95 | 96 | @[runParserAttributeHooks] 97 | def unpackedStructTypeLit := leading_parser 98 | "{" >> sepBy typeParser "," >> "}" 99 | 100 | @[runParserAttributeHooks] 101 | def structTypeLit := unpackedStructTypeLit <|> packedStructTypeLit 102 | 103 | def expandStructTypeLit : (stx : Syntax) → MacroM (Array Syntax × Bool) 104 | | `(unpackedStructTypeLit| { $[$ts:llvmType],* }) => do 105 | (← ts.mapM expandType, false) 106 | | `(packedStructTypeLit| $x) => do 107 | (← x[1].getSepArgs.mapM expandType, true) 108 | | stx => Macro.throwErrorAt stx "ill-formed struct llvmType literal" 109 | 110 | def expandLiteralStructTypeLit (stx : Syntax) : MacroM Syntax := do 111 | let (tys, packed) ← expandStructTypeLit stx 112 | mkCAppFrom stx ``literalStructType #[quote tys, quote packed] 113 | 114 | macro t:structTypeLit : llvmType => expandLiteralStructTypeLit t 115 | macro "%" id:ident : llvmType => mkCAppFrom id ``opaqueStructType #[identAsStrLit id] 116 | 117 | -- ## Array Types 118 | 119 | def xTk := 120 | nonReservedSymbol "x" <|> "×" 121 | 122 | @[runParserAttributeHooks] 123 | def arrayTypeLit := leading_parser 124 | "[" >> termParser maxPrec >> xTk >> typeParser >> "]" 125 | 126 | def expandArrayTypeLit : Macro 127 | | stx@`(arrayTypeLit| [$x x $t]) => do 128 | mkCAppFrom stx ``arrayType #[← expandType t, x] 129 | | stx => Macro.throwErrorAt stx "ill-formed array llvmType literal" 130 | 131 | macro t:arrayTypeLit : llvmType => expandArrayTypeLit t 132 | 133 | -- ## Vector Types 134 | 135 | def optVScale := 136 | Parser.optional (nonReservedSymbol "vscale" >> xTk) 137 | 138 | @[runParserAttributeHooks] 139 | def vectorTypeLit := leading_parser 140 | "<" >> optVScale >> termParser maxPrec >> xTk >> typeParser >> ">" 141 | 142 | def expandVectorTypeLit : (stx : Syntax) → MacroM Syntax 143 | | stx@`(vectorTypeLit| <$x x $t>) => do 144 | mkCAppFrom stx ``fixedVectorType #[← expandType t, x] 145 | | stx@`(vectorTypeLit| ) => do 146 | mkCAppFrom stx ``scalableVectorType #[← expandType t, x] 147 | | stx => Macro.throwErrorAt stx "ill-formed vector llvmType literal" 148 | 149 | macro t:vectorTypeLit : llvmType => expandVectorTypeLit t 150 | -------------------------------------------------------------------------------- /Papyrus/Script/Value.lean: -------------------------------------------------------------------------------- 1 | import Lean.Parser 2 | import Papyrus.Script.Type 3 | import Papyrus.Script.ParserUtil 4 | import Papyrus.Script.AddressSpace 5 | import Papyrus.IR.ConstantRefs 6 | import Papyrus.Builders 7 | 8 | namespace Papyrus.Script 9 | 10 | open Builder Lean Parser 11 | 12 | -- # Category 13 | 14 | declare_syntax_cat llvmValue (behavior := symbol) 15 | def valueParser (rbp : Nat := 0) := categoryParser `llvmValue rbp 16 | 17 | -- # Expansion 18 | 19 | def expandValueAsRef (stx : Syntax) : MacroM Syntax := 20 | expandMacros stx 21 | 22 | def expandValueAsRefArrow (stx : Syntax) : MacroM Syntax := do 23 | `(← $(← expandValueAsRef stx)) 24 | 25 | scoped macro "llvm " x:llvmValue : term => expandValueAsRef x 26 | 27 | -- # Special Macros 28 | 29 | macro "%" x:ident : llvmValue => x 30 | macro "value" "(" x:term ")" : llvmValue => x 31 | macro (priority := low) x:ident : llvmValue => x 32 | 33 | -------------------------------------------------------------------------------- 34 | -- # Constants 35 | -------------------------------------------------------------------------------- 36 | 37 | -- ## Category 38 | 39 | declare_syntax_cat llvmConst (behavior := symbol) 40 | def constParser (rbp : Nat := 0) := categoryParser `llvmConst rbp 41 | 42 | -- ## Expansion 43 | 44 | def expandConstantAsRef (stx : Syntax) : MacroM Syntax := 45 | expandMacros stx 46 | 47 | def expandConstantAsRefArrow (stx : Syntax) : MacroM Syntax := do 48 | `(← $(← expandConstantAsRef stx)) 49 | 50 | macro c:llvmConst : llvmValue => expandConstantAsRef c 51 | 52 | -- ## Constant Global String Pointers 53 | 54 | macro s:strLit addrspace?:optional(addrspace) "*" : llvmConst => do 55 | ``(stringPtr $s $(← expandOptAddrspace addrspace?)) 56 | 57 | -- ## Integer Constants 58 | 59 | @[runParserAttributeHooks] 60 | def constIntLit := leading_parser 61 | intTypeLit >> (numLit <|> negNumLit) 62 | 63 | def expandConstIntLitAsRef : Macro 64 | | `(constIntLit| $t:intTypeLit $n:numLit) => do 65 | ``(ConstantIntRef.ofNat $(← expandIntTypeLitAsNatLit t) $n) 66 | | `(constIntLit| $t:intTypeLit $n:negNumLit) => do 67 | ``(ConstantIntRef.ofInt $(← expandIntTypeLitAsNatLit t) $(← expandNegNumLit n)) 68 | | stx => Macro.throwErrorAt stx "ill-formed constant int literal" 69 | 70 | macro x:constIntLit : llvmConst => expandConstIntLitAsRef x 71 | 72 | -- ## Boolean Constants 73 | 74 | macro x:"true" : llvmConst => mkCIdentFrom x ``ConstantIntRef.getTrue 75 | macro x:"false" : llvmConst => mkCIdentFrom x ``ConstantIntRef.getFalse 76 | 77 | -- ## Constant Expressions 78 | 79 | @[runParserAttributeHooks] 80 | def constPtrToInt := leading_parser 81 | nonReservedSymbol "ptrtoint " true >> 82 | "(" >> constParser >> nonReservedSymbol " to " true >> typeParser >> ")" 83 | 84 | def expandConstPtrToIntAsRef : Macro 85 | | `(constPtrToInt| ptrtoint ($c:llvmConst to $ty:llvmType)) => do 86 | let ty ← expandTypeAsRefArrow ty 87 | let c ← expandConstantAsRefArrow c 88 | ``(ConstantExprRef.getPtrToInt $c $ty) 89 | | stx => Macro.throwErrorAt stx "ill-formed constant ptrtoint expression" 90 | 91 | macro x:constPtrToInt : llvmConst => expandConstPtrToIntAsRef x 92 | 93 | @[runParserAttributeHooks] 94 | def constIntToPtr := leading_parser 95 | nonReservedSymbol "inttoptr " true >> 96 | "(" >> constParser >> nonReservedSymbol " to " true >> typeParser >> ")" 97 | 98 | def expandConstIntToPtrAsRef : Macro 99 | | `(constIntToPtr| inttoptr ($c:llvmConst to $ty:llvmType)) => do 100 | let ty ← expandTypeAsRefArrow ty 101 | let c ← expandConstantAsRefArrow c 102 | ``(ConstantExprRef.getIntToPtr $c $ty) 103 | | stx => Macro.throwErrorAt stx "ill-formed constant inttoptr expression" 104 | 105 | macro x:constIntToPtr : llvmConst => expandConstIntToPtrAsRef x 106 | -------------------------------------------------------------------------------- /Papyrus/Script/Verify.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Script.SyntaxUtil 2 | import Papyrus.IR.FunctionRef 3 | import Papyrus.IR.ModuleRef 4 | 5 | namespace Papyrus.Script 6 | 7 | -- # Verify Class 8 | 9 | class VerifyRef (α : Type u) where 10 | verifyRef : α → IO PUnit 11 | 12 | export VerifyRef (verifyRef) 13 | 14 | class Verify (α : Type u) where 15 | verify : α → LlvmM PUnit 16 | 17 | export Verify (verify) 18 | 19 | instance [VerifyRef α] : Verify α := ⟨liftM ∘ verifyRef⟩ 20 | 21 | instance : VerifyRef FunctionRef := ⟨FunctionRef.verify⟩ 22 | instance : VerifyRef ModuleRef := ⟨fun m => discard <| ModuleRef.verify m⟩ 23 | 24 | -- # Verify Command 25 | 26 | macro kw:"#verify " x:term : command => do 27 | mkEvalAt kw <| ← ``(LlvmM.run ($x >>= verify)) 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Papyrus 2 | 3 | A **work-in-progress** LLVM interface for Lean 4. 4 | 5 | Inspired by [`lean-llvm`](https://github.com/GaloisInc/lean-llvm), which is Copyright (c) 2019 Galois, Inc. and released under the Apache 2.0 license, which can be found here: http://www.apache.org/licenses/LICENSE-2.0. 6 | 7 | More documentation will come as development progresses. In fact, the source files are pretty well documented already (if I do say so myself), so feel free to take a look at them. 8 | 9 | ## Demo 10 | 11 | In addition to Lean/C bindings to LLVM, Papyrus also provides a DSL for writing and interacting with LLVM IR. It is still very much a work-in-progress, but here is a little sample of what it can do at the moment: 12 | 13 | ```lean 14 | import Papyrus 15 | 16 | open Papyrus Script 17 | 18 | llvm module lean_hello do 19 | declare %lean_object* @lean_mk_string(i8*) 20 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object*, %lean_object*) 21 | define i32 @main() do 22 | %hello = call @lean_mk_string("Hello World!"*) 23 | call @l_IO_println___at_Lean_instEval___spec__1(%hello, inttoptr (i32 1 to %lean_object*)) 24 | ret i32 0 25 | 26 | #dump lean_hello -- Prints the module's IR 27 | #verify lean_hello -- Checks that the IR is valid 28 | #jit lean_hello -- JITs the `main` function 29 | 30 | /- #jit: 31 | Hello World 32 | Exited with code 0 33 | -/ 34 | ``` 35 | 36 | **Note:** To run this code, you will need to provide the `PapyrusPlugin` shared library (located at `papyrus/plugin/build` after a build) to Lean as a plugin (e.g., by providing `--plugin papyrus/plugin/build/PapyrusPlugin` as an argument). 37 | -------------------------------------------------------------------------------- /c/Makefile: -------------------------------------------------------------------------------- 1 | # Detect Lean 2 | 3 | ifndef LEAN_HOME 4 | LEAN ?= lean 5 | LEAN_HOME := $(shell $(LEAN) --print-prefix) 6 | endif 7 | 8 | LEAN_INCLUDE := $(LEAN_HOME)/include 9 | 10 | # Detect LLVM 11 | 12 | LLVM_CONFIG ?= llvm-config 13 | LLVM_CXX_FLAGS := $(shell $(LLVM_CONFIG) --cxxflags) 14 | 15 | # Detect OS 16 | 17 | OS_NAME := ${OS} 18 | ifneq ($(OS_NAME),Windows_NT) 19 | OS_NAME := $(shell uname -s) 20 | endif 21 | 22 | # Config 23 | 24 | MKPATH := mkdir -p 25 | RMPATH := rm -rf 26 | 27 | AR := ar 28 | CXX := c++ 29 | 30 | EXTRA_CXX_FLAGS := -O3 -DNDEBUG 31 | ifneq ($(OS_NAME),Windows_NT) 32 | EXTRA_CXX_FLAGS += -fPIC 33 | endif 34 | 35 | SRC_DIR := src 36 | HDR_DIR := include 37 | OUT_DIR := build/$(OS_NAME) 38 | 39 | HDRS := \ 40 | papyrus.h\ 41 | papyrus_ffi.h 42 | 43 | SRCS := \ 44 | adt.cpp\ 45 | init.cpp\ 46 | memory_buffer.cpp\ 47 | context.cpp\ 48 | module.cpp\ 49 | bitcode.cpp\ 50 | type.cpp\ 51 | value.cpp\ 52 | constant.cpp\ 53 | instruction.cpp\ 54 | basic_block.cpp\ 55 | global.cpp\ 56 | global_variable.cpp\ 57 | function.cpp\ 58 | generic_value.cpp\ 59 | execution_engine.cpp\ 60 | 61 | LIB_NAME := PapyrusC 62 | LIB := lib${LIB_NAME}.a 63 | 64 | OBJ_FILES := $(addprefix $(OUT_DIR)/,$(SRCS:.cpp=.o)) 65 | HDR_FILES := $(addprefix $(HDR_DIR)/,$(HDRS)) 66 | 67 | # Build Rules 68 | 69 | all: lib 70 | 71 | lib: $(OUT_DIR)/$(LIB) 72 | 73 | $(OUT_DIR): 74 | $(MKPATH) $@ 75 | 76 | $(OUT_DIR)/$(LIB) : $(OBJ_FILES) | $(OUT_DIR) 77 | ${AR} rcs $@ $^ 78 | 79 | $(OUT_DIR)/%.o : $(SRC_DIR)/%.cpp $(HDR_FILES) | $(OUT_DIR) 80 | $(CXX) -o $@ -c $< -I$(HDR_DIR) -I$(LEAN_INCLUDE) $(LLVM_CXX_FLAGS) $(EXTRA_CXX_FLAGS) 81 | 82 | clean: 83 | $(RMPATH) $(OUT_DIR) 84 | -------------------------------------------------------------------------------- /c/include/papyrus.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | // Forward declarations 6 | namespace llvm { 7 | class APInt; 8 | class StringRef; 9 | class MemoryBuffer; 10 | class LLVMContext; 11 | class Module; 12 | class Type; 13 | class IntegerType; 14 | class FunctionType; 15 | class Value; 16 | class Constant; 17 | class Instruction; 18 | class BasicBlock; 19 | class GlobalVariable; 20 | class Function; 21 | class GenericValue; 22 | } 23 | 24 | namespace papyrus { 25 | 26 | //------------------------------------------------------------------------------ 27 | // Lean Helpers 28 | //------------------------------------------------------------------------------ 29 | 30 | #define PAPYRUS_DEFAULT_ARRAY_CAPCITY 8 31 | 32 | std::string stdOfString(b_lean_obj_arg str); 33 | lean_obj_res mkStringFromStd(const std::string& str); 34 | 35 | // Option.some 36 | static inline lean_obj_res mkSome(lean_obj_arg val) { 37 | lean_obj_res obj = lean_alloc_ctor(1, 1, 0); 38 | lean_ctor_set(obj, 0, val); 39 | return obj; 40 | } 41 | 42 | static inline lean_obj_res mkStringError(const char* msg) { 43 | return lean_io_result_mk_error(lean_mk_io_user_error(lean_mk_string(msg))); 44 | } 45 | 46 | static inline lean_obj_res mkStdStringError(const std::string& msg) { 47 | return lean_io_result_mk_error(lean_mk_io_user_error(mkStringFromStd(msg))); 48 | } 49 | 50 | //------------------------------------------------------------------------------ 51 | // LLVM Interface 52 | //------------------------------------------------------------------------------ 53 | 54 | lean_object* mkNatFromAP(const llvm::APInt& ap); 55 | lean_object* mkIntFromAP(const llvm::APInt& ap); 56 | llvm::APInt apOfNat(unsigned numBits, b_lean_obj_arg natObj); 57 | llvm::APInt apOfInt(unsigned numBits, b_lean_obj_arg intObj); 58 | 59 | lean_obj_res mkStringFromRef(const llvm::StringRef& str); 60 | llvm::StringRef refOfString(b_lean_obj_arg str); 61 | llvm::StringRef refOfStringWithNull(b_lean_obj_arg str); 62 | 63 | llvm::MemoryBuffer* toMemoryBuffer(b_lean_obj_arg ref); 64 | 65 | lean_obj_res mkContextRef(llvm::LLVMContext* ctx); 66 | llvm::LLVMContext* toLLVMContext(b_lean_obj_res ref); 67 | 68 | lean_obj_res mkModuleRef(b_lean_obj_arg ctx, llvm::Module* ptr); 69 | llvm::Module* toModule(b_lean_obj_arg ref); 70 | 71 | lean_obj_res mkTypeRef(b_lean_obj_arg ctxRef, llvm::Type* type); 72 | llvm::Type* toType(b_lean_obj_arg ref); 73 | llvm::IntegerType* toIntegerType(b_lean_obj_arg ref); 74 | llvm::FunctionType* toFunctionType(b_lean_obj_arg ref); 75 | 76 | lean_obj_res mkValueRef(lean_obj_arg ctxRef, llvm::Value* value); 77 | lean_obj_res getValueContext(b_lean_obj_arg ref); 78 | llvm::Value* toValue(b_lean_obj_arg ref); 79 | 80 | lean_obj_res mkConstantRef(lean_obj_arg ctxRef, llvm::Constant* ptr); 81 | llvm::Constant* toConstant(b_lean_obj_arg ref); 82 | 83 | llvm::Instruction* toInstruction(b_lean_obj_arg ref); 84 | llvm::BasicBlock* toBasicBlock(b_lean_obj_arg ref); 85 | llvm::GlobalVariable* toGlobalVariable(b_lean_obj_arg ref); 86 | llvm::Function* toFunction(b_lean_obj_arg ref); 87 | 88 | lean_obj_res mkGenericValueRef(llvm::GenericValue* val); 89 | llvm::GenericValue* toGenericValue(b_lean_obj_arg ref); 90 | 91 | // Covert a Lean Array of references to an LLVM ArrayRef of objects. 92 | // Defined as a macro because it needs to dynamically allocate to the user's stack. 93 | #define LEAN_ARRAY_TO_REF(ELEM_TYPE, CONVERTER, OBJ, REF) \ 94 | auto OBJ##_arr = lean_to_array(OBJ); \ 95 | auto OBJ##_len = OBJ##_arr->m_size; \ 96 | ELEM_TYPE REF##_data[OBJ##_len]; \ 97 | for (auto i = 0; i < OBJ##_len; i++) { \ 98 | REF##_data[i] = CONVERTER(OBJ##_arr->m_data[i]); \ 99 | } \ 100 | ArrayRef REF(REF##_data, OBJ##_len) 101 | 102 | } // end namespace papyrus 103 | -------------------------------------------------------------------------------- /c/include/papyrus_ffi.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | 4 | namespace papyrus { 5 | 6 | //------------------------------------------------------------------------------ 7 | // External object callbacks 8 | //------------------------------------------------------------------------------ 9 | 10 | // A no-op finalize callback for external classes. 11 | static void nopFinalize(void* p) { 12 | return; 13 | } 14 | 15 | // A finalize callback for external classes that 16 | // casts the pointer to the template type and then invokes delete. 17 | template 18 | void deleteFinalize(void* p) { 19 | delete static_cast(p); 20 | } 21 | 22 | // A no-op foreach callback for external classes. 23 | static void nopForeach(void* /* p */, b_lean_obj_arg /* a */) { 24 | return; 25 | } 26 | 27 | //------------------------------------------------------------------------------ 28 | // Unmanaged (Loose) Pointers 29 | //------------------------------------------------------------------------------ 30 | 31 | // Lean external object class for unmanaged pointers. 32 | template static lean_external_class* getLoosePtrClass() { 33 | // Use static to make this thread safe by static initialization rules. 34 | static lean_external_class* k = 35 | lean_register_external_class(&nopFinalize, &nopForeach); 36 | return k; 37 | } 38 | 39 | // Wrap a unmanaged pointer in a Lean object. 40 | template lean_object* mkLoosePtr(T* ptr) { 41 | return lean_alloc_external(getLoosePtrClass(), ptr); 42 | } 43 | 44 | // Get the pointer wrapped in an LoosePtr. 45 | template T* fromLoosePtr(b_lean_obj_arg ctxRef) { 46 | lean_external_object* external = lean_to_external(ctxRef); 47 | assert(external->m_class == getLoosePtrClass()); 48 | return static_cast(external->m_data); 49 | } 50 | 51 | //------------------------------------------------------------------------------ 52 | // Lean-Owned Pointers 53 | //------------------------------------------------------------------------------ 54 | 55 | // Lean external object class template for Lean owned pointers. 56 | template static lean_external_class* getOwnedPtrClass() { 57 | // Use static to make this thread safe by static initialization rules. 58 | static lean_external_class* k = 59 | lean_register_external_class(&deleteFinalize, &nopForeach); 60 | return k; 61 | } 62 | 63 | // Wrap an pointer in a Lean object, transfering ownership to it. 64 | template lean_obj_res mkOwnedPtr(T* ptr) { 65 | return lean_alloc_external(getOwnedPtrClass(), ptr); 66 | } 67 | 68 | // Get the Lean-owned pointer wrapped in an OwnedPtr. 69 | template T* fromOwnedPtr(b_lean_obj_arg obj) { 70 | lean_external_object* external = lean_to_external(obj); 71 | assert(external->m_class == getOwnedPtrClass()); 72 | return static_cast(external->m_data); 73 | } 74 | 75 | //------------------------------------------------------------------------------ 76 | // Linked Pointers 77 | //------------------------------------------------------------------------------ 78 | 79 | // Borrow the object linked to the given linked pointer object. 80 | static inline b_lean_obj_res borrowLink(b_lean_obj_arg linkedPtrObj) { 81 | return lean_ctor_get(linkedPtrObj, 0); 82 | } 83 | 84 | // Get the object linked to the given linked pointer object and increment its RC. 85 | static inline lean_obj_res copyLink(b_lean_obj_arg linkedPtrObj) { 86 | auto link = lean_ctor_get(linkedPtrObj, 0); 87 | lean_inc_ref(link); 88 | return link; 89 | } 90 | 91 | // Wrap a pointer in a linked pointer object, transfering ownership to of it to Lean. 92 | template lean_obj_res mkLinkedOwnedPtr(lean_obj_arg link, T* ptr) { 93 | lean_object* obj = lean_alloc_ctor(0, 2, 0); 94 | lean_ctor_set(obj, 0, link); 95 | lean_ctor_set(obj, 1, mkOwnedPtr(ptr)); 96 | return obj; 97 | } 98 | 99 | // Get the Lean-owned pointer wrapped in an object. 100 | template T* fromLinkedOwnedPtr(b_lean_obj_arg obj) { 101 | return fromOwnedPtr(lean_ctor_get(obj, 1)); 102 | } 103 | 104 | // Wrap a loose pointer in a Lean LinkedPtr. 105 | template lean_obj_res mkLinkedLoosePtr(lean_obj_arg link, T* ptr) { 106 | lean_object* obj = lean_alloc_ctor(0, 2, 0); 107 | lean_ctor_set(obj, 0, link); 108 | lean_ctor_set(obj, 1, mkLoosePtr(ptr)); 109 | return obj; 110 | } 111 | 112 | // Get the loose pointer wrapped in linked pointer object. 113 | template T* fromLinkedLoosePtr(b_lean_obj_arg obj) { 114 | return fromLoosePtr(lean_ctor_get(obj, 1)); 115 | } 116 | 117 | } // end namespace papyrus 118 | -------------------------------------------------------------------------------- /c/src/adt.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | // Forward declarations 10 | 11 | namespace papyrus { 12 | 13 | // Makes a Lean `String` from a non-null terminated string of the given size. 14 | lean_obj_res mkStringFromSized(const char* str, size_t size) { 15 | size_t real_size = size + 1; 16 | size_t len = lean_utf8_n_strlen(str, size); 17 | lean_object* obj = lean_alloc_string(real_size, real_size, len); 18 | auto lean_data = lean_to_string(obj)->m_data; 19 | memcpy(lean_data, str, size); 20 | lean_data[size] = 0; 21 | return obj; 22 | } 23 | 24 | lean_obj_res mkStringFromStd(const std::string& str) { 25 | return mkStringFromSized(str.data(), str.size()); 26 | } 27 | 28 | std::string stdOfString(b_lean_obj_arg str) { 29 | auto strObj = lean_to_string(str); 30 | assert(strObj->m_size > 0); 31 | return std::string(strObj->m_data, strObj->m_size - 1); 32 | } 33 | 34 | lean_obj_res mkStringFromRef(const llvm::StringRef& str) { 35 | return mkStringFromSized(str.data(), str.size()); 36 | } 37 | 38 | llvm::StringRef refOfString(b_lean_obj_arg str) { 39 | auto strObj = lean_to_string(str); 40 | return llvm::StringRef(strObj->m_data, strObj->m_size - 1); 41 | } 42 | 43 | llvm::StringRef refOfStringWithNull(b_lean_obj_arg str) { 44 | auto strObj = lean_to_string(str); 45 | return llvm::StringRef(strObj->m_data, strObj->m_size); 46 | } 47 | 48 | #define LEAN_SMALL_NAT_BITS (CHAR_BIT*sizeof(size_t)-1) 49 | #define LEAN_SMALL_INT_BITS (sizeof(void*) == 8 ? (CHAR_BIT*sizeof(int)-1) : 30) 50 | 51 | lean_object* mkNatFromAP(const llvm::APInt& ap) { 52 | if (LEAN_LIKELY(ap.getActiveBits() <= LEAN_SMALL_NAT_BITS)) { 53 | return lean_box(ap.getZExtValue()); 54 | } else { 55 | mpz_t val; 56 | mpz_init(val); 57 | mpz_import(val, ap.getNumWords(), -1, 58 | llvm::APInt::APINT_WORD_SIZE, 0, 0, ap.getRawData()); 59 | return lean_alloc_mpz(val); 60 | } 61 | } 62 | 63 | lean_object* mkIntFromAP(const llvm::APInt& ap) { 64 | if (LEAN_LIKELY(ap.getMinSignedBits() <= LEAN_SMALL_INT_BITS)) { 65 | return lean_box((unsigned)((int)ap.getSExtValue())); 66 | } else { 67 | mpz_t val; 68 | mpz_init(val); 69 | auto apAbs = ap.abs(); 70 | mpz_import(val, apAbs.getNumWords(), -1, 71 | llvm::APInt::APINT_WORD_SIZE, 0, 0, apAbs.getRawData()); 72 | if (ap.isNegative()) mpz_neg(val, val); 73 | return lean_alloc_mpz(val); 74 | } 75 | } 76 | 77 | llvm::APInt apNatOfMpz(unsigned numBits, const mpz_t& val) { 78 | auto realNumBits = mpz_sizeinbase(val, 2); 79 | auto bitsPerWord = llvm::APInt::APINT_BITS_PER_WORD; 80 | size_t numWords = (realNumBits + (bitsPerWord - 1)) / bitsPerWord; 81 | llvm::APInt::WordType words[numWords]; 82 | mpz_export(&words, nullptr, -1, llvm::APInt::APINT_WORD_SIZE, 0, 0, val); 83 | llvm::ArrayRef wordsRef(words, numWords); 84 | return llvm::APInt(numBits, wordsRef); 85 | } 86 | 87 | llvm::APInt apOfNat(unsigned numBits, b_lean_obj_arg obj) { 88 | if (lean_is_scalar(obj)) { 89 | return llvm::APInt(numBits, lean_unbox(obj), false); 90 | } else { 91 | mpz_t val; 92 | mpz_init(val); 93 | assert(lean_is_mpz(obj)); 94 | lean_extract_mpz_value(obj, val); 95 | return apNatOfMpz(numBits, val); 96 | } 97 | } 98 | 99 | llvm::APInt apOfInt(unsigned numBits, b_lean_obj_arg obj) { 100 | if (lean_is_scalar(obj)) { 101 | return llvm::APInt(numBits, lean_scalar_to_int64(obj), true); 102 | } else { 103 | mpz_t val; 104 | mpz_init(val); 105 | assert(lean_is_mpz(obj)); 106 | lean_extract_mpz_value(obj, val); 107 | llvm::APInt apNat = apNatOfMpz(numBits, val); 108 | return mpz_sgn(val) < 0 ? -apNat : apNat; 109 | } 110 | } 111 | 112 | } // end namespace papyrus 113 | -------------------------------------------------------------------------------- /c/src/basic_block.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | // Get the LLVM BasicBlock pointer wrapped in an object. 12 | llvm::BasicBlock* toBasicBlock(lean_object* bbRef) { 13 | return llvm::cast(toValue(bbRef)); 14 | } 15 | 16 | // Get a reference to a newly created basic block. 17 | extern "C" lean_obj_res papyrus_basic_block_create 18 | (b_lean_obj_arg nameObj, lean_obj_arg ctxRef, lean_obj_arg /* w */) 19 | { 20 | auto bb = BasicBlock::Create(*toLLVMContext(ctxRef), refOfString(nameObj)); 21 | return lean_io_result_mk_ok(mkValueRef(ctxRef, bb)); 22 | } 23 | 24 | // Get an array of references to the instructions of the given basic block. 25 | extern "C" lean_obj_res papyrus_basic_block_get_instructions 26 | (b_lean_obj_arg bbRef, lean_obj_arg /* w */) 27 | { 28 | auto link = borrowLink(bbRef); 29 | auto& is = toBasicBlock(bbRef)->getInstList(); 30 | lean_object* arr = lean_alloc_array(0, PAPYRUS_DEFAULT_ARRAY_CAPCITY); 31 | for (llvm::Instruction& i : is) { 32 | lean_inc_ref(link); 33 | arr = lean_array_push(arr, mkValueRef(link, &i)); 34 | } 35 | return lean_io_result_mk_ok(arr); 36 | } 37 | 38 | // Add the given instruction to the end of the given basic block. 39 | extern "C" lean_obj_res papyrus_basic_block_append_instruction 40 | (b_lean_obj_arg instRef, b_lean_obj_arg bbRef, lean_obj_arg /* w */) 41 | { 42 | toBasicBlock(bbRef)->getInstList().push_back(toInstruction(instRef)); 43 | return lean_io_result_mk_ok(lean_box(0)); 44 | } 45 | 46 | } // end namespace papyrus 47 | -------------------------------------------------------------------------------- /c/src/bitcode.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | extern "C" lean_obj_res papyrus_module_write_bitcode_to_file 12 | (b_lean_obj_res fnameObj, b_lean_obj_res modObj, uint8_t perserveOrder, 13 | lean_obj_arg /* w */) 14 | { 15 | std::error_code ec; 16 | raw_fd_ostream out(refOfString(fnameObj), ec); 17 | if (ec) return lean_decode_io_error(ec.value(), fnameObj); 18 | llvm::WriteBitcodeToFile(*toModule(modObj), out, perserveOrder); 19 | return lean_io_result_mk_ok(lean_box(0)); 20 | } 21 | 22 | extern "C" lean_obj_res papyrus_module_parse_bitcode_from_buffer 23 | (b_lean_obj_res bufObj, lean_obj_arg ctxObj, lean_obj_arg /* w */) 24 | { 25 | auto ctx = toLLVMContext(ctxObj); 26 | MemoryBufferRef buf = toMemoryBuffer(bufObj)->getMemBufferRef(); 27 | Expected> moduleOrErr = llvm::parseBitcodeFile(buf, *ctx); 28 | if (!moduleOrErr) { 29 | lean_dec_ref(ctxObj); 30 | std::string errMsg = "failed to parse bitcode file"; 31 | handleAllErrors(std::move(moduleOrErr.takeError()), [&](llvm::ErrorInfoBase &eib) { 32 | errMsg = "failed to parse bitcode file:" + eib.message(); 33 | }); 34 | return mkStdStringError(errMsg); 35 | } 36 | return lean_io_result_mk_ok(mkModuleRef(ctxObj, moduleOrErr.get().release())); 37 | } 38 | 39 | } // end namespace lean_llvm 40 | -------------------------------------------------------------------------------- /c/src/context.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | // Wrap an LLVMContext in a Lean object. 12 | lean_object* mkContextRef(LLVMContext* ctx) { 13 | return mkOwnedPtr(ctx); 14 | } 15 | 16 | // Get the LLVMContext wrapped in an object. 17 | LLVMContext* toLLVMContext(lean_object* ref) { 18 | return fromOwnedPtr(ref); 19 | } 20 | 21 | // Create a new Lean LLVM Context object. 22 | extern "C" lean_obj_res papyrus_context_new(lean_obj_arg /* w */) { 23 | return lean_io_result_mk_ok(mkContextRef(new LLVMContext())); 24 | } 25 | 26 | } // end namespace papyrus 27 | -------------------------------------------------------------------------------- /c/src/execution_engine.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | using namespace llvm; 9 | 10 | namespace papyrus { 11 | 12 | struct EEExternal { 13 | 14 | // The execution engine handle. 15 | ExecutionEngine* ee; 16 | 17 | // The modules controlled by the execution engine. 18 | SmallVector modules; 19 | 20 | // The error message owned by the execution engine. 21 | std::string* errMsg; 22 | 23 | EEExternal(ExecutionEngine* ee, std::string* errMsg) 24 | : ee(ee), errMsg(errMsg) {} 25 | 26 | EEExternal(const EEExternal&) = delete; 27 | 28 | ~EEExternal() { 29 | // remove all the modules from the execution engine so they don't get deleted 30 | for (auto it = modules.begin(), end = modules.end(); it != end; ++it) { 31 | ee->removeModule(*it); 32 | } 33 | delete ee; 34 | delete errMsg; 35 | } 36 | }; 37 | 38 | // Lean object class for an LLVM ExecutionEngine. 39 | static lean_external_class* getExecutionEngineClass() { 40 | // Use static to make this thread safe by static initialization rules. 41 | static lean_external_class* c = 42 | lean_register_external_class(&deleteFinalize, &nopForeach); 43 | return c; 44 | } 45 | 46 | // Wrap a ExecutionEngine in a Lean object. 47 | lean_object* mkExecutionEngineRef(EEExternal* ee) { 48 | return lean_alloc_external(getExecutionEngineClass(), ee); 49 | } 50 | 51 | // Get the ExecutionEngine external wrapped in an object. 52 | EEExternal* toEEExternal(lean_object* eeRef) { 53 | auto external = lean_to_external(eeRef); 54 | assert(external->m_class == getExecutionEngineClass()); 55 | return static_cast(external->m_data); 56 | } 57 | 58 | // Get the ExecutionEngine wrapped in an object. 59 | ExecutionEngine* toExecutionEngine(lean_object* eeRef) { 60 | return toEEExternal(eeRef)->ee; 61 | } 62 | 63 | // Unpack the Lean representation of an engine kind into the LLVM one. 64 | EngineKind::Kind unpackEngineKnd(uint8_t kind) { 65 | return kind == 0 ? EngineKind::Either : static_cast(kind); 66 | } 67 | 68 | //extern "C" lean_object* mk_io_user_error(lean_object* str); 69 | 70 | // Create a new execution engine for the given module. 71 | extern "C" lean_obj_res papyrus_execution_engine_create_for_module 72 | (b_lean_obj_res modObj, uint8_t kindObj, b_lean_obj_res marchStr, b_lean_obj_res mcpuStr, 73 | b_lean_obj_res mattrsObj, uint8_t optLevel, uint8_t verifyModules, lean_obj_arg /* w */) 74 | { 75 | // Create an engine builder 76 | EngineBuilder builder(std::unique_ptr(toModule(modObj))); 77 | // Configure the builder 78 | auto errMsg = new std::string(); 79 | auto kind = unpackEngineKnd(kindObj); 80 | builder.setEngineKind(kind); 81 | builder.setErrorStr(errMsg); 82 | builder.setOptLevel(static_cast(optLevel)); 83 | builder.setVerifyModules(verifyModules); 84 | builder.setMArch(refOfString(marchStr)); 85 | builder.setMCPU(refOfString(mcpuStr)); 86 | LEAN_ARRAY_TO_REF(std::string, stdOfString, mattrsObj, mattrs); 87 | builder.setMAttrs(mattrs); 88 | // Try to construct the execution engine 89 | if (ExecutionEngine* ee = builder.create()) { 90 | auto eee = new EEExternal(ee, errMsg); 91 | eee->modules.push_back(toModule(modObj)); 92 | return lean_io_result_mk_ok(mkExecutionEngineRef(eee)); 93 | } else { 94 | // Steal back the module pointer before it gets deleted 95 | reinterpret_cast&>(builder).release(); 96 | auto res = mkStdStringError(*errMsg); 97 | delete errMsg; 98 | return res; 99 | } 100 | return lean_io_result_mk_ok(lean_box(0)); 101 | } 102 | 103 | // Run the given function with given arguments 104 | // in the given execution engine and return the result. 105 | extern "C" lean_obj_res papyrus_execution_engine_run_function 106 | (b_lean_obj_res funRef, b_lean_obj_res eeRef, b_lean_obj_res argsObj, lean_obj_arg /* w */) 107 | { 108 | LEAN_ARRAY_TO_REF(GenericValue, *toGenericValue, argsObj, args); 109 | auto ret = toExecutionEngine(eeRef)->runFunction(toFunction(funRef), args); 110 | return lean_io_result_mk_ok(mkGenericValueRef(new GenericValue(ret))); 111 | } 112 | 113 | class ArgvArray { 114 | public: 115 | std::unique_ptr argv; 116 | std::vector> ptrs; 117 | // Turn a Lean array of string objects 118 | // into a nice argv style null terminated array of pointers. 119 | void* set(PointerType* pInt8Ty, ExecutionEngine *ee, const lean_array_object* args); 120 | }; 121 | 122 | void* ArgvArray::set 123 | (PointerType* pInt8Ty, ExecutionEngine *ee, const lean_array_object* args) 124 | { 125 | auto argc = args->m_size; 126 | unsigned ptrSize = ee->getDataLayout().getPointerSize(); 127 | argv = std::make_unique((argc+1)*ptrSize); 128 | ptrs.reserve(argc); 129 | 130 | auto data = args->m_data; 131 | for (unsigned i = 0; i != argc; ++i) { 132 | auto str = lean_to_string(data[i]); 133 | // copy the string so that the user may edit it 134 | auto ptr = std::make_unique(str->m_size); 135 | std::copy(str->m_data, str->m_data + str->m_size, ptr.get()); 136 | // endian safe: argv[i] = ptr.get() 137 | ee->StoreValueToMemory(PTOGV(ptr.get()), 138 | (GenericValue*)(&argv[i*ptrSize]), pInt8Ty); 139 | // pointer will be deallocated when the `ArgvArray` is 140 | ptrs.push_back(std::move(ptr)); 141 | } 142 | // null terminate the array 143 | ee->StoreValueToMemory(PTOGV(nullptr), 144 | (GenericValue*)(&argv[argc*ptrSize]), pInt8Ty); 145 | 146 | return argv.get(); 147 | } 148 | 149 | /* 150 | A helper function to wrap the behavior of `runFunction` 151 | to handle common task of starting up a `main` function with the usual 152 | `argc`, `argv`, and `envp` parameters. 153 | 154 | Instead of using LLVM's `runFunctionAsMain` directly, 155 | we adapt its code to Lean's data structures. 156 | */ 157 | extern "C" lean_obj_res papyrus_execution_engine_run_function_as_main 158 | (b_lean_obj_res funRef, b_lean_obj_res eeRef, b_lean_obj_res argsObj, b_lean_obj_res envObj, lean_obj_arg /* w */) 159 | { 160 | auto fn = toFunction(funRef); 161 | auto fnTy = fn->getFunctionType(); 162 | auto& ctx = fnTy->getContext(); 163 | auto fnArgc = fnTy->getNumParams(); 164 | auto pInt8Ty = Type::getInt8PtrTy(ctx); 165 | auto ppInt8Ty = pInt8Ty->getPointerTo(); 166 | 167 | if (fnArgc > 3) 168 | return mkStdStringError("Invalid number of arguments of main() supplied"); 169 | if (fnArgc >= 3 && fnTy->getParamType(2) != ppInt8Ty) 170 | return mkStdStringError("Invalid type for third argument of main() supplied"); 171 | if (fnArgc >= 2 && fnTy->getParamType(1) != ppInt8Ty) 172 | return mkStdStringError("Invalid type for second argument of main() supplied"); 173 | if (fnArgc >= 1 && !fnTy->getParamType(0)->isIntegerTy(32)) 174 | return mkStdStringError("Invalid type for first argument of main() supplied"); 175 | if (!fnTy->getReturnType()->isIntegerTy() && !fnTy->getReturnType()->isVoidTy()) 176 | return mkStdStringError("Invalid return type of main() supplied"); 177 | 178 | ArgvArray argv, env; 179 | GenericValue fnArgs[fnArgc]; 180 | auto ee = toExecutionEngine(eeRef); 181 | if (fnArgc > 0) { 182 | auto argsArr = lean_to_array(argsObj); 183 | fnArgs[0].IntVal = APInt(32, argsArr->m_size); // argc 184 | if (fnArgc > 1) { 185 | fnArgs[1].PointerVal = argv.set(pInt8Ty, ee, argsArr); 186 | if (fnArgc > 2) { 187 | fnArgs[2].PointerVal = env.set(pInt8Ty, ee, lean_to_array(envObj)); 188 | } 189 | } 190 | } 191 | auto gRc = ee->runFunction(toFunction(funRef), ArrayRef(fnArgs, fnArgc)); 192 | return lean_io_result_mk_ok(lean_box_uint32(gRc.IntVal.getZExtValue())); 193 | } 194 | 195 | } // end namespace papyrus 196 | -------------------------------------------------------------------------------- /c/src/function.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | using namespace llvm; 9 | 10 | namespace papyrus { 11 | 12 | // Get the LLVM Function pointer wrapped in an object. 13 | llvm::Function* toFunction(lean_object* funRef) { 14 | return llvm::cast(toValue(funRef)); 15 | } 16 | 17 | // Get a reference to a newly created function. 18 | extern "C" lean_obj_res papyrus_function_create 19 | (b_lean_obj_res typeRef, b_lean_obj_res nameObj, uint8_t linkage, 20 | uint32_t addrSpace, lean_obj_arg /* w */) 21 | { 22 | auto* fun = Function::Create(toFunctionType(typeRef), 23 | static_cast(linkage), addrSpace, refOfString(nameObj)); 24 | return lean_io_result_mk_ok(mkValueRef(copyLink(typeRef), fun)); 25 | } 26 | 27 | // Get the nth argument of the function 28 | extern "C" lean_obj_res papyrus_function_get_arg 29 | (uint32_t argNo, b_lean_obj_res funRef, lean_obj_arg /* w */) 30 | { 31 | return lean_io_result_mk_ok(mkValueRef(copyLink(funRef), 32 | toFunction(funRef)->getArg(argNo))); 33 | } 34 | 35 | // Get an array of references to the basic blocks of the given function. 36 | extern "C" lean_obj_res papyrus_function_get_basic_blocks 37 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 38 | { 39 | auto link = borrowLink(funRef); 40 | auto& bbs = toFunction(funRef)->getBasicBlockList(); 41 | lean_object* arr = lean_alloc_array(0, PAPYRUS_DEFAULT_ARRAY_CAPCITY); 42 | for (BasicBlock& bb : bbs) { 43 | lean_inc_ref(link); 44 | arr = lean_array_push(arr, mkValueRef(link, &bb)); 45 | } 46 | return lean_io_result_mk_ok(arr); 47 | } 48 | 49 | // Add the given instruction to the end of the given basic block. 50 | extern "C" lean_obj_res papyrus_function_append_basic_block 51 | (b_lean_obj_res bbRef, b_lean_obj_res funRef, lean_obj_arg /* w */) 52 | { 53 | toFunction(funRef)->getBasicBlockList().push_back(toBasicBlock(bbRef)); 54 | return lean_io_result_mk_ok(lean_box(0)); 55 | } 56 | 57 | // Check the given function for errors. 58 | // Errors are reported inside the `IO` monad. 59 | extern "C" lean_obj_res papyrus_function_verify 60 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 61 | { 62 | std::string ostr; 63 | raw_string_ostream out(ostr); 64 | if (llvm::verifyFunction(*toFunction(funRef), &out)) { 65 | return mkStdStringError(out.str()); 66 | } else { 67 | return lean_io_result_mk_ok(lean_box(0)); 68 | } 69 | } 70 | 71 | // Get whether the function has a specified garbage collection algorithm. 72 | extern "C" lean_obj_res papyrus_function_has_gc 73 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 74 | { 75 | return lean_io_result_mk_ok(lean_box(toFunction(funRef)->hasGC())); 76 | } 77 | 78 | // Get the garbage collection algorithm of a function. 79 | // Should only be called if it is known to have one specified. 80 | extern "C" lean_obj_res papyrus_function_get_gc 81 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 82 | { 83 | return lean_io_result_mk_ok(mkStringFromStd(toFunction(funRef)->getGC())); 84 | } 85 | 86 | // Set the garbage collection algorithm of a function. 87 | extern "C" lean_obj_res papyrus_function_set_gc 88 | (b_lean_obj_res gcStr, b_lean_obj_res funRef, lean_obj_arg /* w */) 89 | { 90 | toFunction(funRef)->setGC(stdOfString(gcStr)); 91 | return lean_io_result_mk_ok(lean_box(0)); 92 | } 93 | 94 | // Remove any specified garbage collection algorithm from the function. 95 | extern "C" lean_obj_res papyrus_function_clear_gc 96 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 97 | { 98 | toFunction(funRef)->clearGC(); 99 | return lean_io_result_mk_ok(lean_box(0)); 100 | } 101 | 102 | // Get the calling convention of a function. 103 | extern "C" lean_obj_res papyrus_function_get_calling_convention 104 | (b_lean_obj_res funRef, lean_obj_arg /* w */) 105 | { 106 | return lean_io_result_mk_ok(lean_box(toFunction(funRef)->getCallingConv())); 107 | } 108 | 109 | // Set the calling convetion of a function. 110 | extern "C" lean_obj_res papyrus_function_set_calling_convention 111 | (uint32_t callingConv, b_lean_obj_res funRef, lean_obj_arg /* w */) 112 | { 113 | toFunction(funRef)->setCallingConv(callingConv); 114 | return lean_io_result_mk_ok(lean_box(0)); 115 | } 116 | 117 | } // end namespace papyrus 118 | -------------------------------------------------------------------------------- /c/src/generic_value.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | using namespace llvm; 9 | 10 | namespace papyrus { 11 | 12 | // Wrap a GenericValue in a Lean object. 13 | lean_object* mkGenericValueRef(GenericValue* ptr) { 14 | return mkOwnedPtr(ptr); 15 | } 16 | 17 | // Get the GenericValue wrapped in an object. 18 | GenericValue* toGenericValue(lean_object* ref) { 19 | return fromOwnedPtr(ref); 20 | } 21 | 22 | // Create a new integer GenericValue of the given width from an Int. 23 | extern "C" lean_obj_res papyrus_generic_value_of_int 24 | (uint32_t numBits, b_lean_obj_res intObj, lean_obj_arg /* w */) 25 | { 26 | auto val = new GenericValue(); 27 | val->IntVal = apOfInt(numBits, intObj); 28 | return lean_io_result_mk_ok(mkGenericValueRef(val)); 29 | } 30 | 31 | // Convert an integer GenericValue to an Int. 32 | extern "C" lean_obj_res papyrus_generic_value_to_int 33 | (b_lean_obj_res valObj, lean_obj_arg /* w */) 34 | { 35 | return lean_io_result_mk_ok(mkIntFromAP(toGenericValue(valObj)->IntVal)); 36 | } 37 | 38 | // Create a new integer GenericValue of the given width from a Nat. 39 | extern "C" lean_obj_res papyrus_generic_value_of_nat 40 | (uint32_t numBits, b_lean_obj_res natObj, lean_obj_arg /* w */) 41 | { 42 | auto val = new GenericValue(); 43 | val->IntVal = apOfNat(numBits, natObj); 44 | return lean_io_result_mk_ok(mkGenericValueRef(val)); 45 | } 46 | 47 | // Convert an integer GenericValue to a Nat. 48 | extern "C" lean_obj_res papyrus_generic_value_to_nat 49 | (b_lean_obj_res valObj, lean_obj_arg /* w */) 50 | { 51 | return lean_io_result_mk_ok(mkNatFromAP(toGenericValue(valObj)->IntVal)); 52 | } 53 | 54 | // Create a new double GenericValue from a Float. 55 | extern "C" lean_obj_res papyrus_generic_value_of_float 56 | (double fval, lean_obj_arg /* w */) 57 | { 58 | auto val = new GenericValue(); 59 | val->DoubleVal = fval; 60 | return lean_io_result_mk_ok(mkGenericValueRef(val)); 61 | } 62 | 63 | // Convert a double GenericValue to a Float. 64 | extern "C" lean_obj_res papyrus_generic_value_to_float 65 | (b_lean_obj_res valObj, lean_obj_arg /* w */) 66 | { 67 | return lean_io_result_mk_ok(lean_box_float(toGenericValue(valObj)->FloatVal)); 68 | } 69 | 70 | // Create a new array GenericValue from an Array of generic value references. 71 | extern "C" lean_obj_res papyrus_generic_value_of_array 72 | (b_lean_obj_res valArr, lean_obj_arg /* w */) 73 | { 74 | auto val = new GenericValue(); 75 | auto valArrObj = lean_to_array(valArr); 76 | auto valArrLen = valArrObj->m_size; 77 | val->AggregateVal.reserve(valArrLen); 78 | for (auto i = 0; i < valArrLen; i++) { 79 | val->AggregateVal[i] = *toGenericValue(valArrObj->m_data[i]); 80 | } 81 | return lean_io_result_mk_ok(mkGenericValueRef(val)); 82 | } 83 | 84 | // Convert a vector GenericValue to an Array of generic value references. 85 | extern "C" lean_obj_res papyrus_generic_value_to_array 86 | (b_lean_obj_res valObj, lean_obj_arg /* w */) 87 | { 88 | auto val = toGenericValue(valObj); 89 | size_t len = val->AggregateVal.size(); 90 | lean_object* obj = lean_alloc_array(len, len); 91 | lean_array_object* arrObj = lean_to_array(obj); 92 | for (auto i = 0; i < len; i++) { 93 | arrObj->m_data[i] = mkGenericValueRef(new GenericValue(val->AggregateVal[i])); 94 | } 95 | return lean_io_result_mk_ok(obj); 96 | } 97 | 98 | } // end namespace papyrus 99 | -------------------------------------------------------------------------------- /c/src/global.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | using namespace llvm; 9 | 10 | namespace papyrus { 11 | 12 | //------------------------------------------------------------------------------ 13 | // GLobal Values 14 | //------------------------------------------------------------------------------ 15 | 16 | // Get the LLVM GlobalValue pointer wrapped in an object. 17 | llvm::GlobalValue* toGlobalValue(lean_object* ref) { 18 | return llvm::cast(toValue(ref)); 19 | } 20 | 21 | // Get the type of the given global's value. 22 | extern "C" lean_obj_res papyrus_global_value_get_value_type 23 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 24 | { 25 | auto type = toGlobalValue(gblRef)->getValueType(); 26 | return lean_io_result_mk_ok(mkTypeRef(copyLink(gblRef), type)); 27 | } 28 | 29 | // Get the linkage of a global value. 30 | extern "C" lean_obj_res papyrus_global_value_get_linkage(b_lean_obj_res gblRef, lean_obj_arg /* w */) { 31 | return lean_io_result_mk_ok(lean_box(toGlobalValue(gblRef)->getLinkage())); 32 | } 33 | 34 | // Set the linkage of a global value. 35 | extern "C" lean_obj_res papyrus_global_value_set_linkage 36 | (uint8_t linkage, b_lean_obj_res gblRef, lean_obj_arg /* w */) 37 | { 38 | toGlobalValue(gblRef)->setLinkage( 39 | static_cast(linkage)); 40 | return lean_io_result_mk_ok(lean_box(0)); 41 | } 42 | 43 | // Get the visibility of a global value. 44 | extern "C" lean_obj_res papyrus_global_value_get_visibility(b_lean_obj_res gblRef, lean_obj_arg /* w */) { 45 | return lean_io_result_mk_ok(lean_box(toGlobalValue(gblRef)->getVisibility())); 46 | } 47 | 48 | // Set the visibility of a global value. 49 | extern "C" lean_obj_res papyrus_global_value_set_visibility 50 | (uint8_t visibility, b_lean_obj_res gblRef, lean_obj_arg /* w */) 51 | { 52 | toGlobalValue(gblRef)->setVisibility( 53 | static_cast(visibility)); 54 | return lean_io_result_mk_ok(lean_box(0)); 55 | } 56 | 57 | // Get the DLL storage class of a global value. 58 | extern "C" lean_obj_res papyrus_global_value_get_dll_storage_class(b_lean_obj_res gblRef, lean_obj_arg /* w */) { 59 | return lean_io_result_mk_ok(lean_box(toGlobalValue(gblRef)->getDLLStorageClass())); 60 | } 61 | 62 | // Set the DLL storage class of a global value. 63 | extern "C" lean_obj_res papyrus_global_value_set_dll_storage_class 64 | (uint8_t dllStorageClass, b_lean_obj_res gblRef, lean_obj_arg /* w */) 65 | { 66 | toGlobalValue(gblRef)->setDLLStorageClass( 67 | static_cast(dllStorageClass)); 68 | return lean_io_result_mk_ok(lean_box(0)); 69 | } 70 | 71 | // Get the thread local mode of a global value. 72 | extern "C" lean_obj_res papyrus_global_value_get_thread_local_mode 73 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 74 | { 75 | return lean_io_result_mk_ok(lean_box(toGlobalValue(gblRef)->getThreadLocalMode())); 76 | } 77 | 78 | // Set the thread local mode of a global value. 79 | extern "C" lean_obj_res papyrus_global_value_set_thread_local_mode 80 | (uint8_t tlm, b_lean_obj_res gblRef, lean_obj_arg /* w */) 81 | { 82 | toGlobalValue(gblRef)->setThreadLocalMode( 83 | static_cast(tlm)); 84 | return lean_io_result_mk_ok(lean_box(0)); 85 | } 86 | 87 | // Get the address significance (unnamed_addr) of a global value. 88 | extern "C" lean_obj_res papyrus_global_value_get_address_significance 89 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 90 | { 91 | uint8_t tag; 92 | auto kind = toGlobalValue(gblRef)->getUnnamedAddr(); 93 | switch (kind) { 94 | case GlobalValue::UnnamedAddr::Local: 95 | tag = 1; 96 | break; 97 | case GlobalValue::UnnamedAddr::Global: 98 | tag = 2; 99 | break; 100 | default: 101 | tag = 0; 102 | break; 103 | } 104 | return lean_io_result_mk_ok(lean_box(tag)); 105 | } 106 | 107 | // Set the address significance (unnamed_addr) of a global value. 108 | extern "C" lean_obj_res papyrus_global_value_set_address_significance 109 | (uint8_t unnamedAddr, b_lean_obj_res gblRef, lean_obj_arg /* w */) 110 | { 111 | GlobalValue::UnnamedAddr kind; 112 | switch (unnamedAddr) { 113 | case 1: 114 | kind = GlobalValue::UnnamedAddr::Local; 115 | break; 116 | case 2: 117 | kind = GlobalValue::UnnamedAddr::Global; 118 | break; 119 | default: 120 | kind = GlobalValue::UnnamedAddr::None; 121 | break; 122 | } 123 | toGlobalValue(gblRef)->setUnnamedAddr(kind); 124 | return lean_io_result_mk_ok(lean_box(0)); 125 | } 126 | 127 | // Get the address space of a global value. 128 | extern "C" lean_obj_res papyrus_global_value_get_address_space 129 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 130 | { 131 | return lean_io_result_mk_ok(lean_box_uint32(toGlobalValue(gblRef)->getAddressSpace())); 132 | } 133 | 134 | //------------------------------------------------------------------------------ 135 | // GLobal Objects 136 | //------------------------------------------------------------------------------ 137 | 138 | // Get the LLVM GlobalObject pointer wrapped in an object. 139 | llvm::GlobalObject* toGlobalObject(lean_object* ref) { 140 | return llvm::cast(toValue(ref)); 141 | } 142 | 143 | // Get whether the global has an explicitly specifiec linker section. 144 | extern "C" lean_obj_res papyrus_global_object_has_section 145 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 146 | { 147 | return lean_io_result_mk_ok(lean_box(toGlobalObject(gblRef)->hasSection())); 148 | } 149 | 150 | // Get the explicit linker section of a global object (or the empty string if none). 151 | extern "C" lean_obj_res papyrus_global_object_get_section 152 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 153 | { 154 | return lean_io_result_mk_ok(mkStringFromRef(toGlobalObject(gblRef)->getSection())); 155 | } 156 | 157 | // Set the explicit linker section of a global object. 158 | // Passing the empty string will remove it. 159 | extern "C" lean_obj_res papyrus_global_object_set_section 160 | (b_lean_obj_res strObj, b_lean_obj_res gblRef, lean_obj_arg /* w */) 161 | { 162 | toGlobalObject(gblRef)->setSection(refOfString(strObj)); 163 | return lean_io_result_mk_ok(lean_box(0)); 164 | } 165 | 166 | // Get the explicit power of two alignment of a global object (or 0 if undefined). 167 | extern "C" lean_obj_res papyrus_global_object_get_alignment 168 | (b_lean_obj_res gblRef, lean_obj_arg /* w */) 169 | { 170 | auto align = toGlobalObject(gblRef)->getAlign(); 171 | return lean_io_result_mk_ok(lean_box_uint64(align ? align->value() : 0)); 172 | } 173 | 174 | // Set the explicit power of two alignment of a global object. 175 | // Passing 0 will remove it. 176 | extern "C" lean_obj_res papyrus_global_object_set_alignment 177 | (uint64_t alignment, b_lean_obj_res gblRef, lean_obj_arg /* w */) 178 | { 179 | toGlobalObject(gblRef)->setAlignment( 180 | alignment == 0 ? MaybeAlign() : MaybeAlign(alignment)); 181 | return lean_io_result_mk_ok(lean_box(0)); 182 | } 183 | 184 | } // end namespace papyrus 185 | -------------------------------------------------------------------------------- /c/src/global_variable.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | // Get the LLVM GlobalVariable pointer wrapped in an object. 12 | llvm::GlobalVariable* toGlobalVariable(lean_object* ref) { 13 | return llvm::cast(toValue(ref)); 14 | } 15 | 16 | // Get a reference to a newly created global variable without an initializer. 17 | extern "C" lean_obj_res papyrus_global_variable_new 18 | (b_lean_obj_res typeRef, uint8_t isConstant, uint8_t linkage, b_lean_obj_res nameObj, 19 | uint8_t tlm, uint32_t addrSpace, uint8_t externInit, lean_obj_arg /* w */) 20 | { 21 | auto var = new GlobalVariable(toType(typeRef), isConstant, 22 | static_cast(linkage), nullptr, refOfString(nameObj), 23 | static_cast(tlm), addrSpace, externInit); 24 | return lean_io_result_mk_ok(mkValueRef(copyLink(typeRef), var)); 25 | } 26 | 27 | // Get a reference to a newly created global variable with an initializer. 28 | extern "C" lean_obj_res papyrus_global_variable_new_with_init 29 | (b_lean_obj_res typeRef, uint8_t isConstant, uint8_t linkage, 30 | b_lean_obj_res initializerObj, b_lean_obj_res nameObj, uint8_t tlm, 31 | uint32_t addrSpace, uint8_t externInit, lean_obj_arg /* w */) 32 | { 33 | auto var = new GlobalVariable(toType(typeRef), isConstant, 34 | static_cast(linkage), toConstant(initializerObj), 35 | refOfString(nameObj), static_cast(tlm), 36 | addrSpace, externInit); 37 | return lean_io_result_mk_ok(mkValueRef(copyLink(typeRef), var)); 38 | } 39 | 40 | 41 | // Get whether this global variable is constant. 42 | extern "C" lean_obj_res papyrus_global_variable_is_constant 43 | (b_lean_obj_res varRef, lean_obj_arg /* w */) 44 | { 45 | auto b = toGlobalVariable(varRef)->isConstant(); 46 | return lean_io_result_mk_ok(lean_box(b)); 47 | } 48 | 49 | // Set whether this global variable is constant. 50 | extern "C" lean_obj_res papyrus_global_variable_set_constant 51 | (uint8_t isConstant, b_lean_obj_res varRef, lean_obj_arg /* w */) 52 | { 53 | toGlobalVariable(varRef)->setConstant(isConstant); 54 | return lean_io_result_mk_ok(lean_box(isConstant)); 55 | } 56 | 57 | // Get whether this global variable has a (local) initializer. 58 | extern "C" lean_obj_res papyrus_global_variable_has_initializer 59 | (b_lean_obj_res varRef, lean_obj_arg /* w */) 60 | { 61 | return lean_io_result_mk_ok(lean_box(toGlobalVariable(varRef)->hasInitializer())); 62 | } 63 | 64 | // Get the (local) initializer of this global variable. 65 | // Only call this if the global variable is know to have one 66 | // (i.e., because hasInitializer return true). 67 | extern "C" lean_obj_res papyrus_global_variable_get_initializer 68 | (b_lean_obj_res varRef, lean_obj_arg /* w */) 69 | { 70 | auto initializer = toGlobalVariable(varRef)->getInitializer(); 71 | return lean_io_result_mk_ok(mkValueRef(getValueContext(varRef), initializer)); 72 | } 73 | 74 | // Set the initializer of this global variable. 75 | extern "C" lean_obj_res papyrus_global_variable_set_initializer 76 | (b_lean_obj_res initializerObj, b_lean_obj_res varRef, lean_obj_arg /* w */) 77 | { 78 | toGlobalVariable(varRef)->setInitializer(toConstant(initializerObj)); 79 | return lean_io_result_mk_ok(lean_box(0)); 80 | } 81 | 82 | // Remove the initializer of this global variable. 83 | extern "C" lean_obj_res papyrus_global_variable_remove_initializer 84 | (b_lean_obj_res initializerObj, b_lean_obj_res varRef, lean_obj_arg /* w */) 85 | { 86 | toGlobalVariable(varRef)->setInitializer(nullptr); 87 | return lean_io_result_mk_ok(lean_box(0)); 88 | } 89 | 90 | // Get whether this global variable is externally initialized. 91 | extern "C" lean_obj_res papyrus_global_variable_is_externally_initialized 92 | (b_lean_obj_res varRef, lean_obj_arg /* w */) 93 | { 94 | return lean_io_result_mk_ok(lean_box(toGlobalVariable(varRef)->isExternallyInitialized())); 95 | } 96 | 97 | // Set whether this global variable is externally initialized. 98 | extern "C" lean_obj_res papyrus_global_variable_set_externally_initialized 99 | (uint8_t externallyInitialized, b_lean_obj_res varRef, lean_obj_arg /* w */) 100 | { 101 | toGlobalVariable(varRef)->setExternallyInitialized(externallyInitialized); 102 | return lean_io_result_mk_ok(lean_box(0)); 103 | } 104 | 105 | } // end namespace papyrus 106 | -------------------------------------------------------------------------------- /c/src/init.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | // JIT Initialization 12 | // ------------------ 13 | // The mere presence of these bindings causes 14 | // MCJIT and the Interpreter to be linked in 15 | 16 | extern "C" lean_obj_res papyrus_link_in_mcjit(lean_obj_arg /* w */) { 17 | LLVMLinkInMCJIT(); 18 | return lean_io_result_mk_ok(lean_box(0)); 19 | } 20 | 21 | extern "C" lean_obj_res papyrus_link_in_interpreter(lean_obj_arg /* w */) { 22 | LLVMLinkInInterpreter(); 23 | return lean_io_result_mk_ok(lean_box(0)); 24 | } 25 | 26 | // All Target Initialization 27 | 28 | extern "C" lean_obj_res papyrus_init_all_targets(lean_obj_arg /* w */) { 29 | llvm::InitializeAllTargets(); 30 | return lean_io_result_mk_ok(lean_box(0)); 31 | } 32 | 33 | extern "C" lean_obj_res papyrus_init_all_target_infos(lean_obj_arg /* w */) { 34 | llvm::InitializeAllTargetInfos(); 35 | return lean_io_result_mk_ok(lean_box(0)); 36 | } 37 | 38 | extern "C" lean_obj_res papyrus_init_all_target_mcs(lean_obj_arg /* w */) { 39 | llvm::InitializeAllTargetMCs(); 40 | return lean_io_result_mk_ok(lean_box(0)); 41 | } 42 | 43 | extern "C" lean_obj_res papyrus_init_all_asm_parsers(lean_obj_arg /* w */) { 44 | llvm::InitializeAllAsmParsers(); 45 | return lean_io_result_mk_ok(lean_box(0)); 46 | } 47 | 48 | extern "C" lean_obj_res papyrus_init_all_asm_printers(lean_obj_arg /* w */) { 49 | llvm::InitializeAllAsmPrinters(); 50 | return lean_io_result_mk_ok(lean_box(0)); 51 | } 52 | 53 | extern "C" lean_obj_res papyrus_init_all_disassemblers(lean_obj_arg /* w */) { 54 | llvm::InitializeAllDisassemblers(); 55 | return lean_io_result_mk_ok(lean_box(0)); 56 | } 57 | 58 | // Native Target Initialization 59 | 60 | extern "C" lean_obj_res papyrus_init_native_target(lean_obj_arg /* w */) { 61 | return lean_io_result_mk_ok(lean_box(llvm::InitializeNativeTarget())); 62 | } 63 | 64 | extern "C" lean_obj_res papyrus_init_native_asm_parser(lean_obj_arg /* w */) { 65 | return lean_io_result_mk_ok(lean_box(llvm::InitializeNativeTargetAsmParser())); 66 | } 67 | 68 | extern "C" lean_obj_res papyrus_init_native_asm_printer(lean_obj_arg /* w */) { 69 | return lean_io_result_mk_ok(lean_box(llvm::InitializeNativeTargetAsmPrinter())); 70 | } 71 | 72 | extern "C" lean_obj_res papyrus_init_native_disassembler(lean_obj_arg /* w */) { 73 | return lean_io_result_mk_ok(lean_box(llvm::InitializeNativeTargetDisassembler())); 74 | } 75 | 76 | } // end namespace papyrus 77 | -------------------------------------------------------------------------------- /c/src/memory_buffer.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | 7 | using namespace llvm; 8 | 9 | namespace papyrus { 10 | 11 | lean_object* mkMemoryBufferRef(MemoryBuffer* ptr) { 12 | return mkOwnedPtr(ptr); 13 | } 14 | 15 | MemoryBuffer* toMemoryBuffer(lean_object* ref) { 16 | return fromOwnedPtr(ref); 17 | } 18 | 19 | extern "C" lean_obj_res papyrus_memory_buffer_from_file(b_lean_obj_res fnameObj, lean_obj_arg /* w */) { 20 | auto mbOrErr = MemoryBuffer::getFile(refOfString(fnameObj)); 21 | if (std::error_code ec = mbOrErr.getError()) { 22 | return lean_decode_io_error(ec.value(), fnameObj); 23 | } 24 | auto bufPtr = std::move(mbOrErr.get()); 25 | lean_object* bufObj = mkMemoryBufferRef(bufPtr.get()); 26 | bufPtr.release(); 27 | return lean_io_result_mk_ok(bufObj); 28 | } 29 | 30 | } // end namespace papyrus 31 | -------------------------------------------------------------------------------- /c/src/module.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | using namespace llvm; 10 | 11 | namespace papyrus { 12 | 13 | //------------------------------------------------------------------------------ 14 | // Module references 15 | //------------------------------------------------------------------------------ 16 | 17 | // Wrap an LLVM Module in a Lean object. 18 | lean_object* mkModuleRef(lean_obj_arg ctx, llvm::Module* modPtr) { 19 | return mkLinkedLoosePtr(ctx, modPtr); 20 | } 21 | 22 | // Get the LLVM Module wrapped in an object. 23 | llvm::Module* toModule(lean_object* modRef) { 24 | return fromLinkedLoosePtr(modRef); 25 | } 26 | 27 | //------------------------------------------------------------------------------ 28 | // Basic functions 29 | //------------------------------------------------------------------------------ 30 | 31 | // Create a new Lean LLVM Module object with the given ID. 32 | extern "C" lean_obj_res papyrus_module_new 33 | (lean_obj_arg modIdObj, lean_obj_arg ctxRef, lean_obj_arg /* w */) 34 | { 35 | auto ctx = toLLVMContext(ctxRef); 36 | auto mod = new llvm::Module(refOfString(modIdObj), *ctx); 37 | return lean_io_result_mk_ok(mkModuleRef(ctxRef, mod)); 38 | } 39 | 40 | // Get the ID of the module. 41 | extern "C" lean_obj_res papyrus_module_get_id 42 | (b_lean_obj_res modRef, lean_obj_arg /* w */) 43 | { 44 | auto id = toModule(modRef)->getModuleIdentifier(); 45 | return lean_io_result_mk_ok(mkStringFromStd(id)); 46 | } 47 | 48 | // Set the ID of the module. 49 | extern "C" lean_obj_res papyrus_module_set_id 50 | (b_lean_obj_res modRef, b_lean_obj_res modIdObj, lean_obj_arg /* w */) 51 | { 52 | toModule(modRef)->setModuleIdentifier(refOfString(modIdObj)); 53 | return lean_io_result_mk_ok(lean_box(0)); 54 | } 55 | 56 | // Get the global variable of the given name in the module 57 | // (or error if it does not exist). 58 | extern "C" lean_obj_res papyrus_module_get_global_variable 59 | (b_lean_obj_res nameObj, b_lean_obj_res modRef, uint8_t allowInternal, 60 | lean_obj_arg /* w */) 61 | { 62 | auto gbl = toModule(modRef)->getGlobalVariable(refOfString(nameObj), allowInternal); 63 | if (gbl) { 64 | return lean_io_result_mk_ok(mkValueRef(copyLink(modRef), gbl)); 65 | } else { 66 | return mkStdStringError("Named global variable does not exist in module."); 67 | } 68 | } 69 | 70 | // Get the global variable of the given name in the module 71 | // (or none if it does not exist). 72 | extern "C" lean_obj_res papyrus_module_get_global_variable_opt 73 | (b_lean_obj_res nameObj, b_lean_obj_res modRef, uint8_t allowInternal, 74 | lean_obj_arg /* w */) 75 | { 76 | auto gbl = toModule(modRef)->getGlobalVariable(refOfString(nameObj), allowInternal); 77 | auto obj = gbl ? mkSome(mkValueRef(copyLink(modRef), gbl)) : lean_box(0); 78 | return lean_io_result_mk_ok(obj); 79 | } 80 | 81 | // Get an array of references to the global variables of the given module. 82 | extern "C" lean_obj_res papyrus_module_get_global_variables 83 | (b_lean_obj_res modRef, lean_obj_arg /* w */) 84 | { 85 | auto ctxRef = borrowLink(modRef); 86 | auto& vars = toModule(modRef)->getGlobalList(); 87 | lean_object* arr = lean_alloc_array(0, PAPYRUS_DEFAULT_ARRAY_CAPCITY); 88 | for (GlobalVariable& var : vars) { 89 | lean_inc_ref(ctxRef); 90 | arr = lean_array_push(arr, mkValueRef(ctxRef, &var)); 91 | } 92 | return lean_io_result_mk_ok(arr); 93 | } 94 | 95 | // Add the given global variable to the end of the module. 96 | extern "C" lean_obj_res papyrus_module_append_global_variable 97 | (b_lean_obj_res funRef, b_lean_obj_res modRef, lean_obj_arg /* w */) 98 | { 99 | toModule(modRef)->getGlobalList().push_back(toGlobalVariable(funRef)); 100 | return lean_io_result_mk_ok(lean_box(0)); 101 | } 102 | 103 | // Get the function of the given name in the module 104 | // (or error if it does not exist). 105 | extern "C" lean_obj_res papyrus_module_get_function 106 | (b_lean_obj_res nameObj, b_lean_obj_res modRef, lean_obj_arg /* w */) 107 | { 108 | auto fn = toModule(modRef)->getFunction(refOfString(nameObj)); 109 | if (fn) { 110 | return lean_io_result_mk_ok(mkValueRef(copyLink(modRef), fn)); 111 | } else { 112 | return mkStdStringError("Named function does not exist in module."); 113 | } 114 | } 115 | 116 | // Get the function of the given name in the module (or none if it does not exist). 117 | extern "C" lean_obj_res papyrus_module_get_function_opt 118 | (b_lean_obj_res nameObj, b_lean_obj_res modRef, lean_obj_arg /* w */) 119 | { 120 | auto fn = toModule(modRef)->getFunction(refOfString(nameObj)); 121 | auto obj = fn ? mkSome(mkValueRef(copyLink(modRef), fn)) : lean_box(0); 122 | return lean_io_result_mk_ok(obj); 123 | } 124 | 125 | // Get an array of references to the functions of the given module. 126 | extern "C" lean_obj_res papyrus_module_get_functions 127 | (b_lean_obj_res modRef, lean_obj_arg /* w */) 128 | { 129 | auto ctxRef = borrowLink(modRef); 130 | auto& funs = toModule(modRef)->getFunctionList(); 131 | lean_object* arr = lean_alloc_array(0, PAPYRUS_DEFAULT_ARRAY_CAPCITY); 132 | for (Function& fun : funs) { 133 | lean_inc_ref(ctxRef); 134 | arr = lean_array_push(arr, mkValueRef(ctxRef, &fun)); 135 | } 136 | return lean_io_result_mk_ok(arr); 137 | } 138 | 139 | // Add the given function to the end of the module. 140 | extern "C" lean_obj_res papyrus_module_append_function 141 | (b_lean_obj_res funRef, b_lean_obj_res modRef, lean_obj_arg /* w */) 142 | { 143 | toModule(modRef)->getFunctionList().push_back(toFunction(funRef)); 144 | return lean_io_result_mk_ok(lean_box(0)); 145 | } 146 | 147 | // Check the given module for errors. 148 | // Errors are reported inside the `IO` monad. 149 | // If `warnBrokenDebugInfo` is true, DebugInfo verification failures won't be 150 | // considered as an error and instead the function will return true. 151 | // Otherwise, the function will always return false. 152 | extern "C" lean_obj_res papyrus_module_verify 153 | (b_lean_obj_res modRef, uint8_t warnBrokenDebugInfo, lean_obj_arg /* w */) 154 | { 155 | std::string ostr; 156 | raw_string_ostream out(ostr); 157 | if (warnBrokenDebugInfo) { 158 | bool brokenDebugInfo; 159 | if (llvm::verifyModule(*toModule(modRef), &out, &brokenDebugInfo)) { 160 | return mkStdStringError(out.str()); 161 | } else { 162 | return lean_io_result_mk_ok(lean_box(brokenDebugInfo)); 163 | } 164 | } else { 165 | if (llvm::verifyModule(*toModule(modRef), &out)) { 166 | return mkStdStringError(out.str()); 167 | } else { 168 | return lean_io_result_mk_ok(lean_box(false)); 169 | } 170 | } 171 | } 172 | 173 | // Print the given module to LLVM's standard output. 174 | extern "C" lean_obj_res papyrus_module_print 175 | (b_lean_obj_res modRef, uint8_t shouldPreserveUseListOrder, uint8_t isForDebug, 176 | lean_obj_arg /* w */) 177 | { 178 | toModule(modRef)->print(llvm::outs(), nullptr, shouldPreserveUseListOrder, isForDebug); 179 | return lean_io_result_mk_ok(lean_box(0)); 180 | } 181 | 182 | // Print the given module to LLVM's standard error. 183 | extern "C" lean_obj_res papyrus_module_eprint 184 | (b_lean_obj_res modRef, uint8_t shouldPreserveUseListOrder, uint8_t isForDebug, 185 | lean_obj_arg /* w */) 186 | { 187 | toModule(modRef)->print(llvm::errs(), nullptr, shouldPreserveUseListOrder, isForDebug); 188 | return lean_io_result_mk_ok(lean_box(0)); 189 | } 190 | 191 | // Print the given module to a string. 192 | extern "C" lean_obj_res papyrus_module_sprint 193 | (b_lean_obj_res modRef, uint8_t shouldPreserveUseListOrder, uint8_t isForDebug, 194 | lean_obj_arg /* w */) 195 | { 196 | std::string ostr; 197 | raw_string_ostream out(ostr); 198 | toModule(modRef)->print(out, nullptr, shouldPreserveUseListOrder, isForDebug); 199 | return lean_io_result_mk_ok(mkStringFromStd(out.str())); 200 | } 201 | 202 | } // end namespace papyrus 203 | -------------------------------------------------------------------------------- /c/src/value.cpp: -------------------------------------------------------------------------------- 1 | #include "papyrus.h" 2 | #include "papyrus_ffi.h" 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | using namespace llvm; 10 | 11 | namespace papyrus { 12 | 13 | //------------------------------------------------------------------------------ 14 | // Value references 15 | //------------------------------------------------------------------------------ 16 | 17 | // Wrap an LLVM Value pointer in a Lean object. 18 | lean_obj_res mkValueRef(lean_obj_arg ctxRef, llvm::Value* ptr) { 19 | return mkLinkedLoosePtr(ctxRef, ptr); 20 | } 21 | 22 | // Get the LLVM Value pointer wrapped in an object. 23 | llvm::Value* toValue(b_lean_obj_res valueRef) { 24 | return fromLinkedLoosePtr(valueRef); 25 | } 26 | 27 | // Get the owning LLVM context object of the given value and increments its RC. 28 | lean_obj_res getValueContext(b_lean_obj_res valRef) { 29 | return copyLink(valRef); 30 | } 31 | 32 | //------------------------------------------------------------------------------ 33 | // Basic functions 34 | //------------------------------------------------------------------------------ 35 | 36 | // Get the ID of the given value. 37 | // As a value's ID is immutable, we don't need to wrap it in IO. 38 | extern "C" uint32_t papyrus_value_id(b_lean_obj_res valueRef) { 39 | return toValue(valueRef)->getValueID(); 40 | } 41 | 42 | // Get a reference to the type of the given value. 43 | extern "C" lean_obj_res papyrus_value_get_type 44 | (b_lean_obj_res valueRef, lean_obj_arg /* w */) 45 | { 46 | return lean_io_result_mk_ok(mkTypeRef(getValueContext(valueRef), toValue(valueRef)->getType())); 47 | } 48 | 49 | // Get whether the the given value has a name. 50 | extern "C" lean_obj_res papyrus_value_has_name 51 | (b_lean_obj_res valueRef, lean_obj_arg /* w */) 52 | { 53 | return lean_io_result_mk_ok(lean_box(toValue(valueRef)->hasName())); 54 | } 55 | 56 | // Get the name of the given value (or the empty string if none). 57 | extern "C" lean_obj_res papyrus_value_get_name 58 | (b_lean_obj_res valueRef, lean_obj_arg /* w */) 59 | { 60 | return lean_io_result_mk_ok(mkStringFromRef(toValue(valueRef)->getName())); 61 | } 62 | 63 | // Set the name of the given value. 64 | // An empty string will remove the value's name. 65 | extern "C" lean_obj_res papyrus_value_set_name 66 | (b_lean_obj_res strObj, b_lean_obj_res valueRef, lean_obj_arg /* w */) 67 | { 68 | toValue(valueRef)->setName(refOfString(strObj)); 69 | return lean_io_result_mk_ok(lean_box(0)); 70 | } 71 | 72 | // Print the given value to LLVM's standard output. 73 | extern "C" lean_obj_res papyrus_value_print 74 | (b_lean_obj_res valueRef, uint8_t isForDebug, lean_obj_arg /* w */) 75 | { 76 | toValue(valueRef)->print(llvm::outs(), isForDebug); 77 | return lean_io_result_mk_ok(lean_box(0)); 78 | } 79 | 80 | // Print the given value to LLVM's standard error. 81 | extern "C" lean_obj_res papyrus_value_eprint 82 | (b_lean_obj_res valueRef, uint8_t isForDebug, lean_obj_arg /* w */) 83 | { 84 | toValue(valueRef)->print(llvm::errs(), isForDebug); 85 | return lean_io_result_mk_ok(lean_box(0)); 86 | } 87 | 88 | // Print the given value to a string. 89 | extern "C" lean_obj_res papyrus_value_sprint 90 | (b_lean_obj_res valueRef, uint8_t isForDebug, lean_obj_arg /* w */) 91 | { 92 | std::string ostr; 93 | raw_string_ostream out(ostr); 94 | toValue(valueRef)->print(out, isForDebug); 95 | return lean_io_result_mk_ok(mkStringFromStd(out.str())); 96 | } 97 | 98 | } // end namespace papyrus 99 | -------------------------------------------------------------------------------- /leanWithPlugin.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | MY_DIR=$(dirname $0) 4 | PLUGIN=${MY_DIR}/plugin/build/PapyrusPlugin 5 | 6 | OS_NAME=${OS} 7 | if [[ "${OS_NAME}" != "Windows_NT" ]]; then 8 | OS_NAME=$(uname -s) 9 | fi 10 | 11 | export LEAN_PATH="${MY_DIR}/build/${OS_NAME}" 12 | if [[ "$OS_NAME" == "Windows_NT" ]]; then 13 | lean --plugin ${PLUGIN} "$@" 14 | else 15 | LEAN_LIBDIR=$(lean --print-libdir) 16 | export LD_PRELOAD="${LEAN_LIBDIR}/libleanshared.so:${PLUGIN}.so" 17 | lean --plugin ${PLUGIN}.so "$@" 18 | fi 19 | -------------------------------------------------------------------------------- /leanpkg.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "papyrus" 3 | version = "0.2" 4 | lean_version = "leanprover/lean4:nightly-2021-09-13" 5 | -------------------------------------------------------------------------------- /plugin/Makefile: -------------------------------------------------------------------------------- 1 | # Detect Lean 2 | 3 | LEAN ?= lean 4 | LEANC ?= leanc 5 | 6 | # Detect LLVM 7 | 8 | LLVM_CONFIG ?= llvm-config 9 | 10 | LLVM_COMPONENTS :=\ 11 | core bitreader bitwriter executionengine mcjit interpreter all-targets 12 | 13 | LLVM_LD_FLAGS := $(shell $(LLVM_CONFIG) --link-static --ldflags) 14 | LLVM_LIBS := $(shell $(LLVM_CONFIG) --link-static --libs $(LLVM_COMPONENTS)) 15 | LLVM_SYS_LIBS := $(shell $(LLVM_CONFIG) --link-static --system-libs) -lffi 16 | LLVM_LIB_FLAGS := $(LLVM_LD_FLAGS) $(LLVM_LIBS) $(LLVM_SYS_LIBS) 17 | 18 | # Detect OS 19 | 20 | OS_NAME := ${OS} 21 | ifneq ($(OS_NAME),Windows_NT) 22 | OS_NAME := $(shell uname -s) 23 | endif 24 | 25 | # Config 26 | 27 | MV := mv 28 | RM := rm 29 | 30 | MKPATH := mkdir -p 31 | RMPATH := ${RM} -rf 32 | 33 | OUT_DIR := build 34 | 35 | LEAN_OUT := ../build/$(OS_NAME) 36 | LEAN_PATH := $(LEAN_OUT) 37 | 38 | LIB_NAME := Papyrus 39 | LIB_DIR := $(LEAN_OUT)/lib 40 | LIB := lib${LIB_NAME}.a 41 | 42 | ifeq ($(OS_NAME),Darwin) 43 | LIB_FLAGS := -Wl,-force_load,${LIB_DIR}/$(LIB) 44 | else 45 | LIB_FLAGS := -L${LIB_DIR} -Wl,--whole-archive -l$(LIB_NAME) -Wl,--no-whole-archive 46 | endif 47 | 48 | C_LIB_NAME := PapyrusC 49 | C_LIB_DIR := ../c/build/$(OS_NAME) 50 | C_LIB := lib${C_LIB_NAME}.a 51 | 52 | PLUGIN := PapyrusPlugin 53 | 54 | ifeq ($(OS_NAME),Windows_NT) 55 | SHARED_LIB_EXT := dll 56 | else 57 | SHARED_LIB_EXT := so 58 | endif 59 | 60 | PLUGIN_LIB := ${PLUGIN}.$(SHARED_LIB_EXT) 61 | 62 | EXTRA_LIB_FLAGS := -lstdc++ 63 | 64 | # Build Rules 65 | 66 | all: plugin 67 | 68 | $(OUT_DIR): 69 | $(MKPATH) $@ 70 | 71 | clean: 72 | $(RMPATH) $(OUT_DIR) 73 | 74 | # Plugin Build 75 | 76 | plugin: $(OUT_DIR)/${PLUGIN_LIB} 77 | 78 | $(OUT_DIR)/${PLUGIN_LIB}: $(OUT_DIR)/${PLUGIN}.c $(C_LIB_DIR)/$(C_LIB) $(LIB_DIR)/$(LIB) | $(OUT_DIR) 79 | # rename old lib in case it can't be replaced (e.g., because it is in use) 80 | -${MV} $@ $@.tmp 81 | ${LEANC} -shared -o $@ $< ${LIB_FLAGS} -L${C_LIB_DIR} -l${C_LIB_NAME} ${LLVM_LIB_FLAGS} ${EXTRA_LIB_FLAGS} 82 | # try to delete old lib 83 | ${RM} -f $@.tmp 84 | 85 | 86 | $(OUT_DIR)/${PLUGIN}.c: ${PLUGIN}.lean | $(OUT_DIR) 87 | LEAN_PATH=${LEAN_PATH} $(LEAN) -c $@ $< 88 | -------------------------------------------------------------------------------- /plugin/PapyrusPlugin.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | /tmp 2 | *.produced.out 3 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | # Config 2 | 3 | MKPATH := mkdir -p 4 | RMPATH := rm -rf 5 | 6 | TEST_RUN := ./test_run.sh 7 | TEST_OUT := ./test_out.sh 8 | TEST_MAIN := ./test_main.sh 9 | 10 | RUN_TEST_DIR := run 11 | OUT_TEST_DIR := out 12 | MAIN_TEST_DIR := main 13 | 14 | RUN_TESTS := $(wildcard $(RUN_TEST_DIR)/**/*.lean) 15 | OUT_TESTS := $(wildcard $(OUT_TEST_DIR)/**/*.lean) 16 | MAIN_TESTS := $(wildcard $(MAIN_TEST_DIR)/*.lean) 17 | 18 | TESTS := $(MAIN_TESTS) $(RUN_TESTS) $(OUT_TESTS) 19 | 20 | TEST_TMP_DIR := tmp 21 | 22 | # Rules 23 | 24 | all: test 25 | 26 | test: $(TESTS) 27 | 28 | clean: clean-out clean-tmp-dir 29 | 30 | $(MAIN_TESTS): 31 | @echo "Testing $@ ... " 32 | @$(TEST_MAIN) $@ 33 | 34 | $(RUN_TESTS): 35 | @echo "Testing $@ ... " 36 | @$(TEST_RUN) $@ 37 | 38 | $(OUT_TESTS): 39 | @echo "Testing $@ ... " 40 | @$(TEST_OUT) $@ 41 | 42 | clean-out: 43 | $(RMPATH) ${SRC_DIR}/**/*.lean.produced.out 44 | 45 | clean-tmp-dir: 46 | $(RMPATH) $(TEST_OUT_DIR) 47 | 48 | .PHONY: all test clean clean-out clean-tmp-dir $(TESTS) 49 | -------------------------------------------------------------------------------- /test/common.sh: -------------------------------------------------------------------------------- 1 | cd ${BASH_SOURCE%/*} 2 | 3 | OS_NAME=${OS} 4 | if [[ "${OS_NAME}" != "Windows_NT" ]]; then 5 | OS_NAME=$(uname -s) 6 | fi 7 | 8 | export LEAN_PATH=../build/${OS_NAME} 9 | PLUGIN=../plugin/build/PapyrusPlugin 10 | if [[ "${OS_NAME}" == "Windows_NT" ]]; then 11 | export LEAN_OPTS="--plugin ${PLUGIN}" 12 | else 13 | LEAN_LIBDIR=$(lean --print-libdir) 14 | export LD_PRELOAD="${LEAN_LIBDIR}/libleanshared.so:${PLUGIN}.so" 15 | export LEAN_OPTS="--plugin ${PLUGIN}.so" 16 | fi 17 | 18 | # The shells scripts in this directory were adapted from the Lean 4 sources 19 | 20 | set -euo pipefail 21 | 22 | ulimit -s 8192 23 | DIFF=diff 24 | if diff --color --help >/dev/null 2>&1; then 25 | DIFF="diff --color"; 26 | fi 27 | 28 | function fail { 29 | echo $1 30 | exit 1 31 | } 32 | 33 | [ $# -eq 0 ] && fail "Usage: ${0##*/} [-i] test-file.lean" 34 | 35 | INTERACTIVE=no 36 | if [ $1 == "-i" ]; then 37 | INTERACTIVE=yes 38 | shift 39 | fi 40 | 41 | [ $# -eq 1 ] || fail "Usage: ${0##*/} [-i] test-file.lean" 42 | f=${1##${BASH_SOURCE%/*}/} # test-file path realtive to the test directory 43 | shift 44 | 45 | function compile_lean { 46 | lean --c="$f.c" "$f" || fail "Failed to compile $f into C file" 47 | leanc -O3 -DNDEBUG -o "$f.out" "$@" "$f.c" || fail "Failed to compile C file $f.c" 48 | } 49 | 50 | function exec_capture { 51 | # mvar suffixes like in `?m.123` are deterministic but prone to change on minor changes, so strip them 52 | "$@" 2>&1 | sed -E 's/(\?\w)\.[0-9]+/\1/g' > "$f.produced.out" 53 | } 54 | 55 | # Remark: `${var+x}` is a parameter expansion which evaluates to nothing if `var` is unset, and substitutes the string `x` otherwise. 56 | function exec_check { 57 | ret=0 58 | [ -n "${expected_ret+x}" ] || expected_ret=0 59 | [ -f "$f.expected.ret" ] && expected_ret=$(< "$f.expected.ret") 60 | exec_capture "$@" || ret=$? 61 | if [ -n "$expected_ret" ] && [ $ret -ne $expected_ret ]; then 62 | echo "Unexpected return code $ret executing '$@'; expected $expected_ret. Output:" 63 | cat "$f.produced.out" 64 | exit 1 65 | fi 66 | } 67 | 68 | function diff_produced { 69 | if test -f "$f.expected.out"; then 70 | if $DIFF -au --strip-trailing-cr -I "executing external script" "$f.expected.out" "$f.produced.out"; then 71 | exit 0 72 | else 73 | echo "ERROR: file $f.produced.out does not match $f.expected.out" 74 | if [ $INTERACTIVE == "yes" ]; then 75 | if ! type "meld" &> /dev/null; then 76 | read -p "copy $f.produced.out (y/n)? " 77 | if [ $REPLY == "y" ]; then 78 | cp -- "$f.produced.out" "$f.expected.out" 79 | echo "-- copied $f.produced.out --> $f.expected.out" 80 | fi 81 | else 82 | meld "$f.produced.out" "$f.expected.out" 83 | if diff -I "executing external script" "$f.expected.out" "$f.produced.out"; then 84 | echo "-- mismatch was fixed" 85 | fi 86 | fi 87 | fi 88 | exit 1 89 | fi 90 | else 91 | echo "ERROR: file $f.expected.out does not exist" 92 | if [ $INTERACTIVE == "yes" ]; then 93 | read -p "copy $f.produced.out (y/n)? " 94 | if [ $REPLY == "y" ]; then 95 | cp -- "$f.produced.out" "$f.expected.out" 96 | echo "-- copied $f.produced.out --> $f.expected.out" 97 | fi 98 | fi 99 | exit 1 100 | fi 101 | } 102 | -------------------------------------------------------------------------------- /test/main/program.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | open Papyrus 3 | 4 | -------------------------------------------------------------------------------- 5 | -- # Helpers 6 | -------------------------------------------------------------------------------- 7 | 8 | def testOutDir : System.FilePath := "tmp" 9 | 10 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 11 | unless expected == actual do 12 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 13 | 14 | def compileAndRunModule (mod : ModuleRef) (fname : String) : IO IO.Process.Output := do 15 | IO.FS.createDirAll testOutDir 16 | let file := testOutDir / fname 17 | let bcFile := file.withExtension "bc" |>.toString 18 | let asmFile := file.withExtension "s" |>.toString 19 | let exeFile := file.withExtension System.FilePath.exeExtension |>.toString 20 | -- Output Bitcode 21 | mod.writeBitcodeToFile bcFile 22 | -- Compile and Run It 23 | let llc ← IO.Process.spawn { 24 | cmd := "llc" 25 | args := #["-o", asmFile, bcFile] 26 | env := #[("LD_PRELOAD","")] 27 | } 28 | let exitCode ← llc.wait 29 | unless exitCode == 0 do 30 | throw <| IO.userError s!"llc exited with error code {exitCode}" 31 | let cc ← IO.Process.spawn { 32 | cmd := "cc" 33 | args := #["-no-pie", "-o", exeFile, asmFile] 34 | } 35 | let exitCode ← cc.wait 36 | unless exitCode == 0 do 37 | throw <| IO.userError s!"cc exited with error code {exitCode}" 38 | IO.Process.output {cmd := exeFile} 39 | 40 | -------------------------------------------------------------------------------- 41 | -- # Exiting Program 42 | -------------------------------------------------------------------------------- 43 | 44 | def testSimpleExitingProgram : LlvmM PUnit := do 45 | 46 | -- Construct Module 47 | let exitCode := 101 48 | let mod ← ModuleRef.new "exit" 49 | let intTypeRef ← IntegerTypeRef.get 32 50 | let fnTy ← FunctionTypeRef.get intTypeRef #[] 51 | let fn ← FunctionRef.create fnTy "main" 52 | let bb ← BasicBlockRef.create 53 | let const ← intTypeRef.getConstantInt exitCode 54 | let inst ← ReturnInstRef.create const 55 | bb.appendInstruction inst 56 | fn.appendBasicBlock bb 57 | mod.appendFunction fn 58 | 59 | -- Verify It 60 | discard mod.verify 61 | 62 | -- Run It 63 | let ee ← ExecutionEngineRef.createForModule mod 64 | let ret ← ee.runFunction fn #[] 65 | let exitCode ← ret.toInt 66 | unless exitCode == 101 do 67 | throw <| IO.userError s!"JIT returned exit code {exitCode}" 68 | 69 | -- Output It 70 | let out ← compileAndRunModule mod "exit" 71 | unless out.exitCode == 101 do 72 | throw <| IO.userError s!"program exited with code {out.exitCode}" 73 | 74 | -------------------------------------------------------------------------------- 75 | -- # Hello World Program 76 | -------------------------------------------------------------------------------- 77 | 78 | def testHelloWorldProgram : LlvmM PUnit := do 79 | 80 | -- Construct Module 81 | let mod ← ModuleRef.new "hello" 82 | 83 | -- Initialize Hello String Constant 84 | let hello := "Hello World!" 85 | let helloGbl ← GlobalVariableRef.ofString hello 86 | let intTypeRef ← IntegerTypeRef.get 32 87 | let z ← intTypeRef.getConstantNat 0 88 | let helloPtr ← ConstantExprRef.getGetElementPtr helloGbl #[z, z] true 89 | mod.appendGlobalVariable helloGbl 90 | 91 | -- Declare `printf` function 92 | let stringTypeRef ← PointerTypeRef.get (← IntegerTypeRef.get 8) 93 | let printfFnTy ← FunctionTypeRef.get intTypeRef #[stringTypeRef] true 94 | let printf ← FunctionRef.create printfFnTy "printf" 95 | mod.appendFunction printf 96 | 97 | -- Add Main Function 98 | let mainFnTy ← FunctionTypeRef.get intTypeRef #[] 99 | let main ← FunctionRef.create mainFnTy "main" 100 | mod.appendFunction main 101 | let bb ← BasicBlockRef.create 102 | main.appendBasicBlock bb 103 | let call ← printf.createCall #[helloPtr] 104 | bb.appendInstruction call 105 | let ret ← ReturnInstRef.createUInt32 0 106 | bb.appendInstruction ret 107 | 108 | -- Verify, Compile, and Run Module 109 | discard mod.verify 110 | let out ← compileAndRunModule mod "hello" 111 | unless out.exitCode == 0 do 112 | throw <| IO.userError s!"program exited with code {out.exitCode}" 113 | assertBEq hello out.stdout 114 | 115 | -------------------------------------------------------------------------------- 116 | -- # Runner 117 | -------------------------------------------------------------------------------- 118 | 119 | def main : IO PUnit := do 120 | if (← initNativeTarget) then 121 | throw <| IO.userError "failed to initialize native target" 122 | if (← initNativeAsmPrinter) then 123 | throw <| IO.userError "failed to initialize native asm printer" 124 | 125 | LlvmM.run do 126 | IO.println "Testing exiting program ... " 127 | testSimpleExitingProgram 128 | IO.println "Testing hello world program ... " 129 | testHelloWorldProgram 130 | -------------------------------------------------------------------------------- /test/out/script/dump.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus Script 4 | 5 | -- # Module 6 | 7 | llvm module hello do 8 | declare i8 @printf(i8*, ...) 9 | define i32 @main() do 10 | call @printf("Hello World"*) 11 | ret i32 0 12 | 13 | #dump hello 14 | 15 | -- # Types 16 | 17 | #dump llvm type void 18 | #dump llvm type i32 19 | #dump llvm type i8 (i8*, ...) 20 | #dump llvm type i8 addrspace(5)* 21 | #dump llvm type {i32, float} 22 | #dump llvm type [2 x i8] 23 | #dump llvm type <4 x i64> 24 | #dump llvm type 25 | 26 | -- # Constants 27 | 28 | #dump llvm true 29 | #dump llvm false 30 | #dump llvm i8 255 31 | #dump llvm i32 1 32 | #dump llvm i64 -1 33 | #dump llvm i128 1208925819614629174706188 -- 2^80 + 12 34 | #dump llvm i128 -1208925819614629174706188 35 | -------------------------------------------------------------------------------- /test/out/script/dump.lean.expected.out: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'hello' 2 | source_filename = "hello" 3 | 4 | @0 = private unnamed_addr constant [12 x i8] c"Hello World\00", align 1 5 | 6 | declare i8 @printf(i8* %0, ...) 7 | 8 | define i32 @main() { 9 | %1 = call i8 (i8*, ...) @printf(i8* getelementptr inbounds ([12 x i8], [12 x i8]* @0, i32 0, i32 0)) 10 | ret i32 0 11 | } 12 | void 13 | i32 14 | i8 (i8*, ...) 15 | i8 addrspace(5)* 16 | { i32, float } 17 | [2 x i8] 18 | <4 x i64> 19 | 20 | i1 true 21 | i1 false 22 | i8 -1 23 | i32 1 24 | i64 -1 25 | i128 1208925819614629174706188 26 | i128 -1208925819614629174706188 27 | -------------------------------------------------------------------------------- /test/out/script/jit.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus Script 4 | 5 | llvm module exit do 6 | define i32 @main() do 7 | ret i32 101 8 | 9 | #jit exit 10 | 11 | llvm module echo do 12 | define i32 @main(i32 %argc) do 13 | ret %argc 14 | 15 | #jit echo #["a", "b", "c"] 16 | 17 | llvm module empty do 18 | pure () 19 | 20 | #jit empty -- Error: Module has no main function 21 | -------------------------------------------------------------------------------- /test/out/script/jit.lean.expected.out: -------------------------------------------------------------------------------- 1 | Exited with code 101 2 | Exited with code 3 3 | 4 | out/script/jit.lean:20:0-20:10: error: Module has no main function 5 | -------------------------------------------------------------------------------- /test/out/script/program.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus Script 4 | 5 | llvm module lean_hello do 6 | declare %lean_object* @lean_mk_string(i8*) 7 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object*, %lean_object*) 8 | define i32 @main() do 9 | %hello = call @lean_mk_string("Hello World!"*) 10 | call @l_IO_println___at_Lean_instEval___spec__1(%hello, inttoptr (i32 1 to %lean_object*)) 11 | ret i32 0 12 | 13 | #dump lean_hello 14 | #verify lean_hello 15 | #jit lean_hello 16 | 17 | llvm module lean_echo do 18 | declare %lean_object* @lean_mk_string(i8*) 19 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object*, %lean_object*) 20 | define i32 @main(i32 %argc, i8** %argv) do 21 | %arg1p = getelementptr i8*, %argv, i32 1 22 | %arg1 = load i8*, %arg1p 23 | %arg1s = call @lean_mk_string(%arg1) 24 | call @l_IO_println___at_Lean_instEval___spec__1(%arg1s, inttoptr (i32 1 to %lean_object*)) 25 | ret i32 0 26 | 27 | #dump lean_echo 28 | #verify lean_echo 29 | #jit lean_echo #["a", "b", "c"] 30 | 31 | llvm module lean_select do 32 | declare %lean_object* @lean_mk_string(i8*) 33 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object*, %lean_object*) 34 | define i32 @main(i32 %argc, i8** %argv) do 35 | let realW ← llvm inttoptr (i32 1 to %lean_object*) 36 | br1: 37 | %arg1p = getelementptr i8*, %argv, i32 1 38 | %arg1 = load i8*, %arg1p 39 | %arg1s = call @lean_mk_string(%arg1) 40 | call @l_IO_println___at_Lean_instEval___spec__1(%arg1s, realW) 41 | ret i32 0 42 | br2: 43 | %arg2p = getelementptr i8*, %argv, i32 2 44 | %arg2 = load i8*, %arg2p 45 | %arg2s = call @lean_mk_string(%arg2) 46 | call @l_IO_println___at_Lean_instEval___spec__1(%arg2s, realW) 47 | ret i32 0; 48 | %arg0 = load i8*, %argv 49 | %arg0c = load i1, %arg0 50 | br %arg0c, %br1, %br2 51 | 52 | #dump lean_select 53 | #verify lean_select 54 | #jit lean_select #["some", "b", "c"] 55 | #jit lean_select #["\x00", "b", "c"] 56 | -------------------------------------------------------------------------------- /test/out/script/program.lean.expected.out: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'lean_hello' 2 | source_filename = "lean_hello" 3 | 4 | %lean_object = type opaque 5 | 6 | @0 = private unnamed_addr constant [13 x i8] c"Hello World!\00", align 1 7 | 8 | declare %lean_object* @lean_mk_string(i8* %0) 9 | 10 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %0, %lean_object* %1) 11 | 12 | define i32 @main() { 13 | %hello = call %lean_object* @lean_mk_string(i8* getelementptr inbounds ([13 x i8], [13 x i8]* @0, i32 0, i32 0)) 14 | %1 = call %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %hello, %lean_object* inttoptr (i32 1 to %lean_object*)) 15 | ret i32 0 16 | } 17 | 18 | Hello World! 19 | Exited with code 0 20 | ; ModuleID = 'lean_echo' 21 | source_filename = "lean_echo" 22 | 23 | %lean_object = type opaque 24 | 25 | declare %lean_object* @lean_mk_string(i8* %0) 26 | 27 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %0, %lean_object* %1) 28 | 29 | define i32 @main(i32 %argc, i8** %argv) { 30 | %arg1p = getelementptr i8*, i8** %argv, i32 1 31 | %arg1 = load i8*, i8** %arg1p, align 1 32 | %arg1s = call %lean_object* @lean_mk_string(i8* %arg1) 33 | %1 = call %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %arg1s, %lean_object* inttoptr (i32 1 to %lean_object*)) 34 | ret i32 0 35 | } 36 | 37 | b 38 | Exited with code 0 39 | ; ModuleID = 'lean_select' 40 | source_filename = "lean_select" 41 | 42 | %lean_object = type opaque 43 | 44 | declare %lean_object* @lean_mk_string(i8* %0) 45 | 46 | declare %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %0, %lean_object* %1) 47 | 48 | define i32 @main(i32 %argc, i8** %argv) { 49 | %arg0 = load i8*, i8** %argv, align 1 50 | %arg0c = load i1, i8* %arg0, align 1 51 | br i1 %arg0c, label %br1, label %br2 52 | 53 | br1: ; preds = %0 54 | %arg1p = getelementptr i8*, i8** %argv, i32 1 55 | %arg1 = load i8*, i8** %arg1p, align 1 56 | %arg1s = call %lean_object* @lean_mk_string(i8* %arg1) 57 | %1 = call %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %arg1s, %lean_object* inttoptr (i32 1 to %lean_object*)) 58 | ret i32 0 59 | 60 | br2: ; preds = %0 61 | %arg2p = getelementptr i8*, i8** %argv, i32 2 62 | %arg2 = load i8*, i8** %arg2p, align 1 63 | %arg2s = call %lean_object* @lean_mk_string(i8* %arg2) 64 | %2 = call %lean_object* @l_IO_println___at_Lean_instEval___spec__1(%lean_object* %arg2s, %lean_object* inttoptr (i32 1 to %lean_object*)) 65 | ret i32 0 66 | } 67 | 68 | b 69 | Exited with code 0 70 | c 71 | Exited with code 0 72 | -------------------------------------------------------------------------------- /test/out/script/type.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Script.Type 2 | 3 | open Papyrus Script 4 | 5 | -- # Floating Point Types 6 | 7 | #check llvm type half 8 | #check llvm type bfloat 9 | #check llvm type float 10 | #check llvm type double 11 | #check llvm type x86_fp80 12 | #check llvm type fp128 13 | #check llvm type ppc_fp128 14 | 15 | -- # Special Types 16 | 17 | #check llvm type void 18 | #check llvm type label 19 | #check llvm type metadata 20 | #check llvm type x86_mmx 21 | #check llvm type x86_amx 22 | #check llvm type token 23 | 24 | -- # Integer Types 25 | 26 | #check i1 27 | #check i32 28 | #check i1942652 29 | 30 | #check llvm type i1 31 | #check llvm type i32 32 | #check llvm type i1942652 33 | 34 | -- # Function Types 35 | 36 | #check llvm type i32 (i32) 37 | #check llvm type float (i16, i32 *) * 38 | #check llvm type i32 (i8*, ...) 39 | #check llvm type {i32, i32} (i32) 40 | 41 | -- # Pointer Types 42 | 43 | #check i8* 44 | 45 | #check llvm type i8* 46 | #check llvm type [4 x i32]* 47 | #check llvm type i32 (i32*) * 48 | #check llvm type i32 addrspace(5) * 49 | 50 | -- # (Literal) Struct Types 51 | 52 | #check llvm type { i32, i32, i32 } 53 | #check llvm type { float, i32 (i32) * } 54 | #check llvm type <{ i8, i32 }> 55 | 56 | -- # Array Types 57 | 58 | #check llvm type [40 x i32] 59 | #check llvm type [41 x i32] 60 | #check llvm type [4 x i8] 61 | 62 | #check llvm type [3 x [4 x i32]] 63 | #check llvm type [12 x [10 x float]] 64 | #check llvm type [2 x [3 x [4 x i16]]] 65 | 66 | -- # Vector Types 67 | 68 | #check llvm type <4 x i32> 69 | #check llvm type <8 x float> 70 | #check llvm type <2 x i64> 71 | #check llvm type < 4 x i64* > 72 | #check llvm type 73 | 74 | -- # Nested Terms 75 | 76 | #check llvm type [4 × type(int8Type)] 77 | #check llvm type { type(int8Type), type(floatType) } 78 | 79 | -- #check llvm type <4 x i64*> -- fails: `*>` is a separate token 80 | 81 | -- #check llvm type %X 82 | -- #check llvm type %T1 { i32, i32, i32 } 83 | -- #check llvm type %T2 <{ i8, i32 }> 84 | -------------------------------------------------------------------------------- /test/out/script/type.lean.expected.out: -------------------------------------------------------------------------------- 1 | halfType : Type 2 | bfloatType : Type 3 | floatType : Type 4 | doubleType : Type 5 | x86FP80Type : Type 6 | fp128Type : Type 7 | ppcFP128Type : Type 8 | voidType : Type 9 | labelType : Type 10 | metadataType : Type 11 | x86MMXType : Type 12 | x86AMXType : Type 13 | tokenType : Type 14 | integerType 1 : IntegerType 15 | integerType 32 : IntegerType 16 | integerType 1942652 : IntegerType 17 | integerType 1 : IntegerType 18 | integerType 32 : IntegerType 19 | integerType 1942652 : IntegerType 20 | functionType (Type.integer (integerType 32)) #[Type.integer (integerType 32)] : FunctionType 21 | (Type.function 22 | (functionType floatType 23 | #[Type.integer (integerType 16), Type.pointer (Type.integer (integerType 32))*]))* : PointerType 24 | functionType (Type.integer (integerType 32)) #[Type.pointer (Type.integer (integerType 8))*] true : FunctionType 25 | functionType (Type.struct (literalStructType #[Type.integer (integerType 32), Type.integer (integerType 32)])) 26 | #[Type.integer (integerType 32)] : FunctionType 27 | (Type.integer (integerType 8))* : PointerType 28 | (Type.integer (integerType 8))* : PointerType 29 | (Type.array (arrayType (Type.integer (integerType 32)) 4))* : PointerType 30 | (Type.function 31 | (functionType (Type.integer (integerType 32)) #[Type.pointer (Type.integer (integerType 32))*]))* : PointerType 32 | pointerType (Type.integer (integerType 32)) 5 : PointerType 33 | literalStructType 34 | #[Type.integer (integerType 32), Type.integer (integerType 32), Type.integer (integerType 32)] : StructType 35 | literalStructType 36 | #[floatType, 37 | Type.pointer 38 | (Type.function (functionType (Type.integer (integerType 32)) #[Type.integer (integerType 32)]))*] : StructType 39 | literalStructType #[Type.integer (integerType 8), Type.integer (integerType 32)] true : StructType 40 | arrayType (Type.integer (integerType 32)) 40 : ArrayType 41 | arrayType (Type.integer (integerType 32)) 41 : ArrayType 42 | arrayType (Type.integer (integerType 8)) 4 : ArrayType 43 | arrayType (Type.array (arrayType (Type.integer (integerType 32)) 4)) 3 : ArrayType 44 | arrayType (Type.array (arrayType floatType 10)) 12 : ArrayType 45 | arrayType (Type.array (arrayType (Type.array (arrayType (Type.integer (integerType 16)) 4)) 3)) 2 : ArrayType 46 | fixedVectorType (Type.integer (integerType 32)) 4 : FixedVectorType 47 | fixedVectorType floatType 8 : FixedVectorType 48 | fixedVectorType (Type.integer (integerType 64)) 2 : FixedVectorType 49 | fixedVectorType (Type.pointer (Type.integer (integerType 64))*) 4 : FixedVectorType 50 | scalableVectorType (Type.integer (integerType 32)) 4 : ScalableVectorType 51 | arrayType (Type.integer int8Type) 4 : ArrayType 52 | literalStructType #[Type.integer int8Type, floatType] : StructType 53 | -------------------------------------------------------------------------------- /test/out/script/value.lean: -------------------------------------------------------------------------------- 1 | import Papyrus.Script.Value 2 | 3 | open Papyrus Script 4 | 5 | #check show ModuleM PUnit from do 6 | let x ← llvm false 7 | let x ← llvm true 8 | let x ← llvm i32 0 9 | let x ← llvm i64 -1 10 | let x ← llvm "hello"* 11 | let x ← llvm "hello" addrspace(5) * 12 | let x ← llvm %x 13 | pure () 14 | -------------------------------------------------------------------------------- /test/out/script/value.lean.expected.out: -------------------------------------------------------------------------------- 1 | let_fun this := 2 | do 3 | let _ ← liftM ConstantIntRef.getFalse 4 | let _ ← liftM ConstantIntRef.getTrue 5 | let _ ← liftM (ConstantIntRef.ofNat 32 0) 6 | let _ ← liftM (ConstantIntRef.ofInt 64 (-1)) 7 | let _ ← Builder.stringPtr "hello" AddressSpace.default true "" 8 | let x ← Builder.stringPtr "hello" 5 true "" 9 | let _ ← pure x 10 | pure (); 11 | this : ModuleM PUnit 12 | -------------------------------------------------------------------------------- /test/out/script/verify.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | open Papyrus Script 3 | 4 | llvm module foo do 5 | define i32 @main() do 6 | ret i32 0 7 | 8 | #verify foo 9 | #verify foo >>= (·.getFunction "main") 10 | 11 | llvm module bug do 12 | define i32 @main() do 13 | ret i8 0 14 | 15 | #verify bug -- Error: Function return type does not match operand 16 | #verify bug >>= (·.getFunction "main") -- Same Error 17 | -------------------------------------------------------------------------------- /test/out/script/verify.lean.expected.out: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | out/script/verify.lean:15:0-15:11: error: Function return type does not match operand type of return inst! 5 | ret i8 0 6 | i32 7 | 8 | out/script/verify.lean:16:0-16:38: error: Function return type does not match operand type of return inst! 9 | ret i8 0 10 | i32 11 | -------------------------------------------------------------------------------- /test/run/ir/basicBlockRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def assertEq [Repr α] [DecidableEq α] 6 | (expected actual : α) : IO (PLift (expected = actual)) := do 7 | if h : expected = actual then return PLift.up h else 8 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 9 | 10 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 11 | unless expected == actual do 12 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 13 | 14 | -- simple test 15 | #eval LlvmM.run do 16 | let name := "foo" 17 | let bb ← BasicBlockRef.create name 18 | assertBEq ValueKind.basicBlock bb.valueKind 19 | let actualName ← bb.getName 20 | assertBEq name actualName 21 | let inst ← ReturnInstRef.createVoid 22 | bb.appendInstruction inst 23 | let is ← bb.getInstructions 24 | if h : is.size = 1 then 25 | let inst ← is.get (Fin.mk 0 (by simp [h])) 26 | let ⟨h⟩ ← assertEq InstructionKind.ret inst.instructionKind 27 | let inst := ReturnInstRef.castInst inst h.symm 28 | unless (← inst.getReturnValue).isNone do 29 | throw <| IO.userError "got return value when expecting none" 30 | else 31 | throw <| IO.userError s!"expected 1 instruction in basic block, got {is.size}" 32 | -------------------------------------------------------------------------------- /test/run/ir/constantRefs.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def assertEq [Repr α] [DecidableEq α] 6 | (expected actual : α) : IO (PLift (expected = actual)) := do 7 | if h : expected = actual then return PLift.up h else 8 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 9 | 10 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 11 | unless expected == actual do 12 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 13 | 14 | -- null ptr constant 15 | #eval LlvmM.run do 16 | let const ← (← int8Type.pointerType.getRef).getNullConstant 17 | assertBEq ValueKind.constantPointerNull const.valueKind 18 | 19 | -- null token constant 20 | #eval LlvmM.run do 21 | let const ← (← tokenType.getRef).getNullConstant 22 | assertBEq ValueKind.constantTokenNone const.valueKind 23 | 24 | -- "big" null integer constant 25 | #eval LlvmM.run do 26 | let int128TypeRef ← IntegerTypeRef.get 128 27 | let const ← int128TypeRef.getNullConstant 28 | let ⟨h⟩ ← assertEq ValueKind.constantInt const.valueKind 29 | let const := ConstantIntRef.cast const h.symm 30 | assertBEq 0 (← const.getNatValue) 31 | assertBEq 0 (← const.getIntValue) 32 | 33 | -- small positive integer constant 34 | #eval LlvmM.run do 35 | let val := 32 36 | let int8TypeRef ← IntegerTypeRef.get 8 37 | let const ← int8TypeRef.getConstantInt val 38 | assertBEq val (← const.getNatValue) 39 | assertBEq val (← const.getIntValue) 40 | 41 | -- small negative integer constant 42 | #eval LlvmM.run do 43 | let absVal := 32; let intVal := -32 44 | let int8TypeRef ← IntegerTypeRef.get 8 45 | let const ← int8TypeRef.getConstantInt intVal 46 | assertBEq (2 ^ 8 - absVal) (← const.getNatValue) 47 | assertBEq intVal (← const.getIntValue) 48 | 49 | -- big positive integer constant 50 | #eval LlvmM.run do 51 | let val : Nat := 2 ^ 80 + 12 52 | let int128TypeRef ← IntegerTypeRef.get 128 53 | let const ← int128TypeRef.getConstantInt val 54 | assertBEq (Int.ofNat val) (← const.getIntValue) 55 | assertBEq val (← const.getNatValue) 56 | 57 | -- big negative integer constant 58 | #eval LlvmM.run do 59 | let absVal := 2 ^ 80 + 12 60 | let intVal := -(Int.ofNat absVal) 61 | let int128TypeRef ← IntegerTypeRef.get 128 62 | let const ← int128TypeRef.getConstantInt intVal 63 | assertBEq (Int.ofNat (2 ^ 128) - absVal) (← const.getNatValue) 64 | assertBEq intVal (← const.getIntValue) 65 | 66 | -- big all ones integer constant 67 | #eval LlvmM.run do 68 | let int128TypeRef ← IntegerTypeRef.get 128 69 | let const ← int128TypeRef.getAllOnesConstant 70 | let ⟨h⟩ ← assertEq ValueKind.constantInt const.valueKind 71 | let const := ConstantIntRef.cast const h.symm 72 | assertBEq (2 ^ 128 - 1) (← const.getNatValue) 73 | assertBEq (-1) (← const.getIntValue) 74 | 75 | -- `inttoptr`/`ptrtoint` constant 76 | #eval LlvmM.run do 77 | let ity ← int64Type.getRef 78 | let pty ← PointerTypeRef.get ity 79 | let cst ← ConstantIntRef.ofUInt64 1 80 | let itp ← ConstantExprRef.getIntToPtr cst pty 81 | let pti ← ConstantExprRef.getPtrToInt itp ity 82 | assertBEq TypeID.pointer (← (← itp.getType).typeID) 83 | assertBEq TypeID.integer (← (← pti.getType).typeID) 84 | -------------------------------------------------------------------------------- /test/run/ir/functionRef.lean: -------------------------------------------------------------------------------- 1 | 2 | import Papyrus 3 | 4 | open Papyrus 5 | 6 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 7 | unless expected == actual do 8 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 9 | 10 | -- empty function 11 | #eval LlvmM.run do 12 | let name := "foo" 13 | let voidTypeRef ← VoidTypeRef.get 14 | let fnTy ← FunctionTypeRef.get voidTypeRef #[] 15 | let fn ← FunctionRef.create fnTy name 16 | assertBEq name (← fn.getName) 17 | assertBEq ValueKind.function fn.valueKind 18 | assertBEq Linkage.external (← fn.getLinkage) 19 | assertBEq Visibility.default (← fn.getVisibility) 20 | assertBEq DLLStorageClass.default (← fn.getDLLStorageClass) 21 | assertBEq ThreadLocalMode.notLocal (← fn.getThreadLocalMode) 22 | assertBEq AddressSignificance.total (← fn.getAddressSignificance) 23 | assertBEq AddressSpace.default (← fn.getAddressSpace) 24 | assertBEq CallingConvention.c (← fn.getCallingConvention) 25 | assertBEq 0 (← fn.getRawAlignment) 26 | assertBEq false (← fn.hasSection) 27 | assertBEq false (← fn.hasGC) 28 | 29 | -- single block function 30 | #eval LlvmM.run do 31 | let bbName := "foo" 32 | let voidTypeRef ← VoidTypeRef.get 33 | let fnTy ← FunctionTypeRef.get voidTypeRef #[] 34 | let fn ← FunctionRef.create fnTy "test" 35 | let bb ← BasicBlockRef.create bbName 36 | fn.appendBasicBlock bb 37 | let bbs ← fn.getBasicBlocks 38 | if h : bbs.size = 1 then 39 | let bb ← bbs.get (Fin.mk 0 (by simp [h])) 40 | assertBEq bbName (← bb.getName) 41 | else 42 | throw <| IO.userError s!"expected 1 basic block in function, got {bbs.size}" 43 | -------------------------------------------------------------------------------- /test/run/ir/globalVariableRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def assertEq [Repr α] [DecidableEq α] 6 | (expected actual : α) : IO (PLift (expected = actual)) := do 7 | if h : expected = actual then return PLift.up h else 8 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 9 | 10 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 11 | unless expected == actual do 12 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 13 | 14 | -- global string constant 15 | #eval LlvmM.run do 16 | let str := "foo" 17 | let name := "myConst" 18 | let gbl ← GlobalVariableRef.ofString str (withNull := false) (name := name) 19 | assertBEq name (← gbl.getName) 20 | assertBEq ValueKind.globalVariable gbl.valueKind 21 | assertBEq Linkage.private (← gbl.getLinkage) 22 | assertBEq Visibility.default (← gbl.getVisibility) 23 | assertBEq DLLStorageClass.default (← gbl.getDLLStorageClass) 24 | assertBEq ThreadLocalMode.notLocal (← gbl.getThreadLocalMode) 25 | assertBEq AddressSignificance.none (← gbl.getAddressSignificance) 26 | assertBEq AddressSpace.default (← gbl.getAddressSpace) 27 | assertBEq true (← gbl.hasInitializer) 28 | let init ← gbl.getInitializer 29 | let ⟨h⟩ ← assertEq ValueKind.constantDataArray init.valueKind 30 | let init := ConstantDataArrayRef.cast init h.symm 31 | assertBEq true (← init.isString) 32 | assertBEq str (← init.getAsString) 33 | assertBEq 1 (← gbl.getRawAlignment) 34 | assertBEq false (← gbl.hasSection) 35 | -------------------------------------------------------------------------------- /test/run/ir/instructionRefs.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def assertEq [Repr α] [DecidableEq α] 6 | (expected actual : α) : IO (PLift (expected = actual)) := do 7 | if h : expected = actual then return PLift.up h else 8 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 9 | 10 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 11 | unless expected == actual do 12 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 13 | 14 | -- void `ret` 15 | #eval LlvmM.run do 16 | let inst ← ReturnInstRef.createVoid 17 | assertBEq ValueKind.instruction inst.valueKind 18 | assertBEq InstructionKind.ret inst.instructionKind 19 | unless (← inst.getReturnValue).isNone do 20 | throw <| IO.userError "got return value when expecting none" 21 | 22 | -- non-void `ret` 23 | #eval LlvmM.run do 24 | let val := 1 25 | let intTypeRef ← IntegerTypeRef.get 32 26 | let const ← intTypeRef.getConstantInt val 27 | let inst ← ReturnInstRef.create const 28 | assertBEq ValueKind.instruction inst.valueKind 29 | assertBEq InstructionKind.ret inst.instructionKind 30 | let some retVal ← inst.getReturnValue 31 | | throw <| IO.userError "got unexpected void return" 32 | let ⟨h⟩ ← assertEq ValueKind.constantInt retVal.valueKind 33 | let retVal := ConstantIntRef.cast retVal h.symm 34 | let retInt ← ConstantIntRef.getIntValue retVal 35 | assertBEq val retInt 36 | 37 | -- conditional `br` 38 | #eval LlvmM.run do 39 | let name0 := "foo" 40 | let name1 := "bar" 41 | let bb0 ← BasicBlockRef.create name0 42 | let bb1 ← BasicBlockRef.create name1 43 | let inst ← CondBrInstRef.create bb0 bb1 (← ConstantIntRef.ofBool true) 44 | assertBEq ValueKind.instruction inst.valueKind 45 | assertBEq InstructionKind.branch inst.instructionKind 46 | assertBEq true inst.isConditional 47 | let cond ← inst.getCondition 48 | let ⟨h⟩ ← assertEq ValueKind.constantInt cond.valueKind 49 | let cond := ConstantIntRef.cast cond h.symm 50 | assertBEq 1 (← cond.getNatValue) 51 | let succ0 ← inst.getIfTrue 52 | assertBEq name0 (← succ0.getName) 53 | let succ1 ← inst.getIfFalse 54 | assertBEq name1 (← succ1.getName) 55 | 56 | -- unconditional `br` 57 | #eval LlvmM.run do 58 | let name := "foo" 59 | let bb ← BasicBlockRef.create name 60 | let inst ← BrInstRef.create bb 61 | assertBEq ValueKind.instruction inst.valueKind 62 | assertBEq InstructionKind.branch inst.instructionKind 63 | assertBEq false inst.isConditional 64 | let succ ← inst.getSuccessor 65 | assertBEq name (← succ.getName) 66 | 67 | -- simple `load` 68 | #eval LlvmM.run do 69 | let i64Ty ← int64Type.getRef 70 | let i64pTy ← PointerTypeRef.get i64Ty 71 | let nullptr ← i64pTy.getNullConstant 72 | let inst ← LoadInstRef.create i64Ty nullptr 73 | assertBEq ValueKind.instruction inst.valueKind 74 | assertBEq InstructionKind.load inst.instructionKind 75 | let op ← inst.getPointerOperand 76 | assertBEq ValueKind.constantPointerNull op.valueKind 77 | assertBEq false (← inst.getVolatile) 78 | assertBEq 1 (← inst.getAlign) 79 | assertBEq AtomicOrdering.notAtomic (← inst.getOrdering) 80 | assertBEq SyncScopeID.system (← inst.getSyncScopeID) 81 | 82 | -- simple `store` 83 | #eval LlvmM.run do 84 | let n ← ConstantIntRef.ofUInt64 1 85 | let i64pTy ← int64Type.pointerType.getRef 86 | let nullptr ← i64pTy.getNullConstant 87 | let inst ← StoreInstRef.create n nullptr 88 | assertBEq ValueKind.instruction inst.valueKind 89 | assertBEq InstructionKind.store inst.instructionKind 90 | let op ← inst.getValueOperand 91 | let ⟨h⟩ ← assertEq ValueKind.constantInt op.valueKind 92 | let op := ConstantIntRef.cast op h.symm 93 | assertBEq 1 (← op.getNatValue) 94 | let op ← inst.getPointerOperand 95 | assertBEq ValueKind.constantPointerNull op.valueKind 96 | assertBEq false (← inst.getVolatile) 97 | assertBEq 1 (← inst.getAlign) 98 | assertBEq AtomicOrdering.notAtomic (← inst.getOrdering) 99 | assertBEq SyncScopeID.system (← inst.getSyncScopeID) 100 | 101 | -- simple GEP 102 | #eval LlvmM.run do 103 | let i8Ty ← int8Type.getRef 104 | let i8pTy ← int8Type.pointerType.getRef 105 | let nullptr ← i8pTy.getNullConstant 106 | let idxTy ← int64Type.getRef 107 | let idx1 ← idxTy.getConstantNat 1 108 | let inst ← GetElementPtrInstRef.create i8Ty nullptr #[idx1] 109 | assertBEq ValueKind.instruction inst.valueKind 110 | assertBEq InstructionKind.getElementPtr inst.instructionKind 111 | assertBEq false (← inst.getInbounds) 112 | inst.setInbounds 113 | assertBEq true (← inst.getInbounds) 114 | let op ← inst.getPointerOperand 115 | assertBEq ValueKind.constantPointerNull op.valueKind 116 | let indices ← inst.getIndices 117 | if h : 0 < indices.size then 118 | let idx ← indices.get ⟨0, h⟩ 119 | let ⟨h⟩ ← assertEq ValueKind.constantInt idx.valueKind 120 | let idx := ConstantIntRef.cast idx h.symm 121 | assertBEq 1 (← idx.getNatValue) 122 | else 123 | throw <| IO.userError "unexpected empty array" 124 | 125 | -- simple `call` 126 | #eval LlvmM.run do 127 | let fnTy ← functionType voidType #[] |>.getRef 128 | let fn ← FunctionRef.create fnTy 129 | let inst ← CallInstRef.create fnTy fn #[] 130 | assertBEq ValueKind.instruction inst.valueKind 131 | assertBEq InstructionKind.call inst.instructionKind 132 | -------------------------------------------------------------------------------- /test/run/ir/moduleRef.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def assertBEq [Repr α] [BEq α] (expected actual : α) : IO PUnit := do 6 | unless expected == actual do 7 | throw <| IO.userError s!"expected '{repr expected}', got '{repr actual}'" 8 | 9 | -- module renaming 10 | #eval LlvmM.run do 11 | let name1 := "foo" 12 | let mod ← ModuleRef.new name1 13 | assertBEq name1 (← mod.getModuleID) 14 | let name2 := "bar" 15 | mod.setModuleID name2 16 | assertBEq name2 (← mod.getModuleID) 17 | 18 | -- single function module 19 | #eval LlvmM.run do 20 | let fnName := "foo" 21 | let mod ← ModuleRef.new "test" 22 | let voidTypeRef ← VoidTypeRef.get 23 | let fnTy ← FunctionTypeRef.get voidTypeRef #[] 24 | let fn ← FunctionRef.create fnTy fnName 25 | mod.appendFunction fn 26 | let fns ← mod.getFunctions 27 | if h : fns.size = 1 then 28 | let fn : FunctionRef ← fns.get (Fin.mk 0 (by simp [h])) 29 | assertBEq fnName (← fn.getName) 30 | else 31 | throw <| IO.userError s!"expected 1 function in module, got {fns.size}" 32 | -------------------------------------------------------------------------------- /test/run/ir/types.lean: -------------------------------------------------------------------------------- 1 | import Papyrus 2 | 3 | open Papyrus 4 | 5 | def checkTypeRoundtrips (type : «Type») : IO PUnit := 6 | LlvmM.run do 7 | let ref ← type.getRef 8 | let actual ← ref.purify 9 | unless type == actual do 10 | ref.dump 11 | IO.println s!"expected {repr type}, got {repr actual}" 12 | throw <| IO.userError "did not round trip" 13 | 14 | macro tk:"#check_type" x:term : command => do 15 | Script.mkEvalAt tk <| ← ``(checkTypeRoundtrips $x) 16 | 17 | #check_type voidType 18 | #check_type labelType 19 | #check_type metadataType 20 | #check_type tokenType 21 | #check_type x86MMXType 22 | #check_type x86AMXType 23 | 24 | #check_type halfType 25 | #check_type bfloatType 26 | #check_type floatType 27 | #check_type doubleType 28 | #check_type x86FP80Type 29 | #check_type fp128Type 30 | #check_type ppcFP128Type 31 | 32 | #check_type integerType 100 33 | #check_type functionType voidType #[int8Type.pointerType] true 34 | #check_type pointerType fp128Type 35 | #check_type structType "foo" #[integerType 24] true 36 | #check_type arrayType halfType 6 37 | #check_type vectorType int32Type 4 true 38 | #check_type fixedVectorType doubleType 8 39 | #check_type scalableVectorType int1Type 16 40 | -------------------------------------------------------------------------------- /test/test_main.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | source ${BASH_SOURCE%/*}/common.sh 3 | 4 | exec_check lean ${LEAN_OPTS} --run -j 0 "$f" 5 | -------------------------------------------------------------------------------- /test/test_out.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | source ${BASH_SOURCE%/*}/common.sh 3 | 4 | # these tests don't have to succeed 5 | exec_capture lean ${LEAN_OPTS} -DprintMessageEndPos=true "$f" || true 6 | diff_produced 7 | -------------------------------------------------------------------------------- /test/test_run.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | source ${BASH_SOURCE%/*}/common.sh 3 | 4 | exec_check lean ${LEAN_OPTS} -j 0 "$f" 5 | --------------------------------------------------------------------------------