├── .gitignore ├── GUI ├── lib │ ├── functionaljava-4.6.jar │ ├── guava-19.0-javadoc.jar │ ├── guava-19.0-sources.jar │ ├── guava-19.0.jar │ ├── javatuples-1.2.jar │ ├── jgraph-5.13.0.0.jar │ ├── jgrapht-core-1.0.1.jar │ ├── jgrapht-ext-1.0.1.jar │ ├── jgraphx-1.10.1.3.jar │ ├── jgraphx-3.4.1.3.jar │ ├── json-simple-1.1.1.jar │ ├── reactive-streams-1.0.0.jar │ ├── rsyntaxtextarea-2.6.1-javadoc.jar │ ├── rsyntaxtextarea-2.6.1-sources.jar │ ├── rsyntaxtextarea-2.6.1.jar │ ├── rxjava-2.0.0-RC3-javadoc.jar │ ├── rxjava-2.0.0-RC3-sources.jar │ ├── rxjava-2.0.0-RC3.jar │ ├── rxswing-0.27.0-javadoc.jar │ ├── rxswing-0.27.0-sources.jar │ ├── rxswing-0.27.0.jar │ └── shimaging.jar ├── llvm-jvm-frontend.jar └── opt-passes.json ├── LICENSE ├── LLVM-JVM.cabal ├── LLVMFrontend ├── CFG.hs ├── Helpers.hs └── MkGraph.hs ├── Main.hs ├── MateVMRuntime ├── BlockAllocation.hs ├── ClassHierarchy.hi-boot ├── ClassHierarchy.hs ├── ClassHierarchy.hs-boot ├── ClassHierarchy.o-boot ├── ClassPool.hs ├── Debug.hs ├── GC.hs ├── GarbageAlloc.hi-boot ├── GarbageAlloc.hs ├── GarbageAlloc.hs-boot ├── GarbageAlloc.o-boot ├── GarbageAlloc_stub.h ├── GenerationalGC.hs ├── JavaObjects.hs ├── JavaObjectsGC.hs ├── JavaObjects_stub.h ├── MemoryManager.hs ├── MethodPool.hi-boot ├── MethodPool.hs ├── MethodPool.hs-boot ├── MethodPool.o-boot ├── MockBlockAllocation.hs ├── NativeMethods.hs ├── NativeMethods_stub.h ├── NativeSizes.hs ├── README.md ├── RtsOptions.hs ├── StackTrace.hs ├── TwoSpaceAllocator.hs ├── Types.hs └── Utilities.hs ├── Misc └── Logger.hs ├── README.md ├── Report.pdf ├── Test.bash ├── Unit ├── Arithmetic │ ├── DoubleArithmetic.good │ ├── DoubleArithmetic.java │ ├── DoubleArithmetic.skip │ ├── FloatArithmetic.good │ ├── FloatArithmetic.java │ ├── IntegerArithmetic.good │ ├── IntegerArithmetic.java │ ├── LongArithmetic.good │ ├── LongArithmetic.java │ └── LongArithmetic.skip └── Basic │ ├── Addition.java │ ├── bitcode │ ├── bitcode.bc │ ├── cfg.main.dot │ ├── opt │ ├── optimizedIR.bc │ ├── optimizedIR.ll │ ├── out.dot │ ├── out.png │ └── unoptimizedIR.ll ├── llvm-jvm.pptx └── rt └── java ├── io ├── PrintStream.class └── PrintStream.java └── lang ├── ArithmeticException.class ├── ArithmeticException.java ├── Character.class ├── Character.java ├── Exception.class ├── Exception.java ├── IllegalArgumentException.class ├── IllegalArgumentException.java ├── Integer.class ├── Integer.java ├── NullPointerException.class ├── NullPointerException.java ├── Object.class ├── RuntimeException.class ├── RuntimeException.java ├── String.class ├── String.java ├── System.class ├── System.java ├── Throwable.class └── Throwable.java /.gitignore: -------------------------------------------------------------------------------- 1 | Documentation/ 2 | *.hi 3 | *.o 4 | *.dyn_hi* 5 | *.dyn_o* 6 | *.log 7 | *.h 8 | *.hi-boot 9 | *.exe 10 | Main 11 | dist/* 12 | -------------------------------------------------------------------------------- /GUI/lib/functionaljava-4.6.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/functionaljava-4.6.jar -------------------------------------------------------------------------------- /GUI/lib/guava-19.0-javadoc.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/guava-19.0-javadoc.jar -------------------------------------------------------------------------------- /GUI/lib/guava-19.0-sources.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/guava-19.0-sources.jar -------------------------------------------------------------------------------- /GUI/lib/guava-19.0.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/guava-19.0.jar -------------------------------------------------------------------------------- /GUI/lib/javatuples-1.2.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/javatuples-1.2.jar -------------------------------------------------------------------------------- /GUI/lib/jgraph-5.13.0.0.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/jgraph-5.13.0.0.jar -------------------------------------------------------------------------------- /GUI/lib/jgrapht-core-1.0.1.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/jgrapht-core-1.0.1.jar -------------------------------------------------------------------------------- /GUI/lib/jgrapht-ext-1.0.1.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/jgrapht-ext-1.0.1.jar -------------------------------------------------------------------------------- /GUI/lib/jgraphx-1.10.1.3.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/jgraphx-1.10.1.3.jar -------------------------------------------------------------------------------- /GUI/lib/jgraphx-3.4.1.3.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/jgraphx-3.4.1.3.jar -------------------------------------------------------------------------------- /GUI/lib/json-simple-1.1.1.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/json-simple-1.1.1.jar -------------------------------------------------------------------------------- /GUI/lib/reactive-streams-1.0.0.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/reactive-streams-1.0.0.jar -------------------------------------------------------------------------------- /GUI/lib/rsyntaxtextarea-2.6.1-javadoc.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rsyntaxtextarea-2.6.1-javadoc.jar -------------------------------------------------------------------------------- /GUI/lib/rsyntaxtextarea-2.6.1-sources.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rsyntaxtextarea-2.6.1-sources.jar -------------------------------------------------------------------------------- /GUI/lib/rsyntaxtextarea-2.6.1.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rsyntaxtextarea-2.6.1.jar -------------------------------------------------------------------------------- /GUI/lib/rxjava-2.0.0-RC3-javadoc.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxjava-2.0.0-RC3-javadoc.jar -------------------------------------------------------------------------------- /GUI/lib/rxjava-2.0.0-RC3-sources.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxjava-2.0.0-RC3-sources.jar -------------------------------------------------------------------------------- /GUI/lib/rxjava-2.0.0-RC3.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxjava-2.0.0-RC3.jar -------------------------------------------------------------------------------- /GUI/lib/rxswing-0.27.0-javadoc.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxswing-0.27.0-javadoc.jar -------------------------------------------------------------------------------- /GUI/lib/rxswing-0.27.0-sources.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxswing-0.27.0-sources.jar -------------------------------------------------------------------------------- /GUI/lib/rxswing-0.27.0.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/rxswing-0.27.0.jar -------------------------------------------------------------------------------- /GUI/lib/shimaging.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/lib/shimaging.jar -------------------------------------------------------------------------------- /GUI/llvm-jvm-frontend.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/GUI/llvm-jvm-frontend.jar -------------------------------------------------------------------------------- /GUI/opt-passes.json: -------------------------------------------------------------------------------- 1 | { 2 | "constmerge": "Merge Duplicate Global Constants", 3 | "tailcallelim": "Tail Call Elimination", 4 | "reg2mem": "Demote all values to stack slots", 5 | "licm": "Loop Invariant Code Motion", 6 | "mergefunc": "Merge Functions", 7 | "loop-simplify": "Canonicalize natural loops", 8 | "ipconstprop": "Interprocedural constant propagation", 9 | "jump-threading": "Jump Threading", 10 | "globaldce": "Dead Global Elimination", 11 | "constprop": "Simple constant propagation", 12 | "strip": "Strip all symbols from a module", 13 | "loop-extract-single": "Extract at most one loop into a new function", 14 | "strip-dead-debug-info": "Strip debug info for unused symbols", 15 | "deadargelim": "Dead Argument Elimination", 16 | "indvars": "Canonicalize Induction Variables", 17 | "memcpyopt": "MemCpy Optimization", 18 | "gvn": "Global Value Numbering", 19 | "functionattrs": "Deduce function attributes", 20 | "strip-dead-prototypes": "Strip Unused Function Prototypes", 21 | "loop-extract": "Extract loops into new functions", 22 | "block-placement": "Profile Guided Basic Block Placement", 23 | "sroa": "Scalar Replacement of Aggregates", 24 | "loop-rotate": "Rotate Loops", 25 | "argpromotion": "Promote \u2018by reference\u2019 arguments to scalars", 26 | "lowerinvoke": "Lower invokes to calls, for unwindless code generators", 27 | "simplifycfg": "Simplify the CFG", 28 | "loop-deletion": "Delete dead loops", 29 | "dse": "Dead Store Elimination", 30 | "strip-debug-declare": "Strip all llvm.dbg.declare intrinsics", 31 | "adce": "Aggressive Dead Code Elimination", 32 | "globalopt": "Global Variable Optimizer", 33 | "dce": "Dead Code Elimination", 34 | "lcssa": "Loop-Closed SSA Form Pass", 35 | "strip-nondebug": "Strip all symbols, except dbg symbols, from a module", 36 | "loop-unswitch": "Unswitch loops", 37 | "lowerswitch": "Lower SwitchInsts to branches", 38 | "loop-reduce": "Loop Strength Reduction", 39 | "sink": "Code sinking", 40 | "codegenprepare": "Optimize for code generation", 41 | "deadtypeelim": "Dead Type Elimination", 42 | "mergereturn": "Unify function exit nodes", 43 | "reassociate": "Reassociate expressions", 44 | "loop-unroll": "Unroll loops", 45 | "ipsccp": "Interprocedural Sparse Conditional Constant Propagation", 46 | "prune-eh": "Remove unused exception handling info", 47 | "instcombine": "Combine redundant instructions", 48 | "die": "Dead Instruction Elimination", 49 | "mem2reg": "Promote Memory to Register", 50 | "always-inline": "Inliner for always_inline functions", 51 | "break-crit-edges": "Break critical edges in CFG", 52 | "sccp": "Sparse Conditional Constant Propagation", 53 | "partial-inliner": "Partial Inliner", 54 | "internalize": "Internalize Global Symbols", 55 | "inline": "Function Integration/Inlining", 56 | "bb-vectorize": "Basic-Block Vectorization", 57 | "loweratomic": "Lower atomic intrinsics to non-atomic form", 58 | "O3" : "Maximum Optimization sequence", 59 | "O2" : "", 60 | "O1" : "", 61 | "O0" : "", 62 | "Os" : "", 63 | "Oz" : "", 64 | "aa-eval" : "", 65 | "basicaa" : "", 66 | "count-aa" : "", 67 | "da" : "", 68 | "domfrontier" : "", 69 | "domtree" : "", 70 | "globalsmodref-aa" : "", 71 | "instcount" : "", 72 | "intervals" : "", 73 | "iv-users" : "", 74 | "lazy-value-info" : "", 75 | "loops" : "", 76 | "memdep" : "", 77 | "postdomfrontier" : "", 78 | "postdomtree" : "", 79 | "regions" : "", 80 | "scalar-evolution" : "", 81 | "scev-aa" : "", 82 | "targetdata" : "" 83 | } 84 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Louis Jenkins 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Louis Jenkins nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /LLVM-JVM.cabal: -------------------------------------------------------------------------------- 1 | -- Initial LLVM-JVM.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: LLVM-JVM 5 | version: 0.1.0.0 6 | synopsis: Just-In-Time JVM to LLVM 7 | -- description: 8 | homepage: https://github.com/LouisJenkinsCS/LLVM-JVM 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Louis Jenkins 12 | maintainer: LouisJenkinsCS@hotmail.com 13 | -- copyright: 14 | -- category: 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md, README.md 17 | cabal-version: >=1.10 18 | 19 | executable LLVM-JVM 20 | main-is: Main.hs 21 | -- other-modules: 22 | other-extensions: OverloadedStrings, FlexibleContexts, GADTs, ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies, ScopedTypeVariables, TemplateHaskell, CPP, GeneralizedNewtypeDeriving 23 | build-depends: base -any, hs-java >=0.3 && <0.4, split -any, bytestring -any, hs-boehmgc -any, binary -any, containers -any, MissingH -any, directory -any, plugins -any, mtl -any, QuickCheck -any, IntervalMap -any, harpy -any, vector -any, lens -any, llvm-hs-pure -any, llvm-hs -any, extra -any 24 | -- hs-source-dirs: 25 | default-language: Haskell2010 26 | -------------------------------------------------------------------------------- /LLVMFrontend/CFG.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module LLVMFrontend.CFG where 4 | import Control.Monad.State 5 | import Control.Lens 6 | import Control.Monad.Extra 7 | 8 | import qualified Data.Vector as Vec 9 | import Data.Vector(Vector) 10 | import qualified Data.ByteString.Lazy as B 11 | 12 | import JVM.ClassFile 13 | import qualified JVM.Assembler as J 14 | import qualified LLVM.AST.Instruction as LI 15 | import qualified LLVM.AST.Global as LG 16 | import qualified LLVM.AST.Constant as LC 17 | import qualified LLVM.AST.Operand as LO 18 | import qualified LLVM.AST.Name as LN 19 | import qualified LLVM.AST.Type as LT 20 | import LLVMFrontend.Helpers 21 | 22 | -- Control-Flow Graph state 23 | data CFGState = CFGState { 24 | basicBlocks :: [LG.BasicBlock], 25 | programCounter :: Int, 26 | instructions :: Vector J.Instruction, 27 | codeMetaData :: J.Code, 28 | operandStack :: [LO.Operand], 29 | localVariableNames :: [LN.Name], 30 | -- Monotonic counter for unnamed temporaries 31 | autotmpN :: Int 32 | } deriving (Show) 33 | -- makeLenses ''CFGState 34 | 35 | type CFG = StateT CFGState IO 36 | 37 | -- Parse a JVM method into an LLVM module 38 | parseCFG :: J.Code -> IO CFGState 39 | parseCFG code = execStateT parseInstructions defaultCFGState 40 | where 41 | defaultCFGState = CFGState { 42 | basicBlocks = [LG.BasicBlock (LN.Name "entry") [] retvoid], 43 | programCounter = 0, 44 | instructions = Vec.fromList (J.codeInstructions code), 45 | codeMetaData = code, 46 | autotmpN = 2, 47 | operandStack = [], 48 | localVariableNames = [] 49 | } 50 | 51 | -- Get next numeric identifier for a new temporary 52 | nextTemp :: Integral a => CFG a 53 | nextTemp = do 54 | curr <- gets autotmpN 55 | modify $ \s -> s { autotmpN = curr + 1 } 56 | return . fromIntegral $ curr 57 | 58 | -- Pushes a constant on the operand stack. 59 | pushConstant :: LC.Constant -> CFG () 60 | pushConstant cons = 61 | -- An LLVM constant must be first converted into a ConstantOperand 62 | pushOperand $ LO.ConstantOperand cons 63 | 64 | -- Pushes an operand on the operand stack. 65 | pushOperand :: LO.Operand -> CFG () 66 | pushOperand op = do 67 | ops <- gets operandStack 68 | modify $ \s -> s { operandStack = op : ops } 69 | 70 | -- Pops a constant off the operand stack... 71 | -- Note that the caller must know the type of the actual operand 72 | popOperand :: CFG LO.Operand 73 | popOperand = do 74 | ops <- gets operandStack 75 | let op = head ops 76 | modify $ \s -> s { operandStack = tail ops } 77 | return op 78 | 79 | updateCurrentBlock :: LG.BasicBlock -> CFG () 80 | updateCurrentBlock b = do 81 | blocks <- gets basicBlocks 82 | modify $ \s -> s { basicBlocks = b : tail blocks } 83 | 84 | -- Sets the current terminator of this basic block. The terminator is an terminal 85 | -- operation (I.E one that is the very last instruction to be called) and generally 86 | -- results in branching of control flow or a return statement 87 | setTerminator :: LI.Named LI.Terminator -> CFG () 88 | setTerminator term = do 89 | block <- head <$> gets basicBlocks 90 | updateCurrentBlock $ setTerminator' term block 91 | 92 | where 93 | setTerminator' term (LG.BasicBlock n i t) = LG.BasicBlock n i term 94 | 95 | 96 | -- Appends an instruction to the specified basic block by creating a copy containing 97 | -- the requested instruction. 98 | appendInstruction :: LI.Named LI.Instruction -> CFG () 99 | appendInstruction instr = do 100 | block <- head <$> gets basicBlocks 101 | updateCurrentBlock $ appendInstruction' instr block 102 | 103 | where 104 | appendInstruction' i (LG.BasicBlock n is t) = LG.BasicBlock n (is ++ [i]) t 105 | 106 | 107 | -- Generate a named local variable name for each possible local variable 108 | setupLocals :: CFG () 109 | setupLocals = do 110 | -- For each maximum locals, generate a name for it in advance 111 | maxLocals <- J.codeMaxLocals <$> gets codeMetaData 112 | names <- forM [0..maxLocals-1] $ \i -> do 113 | let name = LN.mkName ("L" ++ show i) 114 | appendInstruction $ name LI.:= alloca LT.i32 115 | return name 116 | modify $ \s -> s { localVariableNames = names } 117 | 118 | -- Obtains the local variable at requested index 119 | getLocal :: Integral a => a -> CFG LN.Name 120 | getLocal idx = (!! fromIntegral idx) <$> gets localVariableNames 121 | 122 | parseInstructions :: CFG () 123 | parseInstructions = do 124 | setupLocals 125 | parseInstructions' 126 | 127 | -- Parse JVM Bytecode instructions into LLVM IR instructions 128 | parseInstructions' :: CFG () 129 | parseInstructions' = do 130 | -- Fetch and Add to program counter. 131 | pc <- gets programCounter 132 | modify $ \s -> s { programCounter = pc + 1 } 133 | 134 | -- Decode instructions. 135 | -- TODO: In future, check type of instruction and go from there... 136 | instr <- (Vec.! pc) <$> gets instructions 137 | case instr of 138 | -- Constants are pushed directly on operand stack 139 | J.ICONST_0 -> pushConstant $ int 0 140 | J.ICONST_1 -> pushConstant $ int 1 141 | J.ICONST_2 -> pushConstant $ int 2 142 | J.ICONST_3 -> pushConstant $ int 3 143 | J.ICONST_4 -> pushConstant $ int 4 144 | J.ICONST_5 -> pushConstant $ int 5 145 | J.ICONST_M1 -> pushConstant $ int (-1) 146 | 147 | -- Loads/Stores are assigned directly via Alloca. 148 | -- The index of the local variable normally is the next byte, but the 149 | -- 'hs-java' library is gracious enough to provide us with a helper that 150 | -- tags the next byte along with it. 151 | -- TODO: Need SSA conversions 152 | J.ISTORE_ idx -> do 153 | localName <- getLocal $ 154 | case idx of 155 | J.I0 -> 0 156 | J.I1 -> 1 157 | J.I2 -> 2 158 | J.I3 -> 3 159 | 160 | storeInstr <- store (local LT.i32 localName) <$> popOperand 161 | appendInstruction (LI.Do storeInstr) 162 | 163 | J.ISTORE idx -> do 164 | localName <- getLocal idx 165 | storeInstr <- store (local LT.i32 localName) <$> popOperand 166 | appendInstruction (LI.Do storeInstr) 167 | 168 | J.ILOAD_ idx -> do 169 | localName <- getLocal $ 170 | case idx of 171 | J.I0 -> 0 172 | J.I1 -> 1 173 | J.I2 -> 2 174 | J.I3 -> 3 175 | 176 | tmpName <- LN.UnName <$> nextTemp 177 | appendInstruction $ tmpName LI.:= load (local LT.i32 localName) 178 | pushOperand $ LO.LocalReference LT.i32 tmpName 179 | 180 | J.ILOAD idx -> do 181 | localName <- getLocal idx 182 | tmpName <- LN.UnName <$> nextTemp 183 | appendInstruction $ tmpName LI.:= load (local LT.i32 localName) 184 | pushOperand $ LO.LocalReference LT.i32 tmpName 185 | 186 | -- Binary operations operate and utilize the operand stack to simulate the 187 | -- stack-machine nature of the JVM on the LLVM. 188 | J.IADD -> do 189 | -- Map a JVM-Bytecode addition instruction to an LLVM addition instruction 190 | llvmInstr <- add <$> popOperand <*> popOperand 191 | tmpName <- LN.UnName <$> nextTemp 192 | pushOperand $ LO.LocalReference LT.i32 tmpName 193 | appendInstruction $ tmpName LI.:= llvmInstr 194 | -- Return instructions will pop off the top of the operand stack and use it as 195 | -- the return value. 196 | J.IRETURN -> do 197 | retInstr <- ret <$> popOperand 198 | setTerminator retInstr 199 | _ -> return () 200 | 201 | -- whenM outOfInstructions $ do 202 | -- retInstr <- ret <$> popOperand 203 | -- setTerminator retInstr 204 | unlessM outOfInstructions parseInstructions' 205 | 206 | where 207 | outOfInstructions :: CFG Bool 208 | outOfInstructions = do 209 | pc <- gets programCounter 210 | pcMax <- Vec.length <$> gets instructions 211 | return $ pc == pcMax 212 | -------------------------------------------------------------------------------- /LLVMFrontend/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module LLVMFrontend.Helpers where 3 | import Data.ByteString.Short 4 | import Control.Monad.State 5 | 6 | import LLVM.AST 7 | import LLVM.AST.Type 8 | import LLVM.AST.Global 9 | import qualified LLVM.AST as AST 10 | 11 | import qualified LLVM.AST.Linkage as LL 12 | import qualified LLVM.AST.Attribute as LA 13 | import qualified LLVM.AST.CallingConvention as LCC 14 | import qualified LLVM.AST.FloatingPointPredicate as LFP 15 | import qualified LLVM.AST.Instruction as LI 16 | import qualified LLVM.AST.Global as LG 17 | import qualified LLVM.AST.Constant as LC 18 | import qualified LLVM.AST.Operand as LO 19 | import qualified LLVM.AST.Name as LN 20 | import qualified LLVM.AST.Type as LT 21 | import qualified LLVM.AST.Float as LF 22 | 23 | -- Used in generation of LLVM backend code 24 | newtype LLVM a = LLVM (State AST.Module a) 25 | deriving (Functor, Applicative, Monad, MonadState AST.Module) 26 | 27 | -- Creates a simple function which returns void and takes no arguments 28 | defineFn :: LT.Type -> ShortByteString -> [BasicBlock] -> Definition 29 | defineFn typ label body = 30 | GlobalDefinition $ functionDefaults { 31 | name = Name label, 32 | returnType = typ, 33 | basicBlocks = body 34 | } 35 | 36 | 37 | -- Create a reference to a local variable 38 | local :: Type -> Name -> Operand 39 | local = LocalReference 40 | 41 | -- Create a reference to a global variable 42 | global :: Type -> Name -> LC.Constant 43 | global = LC.GlobalReference 44 | 45 | -- Create a reference to an 'extern'd variable 46 | externf :: Type -> Name -> Operand 47 | externf ty nm = ConstantOperand (LC.GlobalReference ty nm) 48 | 49 | {- Constants -} 50 | 51 | -- 32-bit integer constant 52 | int :: Integral a => a -> LC.Constant 53 | int = LC.Int 32 . fromIntegral 54 | 55 | float :: Float -> LC.Constant 56 | float = LC.Float . LF.Single 57 | 58 | add :: Operand -> Operand -> Instruction 59 | add a b = LI.Add False False a b [] 60 | 61 | mult :: Operand -> Operand -> Instruction 62 | mult a b = LI.Mul False False a b [] 63 | 64 | 65 | -- Arithmetic and Constants for floating points 66 | fadd :: Operand -> Operand -> Instruction 67 | fadd a b = FAdd NoFastMathFlags a b [] 68 | 69 | fsub :: Operand -> Operand -> Instruction 70 | fsub a b = FSub NoFastMathFlags a b [] 71 | 72 | fmul :: Operand -> Operand -> Instruction 73 | fmul a b = FMul NoFastMathFlags a b [] 74 | 75 | fdiv :: Operand -> Operand -> Instruction 76 | fdiv a b = FDiv NoFastMathFlags a b [] 77 | 78 | fcmp :: LFP.FloatingPointPredicate -> Operand -> Operand -> Instruction 79 | fcmp cond a b = FCmp cond a b [] 80 | 81 | cons :: LC.Constant -> Operand 82 | cons = ConstantOperand 83 | 84 | uitofp :: Type -> Operand -> Instruction 85 | uitofp ty a = UIToFP a ty [] 86 | 87 | toArgs :: [Operand] -> [(Operand, [LA.ParameterAttribute])] 88 | toArgs = map (\x -> (x, [])) 89 | 90 | -- Effects 91 | call :: Operand -> [Operand] -> Instruction 92 | call fn args = Call Nothing LCC.C [] (Right fn) (toArgs args) [] [] 93 | 94 | alloca :: Type -> Instruction 95 | alloca ty = Alloca ty Nothing 0 [] 96 | 97 | store :: Operand -> Operand -> Instruction 98 | store ptr val = Store False ptr val Nothing 0 [] 99 | 100 | load :: Operand -> Instruction 101 | load ptr = Load False ptr Nothing 0 [] 102 | 103 | -- Control Flow 104 | br :: Name -> Named Terminator 105 | br val = Do $ Br val [] 106 | 107 | cbr :: Operand -> Name -> Name -> Named Terminator 108 | cbr cond tr fl = Do $ CondBr cond tr fl [] 109 | 110 | phi :: Type -> [(Operand, Name)] -> Instruction 111 | phi ty incoming = Phi ty incoming [] 112 | 113 | ret :: Operand -> Named Terminator 114 | ret val = Do $ Ret (Just val) [] 115 | 116 | retvoid :: Named Terminator 117 | retvoid = Do $ Ret Nothing [] 118 | -------------------------------------------------------------------------------- /LLVMFrontend/MkGraph.hs: -------------------------------------------------------------------------------- 1 | {-RIPPED FROM MATEVM-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module LLVMFrontend.MkGraph 6 | ( ParseState'(..) 7 | , addExceptionBlocks 8 | , resolveReferences 9 | , resetPC 10 | , mkBlocks 11 | , mkMethod 12 | , pipeline 13 | , jvm2llvmType 14 | , returnType 15 | ) where 16 | 17 | import qualified Data.List as L 18 | import qualified Data.Set as S 19 | import qualified Data.Map as M 20 | import qualified Data.IntervalMap as IM 21 | import qualified Data.IntervalMap.Interval as IIM 22 | import qualified Data.ByteString.Lazy as B 23 | import Data.Int 24 | import Data.Word 25 | import Data.Maybe 26 | import Unsafe.Coerce 27 | 28 | import Control.Applicative hiding ((<*>)) 29 | import Control.Monad 30 | import Control.Monad.State 31 | import Control.Arrow 32 | 33 | import qualified JVM.Assembler as J 34 | import JVM.Assembler hiding (Instruction) 35 | import JVM.ClassFile 36 | import JVM.Converter 37 | 38 | import MateVMRuntime.Debug 39 | import MateVMRuntime.Types 40 | import MateVMRuntime.NativeSizes 41 | 42 | import Control.Monad.Extra 43 | 44 | import qualified Data.Vector as Vec 45 | import Data.Vector(Vector) 46 | 47 | import qualified LLVM.AST.Instruction as LI 48 | import qualified LLVM.AST.Global as LG 49 | import qualified LLVM.AST.Constant as LC 50 | import qualified LLVM.AST.Operand as LO 51 | import qualified LLVM.AST.Name as LN 52 | import qualified LLVM.AST.Type as LT 53 | import qualified LLVM.AST.Float as LF 54 | import qualified LLVM.AST.IntegerPredicate as LIP 55 | import LLVMFrontend.Helpers 56 | 57 | -- import Debug.Trace 58 | 59 | data ParseState' = ParseState' 60 | { basicBlocks :: M.Map Int32 LG.BasicBlock {- store offset -> label -} 61 | , currentBlockIdx :: Int 62 | , nBlocks :: Int 63 | , blockEntries :: S.Set Int32 {- store block entries (data gained from first pass) -} 64 | , localVariableNames :: [LN.Name] 65 | 66 | , pcOffset :: Int32 {- programm counter -} 67 | , operandStack :: [LO.Operand] {- simulation stack -} 68 | , autotmpN :: Int {- Counter for autotmp registers -} 69 | , classf :: Class Direct {- reference to class of processed method -} 70 | , method :: Method Direct {- reference to processed method -} 71 | 72 | , instructions :: [J.Instruction] {- instructions to process -} 73 | -- Note: The ExceptionMap is a type-alias for the IntervalMap, which maps an 74 | -- interval (I.E: [1,10] representing all numbers between 1 and 10) to its 75 | -- exception handler. This allows us to search whether or not a particular program 76 | -- counter has an exception handler within amortized O(log n) time. 77 | , exceptionMap :: ExceptionMap Int32 {- map of try-blocks, with references to handler -} 78 | , handlerStarts :: S.Set Int32 {- set of handler starts -} 79 | } 80 | 81 | type ParseState a = StateT ParseState' IO a 82 | 83 | pipeline :: Class Direct -> Method Direct -> [J.Instruction] -> IO ParseState' 84 | pipeline cls meth jvminsn = do 85 | prettyHeader "JVM Input" 86 | mapM_ (printfPipe . printf "\t%s\n" . show) jvminsn 87 | prettyHeader "Code Generation" 88 | action <- liftIO $ runAll $ do 89 | addExceptionBlocks 90 | resolveReferences 91 | resetPC jvminsn 92 | gs <- mkBlocks 93 | mkMethod 94 | seq action (return True) 95 | return action 96 | where 97 | mname = methodName meth 98 | codeseg = fromMaybe 99 | (error $ "codeseg " ++ (show . toString) mname ++ " not found") 100 | (attrByName meth "Code") 101 | decoded = decodeMethod codeseg 102 | exmap :: ExceptionMap Int32 103 | exmap = L.foldl' f IM.empty $ codeExceptions decoded 104 | where 105 | f emap ce = 106 | if IM.member key emap 107 | -- build list in reverse order, since matching order is important 108 | then IM.adjust (++ [value]) key emap 109 | else IM.insert key [value] emap 110 | where 111 | -- decrement end by one to get correct ranges 112 | key = IM.ClosedInterval (fromIntegral $ eStartPC ce) 113 | (fromIntegral $ eEndPC ce - 1) 114 | value = (&&&) g (fromIntegral . eHandlerPC) ce 115 | where 116 | g ce' = case eCatchType ce' of 117 | 0 -> B.empty 118 | x -> buildClassID cls x 119 | where 120 | buildClassID :: Class Direct -> Word16 -> B.ByteString 121 | buildClassID cls idx = cl 122 | where (CClass cl) = constsPool cls M.! idx 123 | hstarts :: S.Set Int32 124 | hstarts = S.fromList $ map (fromIntegral . eHandlerPC) 125 | $ codeExceptions decoded 126 | 127 | initstate :: ParseState' 128 | initstate = ParseState' { 129 | -- We begin with only a single entry block 130 | basicBlocks = M.fromList [(0, LG.BasicBlock (LN.Name "entry") [] (ret . LO.ConstantOperand $ int 0))] 131 | , currentBlockIdx = 0 132 | , blockEntries = S.empty 133 | , nBlocks = 0 134 | , pcOffset = 0 135 | , operandStack = [] 136 | , classf = cls 137 | , method = meth 138 | , localVariableNames = [] 139 | , autotmpN = 0 140 | , instructions = jvminsn 141 | , exceptionMap = exmap 142 | , handlerStarts = hstarts 143 | } 144 | runAll prog = execStateT prog initstate 145 | 146 | jvm2llvmType :: FieldType -> LT.Type 147 | jvm2llvmType typ = case typ of 148 | SignedByte -> LT.i8 149 | CharByte -> LT.i8 150 | DoubleType -> LT.double 151 | FloatType -> LT.float 152 | IntType -> LT.i32 153 | LongInt -> LT.i64 154 | ShortInt -> LT.i16 155 | BoolType -> LT.i1 156 | (ObjectType _) -> LT.i64 157 | (Array dim typ) -> LT.ArrayType (maybe 0 fromIntegral dim) (jvm2llvmType typ) 158 | 159 | 160 | returnType :: MethodSignature -> LT.Type 161 | returnType (MethodSignature _ (Returns typ)) = jvm2llvmType typ 162 | returnType (MethodSignature _ ReturnsVoid) = LT.void 163 | 164 | prettyHeader :: String -> IO () 165 | prettyHeader str = do 166 | let len = length str + 6 167 | printfPipe $ printf "%s\n" (replicate len ' ') 168 | printfPipe $ printf "-- %s --\n" str 169 | printfPipe $ printf "%s\n" (replicate len ' ') 170 | 171 | -- compileMethod :: B.ByteString -> MethodSignature -> Class Direct -> IO (NativeWord, TrapMap) 172 | -- compileMethod meth sig cls = 173 | -- case lookupMethodWithSig meth sig cls of 174 | -- Just m -> do 175 | -- let c = codeInstructions $ decodeMethod $ fromMaybe (error "no code seg") (attrByName m "Code") 176 | -- pipeline cls m c 177 | -- Nothing -> error $ "lookupMethod: " ++ show meth 178 | -- where 179 | -- lookupMethodWithSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct) 180 | -- lookupMethodWithSig name sig cls = 181 | -- L.find (\x -> methodName x == name && methodSignature x == sig) $ classMethods cls 182 | 183 | -- Generate Basic Block name 184 | generateBasicBlockName :: ParseState LN.Name 185 | generateBasicBlockName = do 186 | n <- gets nBlocks 187 | modify' $ \s -> s { nBlocks = n + 1 } 188 | return . LN.mkName $ "BB" ++ show n 189 | 190 | -- Split exception handlers and try-catch blocks into their own basic blocks. 191 | addExceptionBlocks :: ParseState () 192 | addExceptionBlocks = do 193 | -- Each exception handler has incoming edges from any pc ∈ [pcStart, pcEnd]... 194 | hstarts <- gets $ S.toList . handlerStarts 195 | forM_ hstarts addPC 196 | exKeys <- gets $ IM.keys . exceptionMap 197 | -- The beginning of the try-block, pcStart, contains an incoming edge from the 198 | -- basic block preceeding us. 199 | forM_ (map IIM.lowerBound exKeys) addPC 200 | -- The end of the try-block, pcEnd, contains an outgoing edge to our successor, pcEnd + 1 201 | forM_ (map IIM.upperBound exKeys) $ addPC . (+1) 202 | 203 | -- forward references wouldn't be a problem, but backwards are 204 | resolveReferences :: ParseState () 205 | resolveReferences = do 206 | jvminsn <- instructions <$> get 207 | pc <- pcOffset <$> get 208 | 209 | -- if there are no more JVM instructions, we are done here... 210 | if null jvminsn 211 | then do 212 | addPC 0 -- add entry instruction 213 | addPC pc -- mark return instruction 214 | else do 215 | when (null jvminsn) $ error "resolveReferences: something is really wrong here" 216 | let ins = head jvminsn 217 | addJumpTarget ins pc -- Handles whether this is a jump instruction or not 218 | incrementPC ins -- Also handles incrementing for multi-bytecode instructions 219 | resolveReferences 220 | where 221 | -- If the instruction is a jump instruction, we handle creating basic blocks 222 | -- for them as needed. If the instruction is not a jump instruction, this 223 | -- effectively becomes a NOP. 224 | addJumpTarget :: J.Instruction -> Int32 -> ParseState () 225 | addJumpTarget ins pc = case ins of 226 | (IF _ rel) -> addPCs pc rel ins 227 | (IF_ICMP _ rel) -> addPCs pc rel ins 228 | (IF_ACMP _ rel) -> addPCs pc rel ins 229 | (IFNULL rel) -> addPCs pc rel ins 230 | (IFNONNULL rel) -> addPCs pc rel ins 231 | GOTO rel -> addPCs pc rel ins 232 | JSR _ -> error "addJumpTarget: JSR?!" 233 | GOTO_W _ -> error "addJumpTarget: GOTO_W?!" 234 | JSR_W _ -> error "addJumpTarget: JSR_W?!" 235 | TABLESWITCH _ def _ _ offs -> addSwitch pc def offs 236 | LOOKUPSWITCH _ def _ switch' -> addSwitch pc def $ map snd switch' 237 | _ -> return () 238 | -- Add basic blocks for the _end_ of the current instruction (accounting for 239 | -- the size of the instruction) to its requested jump target instruction. 240 | addPCs :: Int32 -> Word16 -> J.Instruction -> ParseState () 241 | addPCs pc rel ins = do 242 | liftIO $ printfJit $ show ins ++ "(" ++ show (pc + w16Toi32 rel) ++ ")\n" 243 | addPC (pc + insnLength ins) -- Some instructions use more than one bytecode 244 | addPC (pc + w16Toi32 rel) -- Jump target for program counter 245 | 246 | -- Add a basic block for the switch instruction and all case statements. 247 | addSwitch :: Int32 -> Word32 -> [Word32] -> ParseState () 248 | addSwitch pc def offs = do 249 | let addrel = addPC . (+ pc) . fromIntegral 250 | mapM_ addrel offs 251 | addrel def 252 | 253 | -- Creates a basic block entry for this program counter. 254 | addPC :: Int32 -> ParseState () 255 | addPC bcoff = do 256 | addLabel bcoff 257 | modify (\s -> s { blockEntries = S.insert bcoff (blockEntries s) }) 258 | 259 | 260 | mkMethod :: ParseState () 261 | mkMethod = do 262 | hs <- gets handlerStarts 263 | -- Create labels for each exception handler, as well as for the entry block. 264 | forM_ (S.toList hs ++ [0]) addLabel 265 | return () 266 | 267 | 268 | mkBlocks :: ParseState () 269 | mkBlocks = do 270 | pc <- pcOffset <$> get 271 | entries <- blockEntries <$> get 272 | jvminsn <- instructions <$> get 273 | 274 | if null jvminsn 275 | then return () 276 | else if S.member pc entries 277 | then do 278 | mkBlock 279 | mkBlocks 280 | return () 281 | else error $ "mkBlocks: something wrong here. pc: " ++ show pc ++ 282 | "\ninsn: " ++ show jvminsn 283 | 284 | mkBlock :: ParseState () 285 | mkBlock = do 286 | handlermap <- exceptionMap <$> get 287 | pc <- pcOffset <$> get 288 | l <- addLabel pc 289 | -- push LT.ptr for Exceptionblock, which is passed via %eax 290 | isExceptionHandler <- S.member pc <$> handlerStarts <$> get 291 | let handlerStart = if isExceptionHandler then Just . fromIntegral $ pc else Nothing 292 | 293 | -- Compute the exception handlers that we are apart of. As there cna be nested 294 | -- exception handlers/try-catch blocks, we end up with a list of the ones we 295 | -- are contained in. 296 | -- let extable = map (second fromIntegral) 297 | -- $ concatMap snd 298 | -- $ handlermap `IM.containing` pc 299 | -- let f' = IRLabel l extable handlerStart 300 | -- fixup block boundaries 301 | -- be <- -- trace (printf "pc: %d\nhstart: %s\nextable: %s\n" pc (show handlerStart) (show extable)) $ 302 | -- M.lookup l <$> blockInterfaces <$> get 303 | -- fixup <- case be of 304 | -- Nothing -> return [] 305 | -- Just ts -> forM ts $ \x -> do 306 | -- nv <- newvar $ varType x 307 | -- apush nv 308 | -- return $ IROp Add nv x (nul (varType x)) 309 | toMid 310 | -- mkFirst f' <*> mkMiddles (fixup ++ ms') <*> mkLast l' 311 | return () 312 | 313 | -- Add a label for the provided program counter, if not already. 314 | addLabel :: Int32 -> ParseState LN.Name 315 | addLabel boff = do 316 | lmap <- basicBlocks <$> get 317 | if M.member boff lmap 318 | then return . basicBlockName $ lmap M.! boff -- Already present 319 | else do 320 | -- Construct a new label. We also create an outgoing edge to the label, 321 | -- as otherwise it would violate the basic block invariant. 322 | bb <- generateBasicBlock 323 | modify (\s -> s { basicBlocks = M.insert boff bb (basicBlocks s) }) 324 | liftIO $ printfJit $ "Added basic block " ++ (show . basicBlockName) bb ++ " at offset " ++ show boff ++ "\n" 325 | return . basicBlockName $ bb 326 | 327 | basicBlock :: LN.Name -> LG.BasicBlock 328 | basicBlock name = LG.BasicBlock name [] (ret . LO.ConstantOperand $ int 0) 329 | 330 | basicBlockName :: LG.BasicBlock -> LN.Name 331 | basicBlockName (LG.BasicBlock n _ _) = n 332 | 333 | generateBasicBlock :: ParseState LG.BasicBlock 334 | generateBasicBlock = basicBlock <$> generateBasicBlockName 335 | 336 | -- Increment program counter, also handling multibyte instructions. 337 | incrementPC :: J.Instruction -> ParseState () 338 | incrementPC ins = do 339 | modify (\s -> s { pcOffset = pcOffset s + insnLength ins}) 340 | popInstruction 341 | 342 | -- Advance current instruction. Note that the instruction is not returned, meaning 343 | -- the current instruction must be queried independently. 344 | popInstruction :: ParseState () 345 | popInstruction = do 346 | i <- instructions <$> get 347 | when (null i) $ error "popInstruction: something is really wrong here" 348 | modify (\s -> s { instructions = tail i }) 349 | 350 | setCurrentIdx :: Integral a => a -> ParseState () 351 | setCurrentIdx idx = modify $ \s -> s { currentBlockIdx = fromIntegral idx } 352 | 353 | toMid :: ParseState () 354 | toMid = do 355 | pc <- pcOffset <$> get 356 | insns <- instructions <$> get 357 | when (null insns) $ error "toMid: something is really wrong here :/" 358 | ins <- head <$> instructions <$> get 359 | entries <- blockEntries <$> get 360 | blocks <- gets basicBlocks 361 | if S.member (pc + insnLength ins) entries 362 | then do 363 | -- Refers to an already-existing basic block... 364 | -- Emulate the 'fallthrough' effect inherent in assembly instructions by 365 | -- adding an edge to the next basic block 366 | res <- toLast ins 367 | setCurrentIdx (pc + insnLength ins) 368 | incrementPC ins 369 | return res 370 | else do 371 | -- Points to an instruction, map to IR... 372 | insIR <- tir ins 373 | incrementPC ins 374 | toMid 375 | where 376 | -- Handle conditional and unconditional jumps here. We create the appropriate 377 | -- basic blocks for the instructions as well. 378 | toLast :: J.Instruction -> ParseState () 379 | toLast ins = do 380 | pc <- pcOffset <$> get 381 | -- Handle if-else statement, where we have two outgoing edges from the 382 | -- conditionally-executed basic block, and to the end of the basic block. 383 | let ifstuff jcmp rel op1 op2 = do 384 | -- Create isolated header block... 385 | headerBlock <- addLabel pc 386 | -- Add edge from predecessor 387 | setTerminator $ br headerBlock 388 | -- Become headerBlock 389 | setCurrentIdx pc 390 | 391 | -- Create the basic blocks... 392 | truejmp <- addLabel (pc + w16Toi32 rel) 393 | falsejmp <- addLabel (pc + insnLength ins) 394 | 395 | -- Perform comparison of op1 and op2 based on JVM instructions 396 | cmpName <- newvar 397 | let cmp = LO.LocalReference LT.i32 cmpName 398 | let cmpInstr = case jcmp of 399 | J.C_LE -> LIP.SLE 400 | J.C_EQ -> LIP.EQ 401 | J.C_GE -> LIP.SGE 402 | J.C_GT -> LIP.SGT 403 | J.C_LT -> LIP.SLT 404 | J.C_NE -> LIP.NE 405 | 406 | appendInstruction $ cmpName LI.:= LI.ICmp cmpInstr op2 op1 [] 407 | 408 | -- branch conditionally based on result 409 | setTerminator $ cbr cmp truejmp falsejmp 410 | return undefined -- TODO 411 | -- return ([], IRIfElse jcmp op1 op2 truejmp falsejmp) 412 | -- Handle switch statements, adding outgoing edges to each case statement. 413 | let switchins def switch' = do 414 | y <- apop 415 | switch <- forM switch' $ \(v, o) -> do 416 | offset <- addLabel $ pc + fromIntegral o 417 | return (Just (w32Toi32 v), offset) 418 | defcase <- addLabel $ pc + fromIntegral def 419 | return undefined -- TODO 420 | -- return ([], IRSwitch y $ switch ++ [(Nothing, defcase)]) 421 | case ins of 422 | RETURN -> return undefined 423 | ARETURN -> returnSomething LT.i32 424 | IRETURN -> returnSomething LT.i32 425 | LRETURN -> returnSomething LT.i64 426 | FRETURN -> returnSomething LT.float 427 | DRETURN -> returnSomething LT.double 428 | (IF jcmp rel) -> do 429 | let op1 = LO.ConstantOperand $ int 0 430 | op2 <- popOperand 431 | ifstuff jcmp rel op1 op2 432 | (IFNULL rel) -> do 433 | op1 <- apop 434 | ifstuff C_EQ rel op1 (nul LT.i64) 435 | (IFNONNULL rel) -> do 436 | op1 <- apop 437 | ifstuff C_NE rel op1 (nul LT.i64) 438 | (IF_ICMP jcmp rel) -> do 439 | op1 <- popOperand 440 | op2 <- popOperand 441 | ifstuff jcmp rel op1 op2 442 | (IF_ACMP jcmp rel) -> do 443 | op1 <- popOperand 444 | op2 <- popOperand 445 | ifstuff jcmp rel op1 op2 446 | (GOTO rel) -> do lbl <- addLabel (pc + w16Toi32 rel); setTerminator $ br lbl; return undefined 447 | TABLESWITCH _ def low high offs -> switchins def $ zip [low..high] offs 448 | LOOKUPSWITCH _ def _ switch -> switchins def switch 449 | _ -> do -- fallthrough case 450 | tir ins 451 | next <- addLabel (pc + insnLength ins) 452 | setTerminator $ br next 453 | -- fixups <- handleBlockEnd 454 | return () 455 | where 456 | -- Return the top operand (after performing type-checking) 457 | returnSomething t = do 458 | r <- apop 459 | setTerminator $ ret r 460 | -- error $ "Processing Type: " ++ show t ++ ", " ++ show r 461 | -- unless (varType r == t) $ error "toLast return: type mismatch" 462 | -- return ([], IRReturn $ Just r) 463 | 464 | -- handleBlockEnd :: ParseState [MateIR Var O O] 465 | -- handleBlockEnd = do 466 | -- st <- get 467 | -- let len = L.genericLength $ stack st 468 | -- if len > 0 469 | -- then 470 | -- forM [600000 .. (600000 + len - 1)] $ \r -> do 471 | -- x <- apop 472 | -- let vreg = VReg (VR r (varType x)) 473 | -- targets <- nextTargets <$> get 474 | -- forM_ targets $ \t -> do 475 | -- be <- fromMaybe [] <$> M.lookup t <$> blockInterfaces <$> get 476 | -- modify (\s -> s { blockInterfaces = M.insert t (vreg:be) (blockInterfaces s)}) 477 | -- return (IROp Add vreg x (nul (varType x))) 478 | -- else return [] 479 | 480 | -- Calculates length of instruction, also taking into account whether or not 481 | -- it is multibyte. 482 | insnLength :: Integral a => J.Instruction -> a 483 | insnLength x = case x of 484 | (TABLESWITCH padding _ _ _ xs) -> 485 | fromIntegral $ 1 {- opcode -} 486 | + padding 487 | + (3 * 4) {- def, low, high -} 488 | + 4 * L.genericLength xs {- entries -} 489 | (LOOKUPSWITCH padding _ _ xs) -> 490 | fromIntegral $ 1 {- opcode -} 491 | + padding 492 | + (2 * 4) {- def, n -} 493 | + 8 * L.genericLength xs {- pairs -} 494 | -- TODO: better idea anyone? 495 | AALOAD -> 1 496 | AASTORE -> 1 497 | ALOAD_ _ -> 1 498 | ANEWARRAY _ -> 3 499 | ARETURN -> 1 500 | ARRAYLENGTH -> 1 501 | DUP -> 1 502 | GOTO _ -> 3 503 | ICONST_0 -> 1 504 | ICONST_1 -> 1 505 | ICONST_2 -> 1 506 | ICONST_3 -> 1 507 | ICONST_4 -> 1 508 | ICONST_5 -> 1 509 | IF_ICMP _ _ -> 3 510 | IF _ _ -> 3 511 | ILOAD_ _ -> 1 512 | INVOKESTATIC _ -> 3 513 | INVOKESPECIAL _ -> 3 514 | INVOKEVIRTUAL _ -> 3 515 | ISTORE_ _ -> 1 516 | NEW _ -> 3 517 | LDC1 _ -> 2 518 | LDC2 _ -> 3 519 | POP -> 1 520 | PUTFIELD _ -> 3 521 | PUTSTATIC _ -> 3 522 | RETURN -> 1 523 | SIPUSH _ -> 3 524 | _ -> len -- trace (printf "insn: %s -> len: %d\n" (show x) (fromIntegral len :: Word32)) len 525 | where 526 | len = fromIntegral . B.length . encodeInstructions . (:[]) $ x 527 | 528 | resetPC :: [J.Instruction] -> ParseState () 529 | resetPC jvmins = 530 | modify (\s -> s { pcOffset = 0, instructions = jvmins }) 531 | 532 | -- Converts a JVM Classfile IMM (immediate constant) to the actual number. 533 | -- For example, imm2num (ICONST_ x) will yield the actual number associated with it. 534 | imm2num :: Num a => IMM -> a 535 | imm2num I0 = 0 536 | imm2num I1 = 1 537 | imm2num I2 = 2 538 | imm2num I3 = 3 539 | 540 | jvmByte2LLVMType :: Word8 -> LT.Type 541 | jvmByte2LLVMType 4 = LT.i1 542 | jvmByte2LLVMType 5 = LT.i8 543 | jvmByte2LLVMType 6 = LT.float 544 | jvmByte2LLVMType 7 = LT.double 545 | jvmByte2LLVMType 8 = LT.i8 546 | jvmByte2LLVMType 9 = LT.i16 547 | jvmByte2LLVMType 10 = LT.i32 548 | jvmByte2LLVMType 11 = LT.i64 549 | jvmByte2LLVMType x = error $ "Unknown array type byte: " ++ show x 550 | 551 | fieldType :: Class Direct -> Word16 -> LT.Type 552 | fieldType cls off = fieldType2VarType $ ntSignature nt 553 | where nt = case constsPool cls M.! off of 554 | (CField _ nt') -> nt' 555 | _ -> error "fieldType: fail :(" 556 | 557 | methodType :: Bool -> Class Direct -> Word16 -> ([LT.Type], Maybe LT.Type) 558 | methodType isVirtual cls off = (map fieldType2VarType argst', rett) 559 | where 560 | argst' = if isVirtual then ObjectType "this" : argst else argst 561 | (MethodSignature argst returnt) = 562 | case constsPool cls M.! off of 563 | (CMethod _ nt') -> ntSignature nt' 564 | (CIfaceMethod _ nt') -> ntSignature nt' 565 | _ -> error "methodType: fail :(" 566 | rett = case returnt of 567 | Returns ft -> Just (fieldType2VarType ft) 568 | ReturnsVoid -> Nothing 569 | 570 | methodIsStatic :: Method Direct -> Bool 571 | methodIsStatic = S.member ACC_STATIC . methodAccessFlags 572 | 573 | methodArgs :: Num a => Method Direct -> a 574 | methodArgs meth = isStatic $ L.genericLength args 575 | where 576 | (MethodSignature args _) = methodSignature meth 577 | isStatic = if methodIsStatic meth then (+0) else (+1) 578 | 579 | -- TODO: Map to LLVM Type? 580 | fieldType2VarType :: FieldType -> LT.Type 581 | fieldType2VarType IntType = LT.i32 582 | fieldType2VarType CharByte = LT.i8 583 | fieldType2VarType BoolType = LT.i1 584 | fieldType2VarType FloatType = LT.float 585 | fieldType2VarType (ObjectType _) = LT.i64 586 | fieldType2VarType (Array _ _) = LT.i64 -- fieldType2VarType ty -- TODO 587 | fieldType2VarType x = error $ "fieldType2VarType: " ++ show x 588 | 589 | -- tir = transform to IR 590 | -- TODO: Convert this to create LLVM... 591 | tir :: J.Instruction -> ParseState () 592 | -- tir ACONST_NULL = do apush LT.ptrNull; return [] 593 | tir ICONST_M1 = tir (BIPUSH 0xff) -- (-1) 594 | tir ICONST_0 = tir (BIPUSH 0) 595 | tir ICONST_1 = tir (BIPUSH 1) 596 | tir ICONST_2 = tir (BIPUSH 2) 597 | tir ICONST_3 = tir (BIPUSH 3) 598 | tir ICONST_4 = tir (BIPUSH 4) 599 | tir ICONST_5 = tir (BIPUSH 5) 600 | tir (BIPUSH x) = pushConstant $ int x 601 | tir (SIPUSH x) = pushConstant $ int x 602 | tir FCONST_0 = pushConstant $ LC.Float . LF.Single $ 0 603 | tir FCONST_1 = pushConstant $ LC.Float . LF.Single $ 1 604 | tir FCONST_2 = pushConstant $ LC.Float . LF.Single $ 3 605 | tir (ILOAD_ x) = tir (ILOAD (imm2num x)) 606 | tir (ILOAD x) = tirLoad' x LT.i32 -- tirLoad' x LT.i32; return [] 607 | tir (IINC x con) = do tir (ILOAD x); tir (BIPUSH con); tir (IADD); tir (ISTORE x) 608 | -- tirLoad' x LT.i32 609 | -- y <- apop 610 | -- nv <- newvar LT.i32 611 | -- apush nv 612 | -- storeinsn <- tirStore x LT.i32 613 | -- error "Not Supported" 614 | -- return $ IROp Add nv y (LT.i32Value (w8Toi32 con)) : storeinsn 615 | tir (ALOAD_ x) = tir (ALOAD (imm2num x)) 616 | tir (ALOAD x) = tirLoad' x LT.i64 617 | tir (FLOAD_ x) = tir (FLOAD (imm2num x)) 618 | tir (FLOAD x) = tirLoad' x LT.float 619 | tir (ISTORE_ x) = tir (ISTORE (imm2num x)) 620 | tir (ISTORE y) = tirStore y LT.i32 621 | tir (FSTORE_ y) = tir (FSTORE (imm2num y)) 622 | tir (FSTORE y) = tirStore y LT.float 623 | tir (ASTORE_ x) = tir (ASTORE (imm2num x)) 624 | tir (ASTORE x) = tirStore x (LT.ptr LT.i32) 625 | tir (PUTFIELD x) = do 626 | error "Not Supported" 627 | -- src <- apop 628 | -- obj <- apop 629 | -- unless (LT.ptr == varType obj) $ error "putfield: type mismatch" 630 | -- cls <- classf <$> get 631 | -- unless (fieldType cls x == varType src) $ error "putfield: type mismatch2" 632 | -- return [IRStore (RTPool x) obj src] 633 | tir (GETFIELD x) = do 634 | error "Not Supported" 635 | -- obj <- apop 636 | -- unless (LT.ptr == varType obj) $ error "getfield: type mismatch" 637 | -- cls <- classf <$> get 638 | -- nv <- newvar (fieldType cls x) 639 | -- apush nv 640 | -- return [IRLoad (RTPool x) obj nv] 641 | tir (GETSTATIC x) = do 642 | cls <- gets classf 643 | (fname, ftype) <- case constsPool cls M.! x of 644 | (CField _ (NameType fname ftype)) -> return (fname, ftype) 645 | _ -> error $ "Bad index: " ++ show x 646 | 647 | let fieldRef = cons $ global (LT.ptr . jvm2llvmType $ ftype) (mkName' fname) 648 | tmp <- newvar 649 | pushOperand $ LO.LocalReference (jvm2llvmType ftype) tmp 650 | appendInstruction $ tmp LI.:= load fieldRef 651 | where 652 | mkName' :: B.ByteString -> LN.Name 653 | mkName' = LN.mkName . map unsafeCoerce . B.unpack 654 | tir (PUTSTATIC x) = do 655 | y <- popOperand 656 | 657 | cls <- gets classf 658 | (fname, ftype) <- case constsPool cls M.! x of 659 | (CField _ (NameType fname ftype)) -> return (fname, ftype) 660 | _ -> error $ "Bad index: " ++ show x 661 | 662 | let fieldRef = cons $ global (LT.ptr . jvm2llvmType $ ftype) (mkName' fname) 663 | appendInstruction $ LI.Do $ store fieldRef y 664 | where 665 | mkName' :: B.ByteString -> LN.Name 666 | mkName' = LN.mkName . map unsafeCoerce . B.unpack 667 | 668 | -- appendInstruction $ LI.Do $ load (global LT.i32 ) 669 | -- return [IRStore (RTPool x) LT.ptrNull y] 670 | tir (LDC1 x) = tir (LDC2 (fromIntegral x)) 671 | tir (LDC2 x) = do 672 | cls <- classf <$> get 673 | case constsPool cls M.! x of 674 | (CString s) -> error "String not supported..." 675 | (CInteger i) -> pushConstant $ int i 676 | (CFloat f) -> pushConstant $ float f 677 | e -> error $ "tir: LDCI... missing impl.: " ++ show e 678 | return () 679 | tir (NEW x) = do 680 | error "Not Supported" 681 | -- nv <- newvar LT.ptr 682 | -- apush nv 683 | -- return [IRLoad (RTPoolCall x []) LT.ptrNull nv] 684 | -- tir (ANEWARRAY _) = tirArray ReferenceType 10 -- for int. TODO? 685 | tir (NEWARRAY w8) = unaryOp makeArray 686 | where 687 | makeArray op@(LO.ConstantOperand (LC.Int _ n)) = 688 | LI.Alloca ((LT.ptr (jvmByte2LLVMType w8))) (Just op) 8 [] 689 | tir ARRAYLENGTH = do 690 | error "Not Supported" 691 | -- array <- apop 692 | -- when (varType array /= LT.ptr) $ error "tir: arraylength: type mismatch" 693 | -- nv <- newvar LT.i32 694 | -- apush nv 695 | -- return [IRLoad RTArrayLength array nv] 696 | -- tir AALOAD = tirArrayLoad LT.ptr Nothing 697 | -- tir IALOAD = tirArrayLoad LT.i32 Nothing 698 | -- tir CALOAD = tirArrayLoad LT.i32 (Just 0xff) 699 | -- tir AASTORE = tirArrayStore LT.ptr Nothing 700 | tir IASTORE = return () 701 | -- tir CASTORE = tirArrayStore LT.i32 (Just 0xff) 702 | tir DUP = popOperand >>= replicateM_ 2 . pushOperand 703 | tir DUP_X1 = do 704 | x <- popOperand 705 | y <- popOperand 706 | pushOperand x 707 | pushOperand y 708 | pushOperand x 709 | tir DUP_X2 = do 710 | -- WARNING: different behaviour for LONG & DOUBLE!! 711 | -- see, category 2 computational type (§2.11.1). 712 | x <- popOperand 713 | y <- popOperand 714 | z <- popOperand 715 | pushOperand x 716 | pushOperand z 717 | pushOperand y 718 | pushOperand x 719 | tir POP = do popOperand; return () 720 | tir IADD = binaryOp LLVMFrontend.Helpers.add 721 | tir ISUB = binaryOp $ \x y -> LI.Sub False False y x [] 722 | tir INEG = do pushConstant $ int (-1); tir IMUL 723 | tir IMUL = binaryOp LLVMFrontend.Helpers.mult 724 | tir IDIV = binaryOp $ \x y -> LI.SDiv False y x [] 725 | tir IREM = binaryOp $ \x y -> LI.SRem y x [] 726 | tir IAND = binaryOp $ \x y -> LI.And y x [] 727 | tir IOR = binaryOp $ \x y -> LI.Or y x [] 728 | tir IXOR = binaryOp $ \x y -> LI.Xor y x [] 729 | tir IUSHR = binaryOp $ \x y -> LI.LShr False y x [] 730 | tir ISHR = binaryOp $ \x y -> LI.AShr False y x [] 731 | tir ISHL = binaryOp $ \x y -> LI.Shl False False y x [] 732 | tir FADD = binaryOp LLVMFrontend.Helpers.fadd 733 | tir I2C = do pushConstant $ int 0xFF; tir IAND 734 | -- tir (INVOKESTATIC ident) = tirInvoke CallStatic ident 735 | -- tir (INVOKESPECIAL ident) = tirInvoke CallSpecial ident 736 | -- tir (INVOKEVIRTUAL ident) = tirInvoke CallVirtual ident 737 | -- tir (INVOKEINTERFACE ident _) = tirInvoke CallInterface ident 738 | -- tir i@(CHECKCAST _) = do 739 | -- y <- apop 740 | -- apush y 741 | -- return [IRMisc1 i y] 742 | -- tir i@(INSTANCEOF _) = do 743 | -- y <- apop 744 | -- nv <- newvar LT.i32 745 | -- apush nv 746 | -- return [IRMisc2 i nv y] 747 | -- tir i@ATHROW = do 748 | -- y <- apop 749 | -- return [IRMisc1 i y] 750 | -- tir MONITORENTER = do -- TODO: stub! 751 | -- apop; return [] 752 | -- tir MONITOREXIT = do -- TODO: stub! 753 | -- apop; return [] 754 | tir x = error $ "tir: " ++ show x 755 | 756 | tirArray :: MateObjType -> Word8 -> ParseState () 757 | tirArray objtype w8 = do 758 | error "Not Supported" 759 | -- len <- apop 760 | -- when (varType len /= LT.i32) $ error "tir: tirArray: type mismatch" 761 | -- nv <- newvar LT.ptr 762 | -- apush nv 763 | -- return [IRLoad (RTArrayNew w8 objtype [] len) LT.ptrNull nv] 764 | -- 765 | -- tirArrayLoad :: VarType -> Maybe Int32 {- Mask -} -> ParseState [MateIR Var O O] 766 | -- tirArrayLoad t mask = do 767 | -- idx <- apop 768 | -- array <- apop 769 | -- when (varType array /= LT.ptr) $ error "tir: aaload: type mismatch1" 770 | -- when (varType idx /= LT.i32) $ error "tir: aaload: type mismatch2" 771 | -- nv <- newvar t 772 | -- apush nv 773 | -- case mask of 774 | -- Just m -> do 775 | -- _ <- apop 776 | -- nv' <- newvar LT.i32 777 | -- apush nv' 778 | -- return [ IRLoad (RTArrayIndex idx t) array nv 779 | -- , IROp And nv' nv (LT.i32Value m)] 780 | -- _ -> return [IRLoad (RTArrayIndex idx t) array nv] 781 | -- 782 | -- tirArrayStore :: VarType -> Maybe Int32 {- Mask -} -> ParseState [MateIR Var O O] 783 | -- tirArrayStore t mask = do 784 | -- value <- apop 785 | -- idx <- apop 786 | -- array <- apop 787 | -- when (varType array /= LT.ptr) $ 788 | -- error $ "tir: tirArrayStore: type mismatch1: " ++ show (varType array) 789 | -- when (varType idx /= LT.i32) $ 790 | -- error $ "tir: tirArrayStore: type mismatch2: " ++ show (varType idx) 791 | -- when (varType value /= t) $ 792 | -- error $ "tir: tirArrayStore: type mismatch3: " ++ show t 793 | -- case mask of 794 | -- Just m -> do 795 | -- nv <- newvar LT.i32 796 | -- return [ IROp And nv value (LT.i32Value m) 797 | -- , IRStore (RTArrayIndex idx t) array nv ] 798 | -- _ -> return [IRStore (RTArrayIndex idx t) array value] 799 | 800 | -- tirInvoke :: CallType -> Word16 -> ParseState [MateIR Var O O] 801 | -- tirInvoke ct ident = do 802 | -- cls <- classf <$> get 803 | -- let (varts, mret) = methodType (ct /= CallStatic) cls ident 804 | -- pushes <- tracePipe (printf "tirInvoke: varts: %s returns %s\n" (show varts) (show mret)) $ 805 | -- forM (reverse $ zip varts [0..]) $ \(x, nr) -> do 806 | -- y <- apop 807 | -- unless (x == varType y) $ error "invoke: type mismatch" 808 | -- case x of 809 | -- LT.i32 -> return $ IRPush nr y 810 | -- LT.ptr -> return $ IRPush nr y 811 | -- LT.float -> do 812 | -- let nr8 = fromIntegral nr 813 | -- let nri = fromIntegral nr 814 | -- let assign = preFloats !! nri 815 | -- modify (\s -> s { preRegs = M.insert 816 | -- (VR assign LT.float) 817 | -- (HFReg $ XMMReg nr8) 818 | -- (preRegs s) }) 819 | -- return $ IROp Add (VReg (VR assign x)) y (LT.floatValue 0) -- mov 820 | -- (targetreg, maybemov) <- case mret of 821 | -- Just x -> do 822 | -- let prereg = case x of 823 | -- LT.i32 -> preeax 824 | -- LT.float -> prexmm7 825 | -- LT.ptr -> preeax 826 | -- let nv = VReg (VR prereg x) 827 | -- movtarget <- newvar x 828 | -- tracePipe (printf "return: %s@%s\n" (show prereg) (show x)) $ 829 | -- apush movtarget 830 | -- return (Just nv, Just $ IROp Add movtarget nv (LT.i32Value 0)) 831 | -- Nothing -> return (Nothing, Nothing) 832 | -- let r = IRPrep SaveRegs [] : pushes ++ 833 | -- [IRInvoke (RTPoolCall ident []) targetreg ct, IRPrep RestoreRegs []] 834 | -- case maybemov of 835 | -- Nothing -> return r 836 | -- Just m -> return $ r ++ [m] 837 | 838 | -- maybeArgument :: Word8 -> VarType -> ParseState Var 839 | -- maybeArgument x t = do 840 | -- meth <- method <$> get 841 | -- let genVReg :: (Disp -> HVarX86) -> VRegNR 842 | -- -> Word8 -> VarType 843 | -- -> (VirtualReg, HVarX86) 844 | -- genVReg constructor a w8 t' = 845 | -- (VR a t' 846 | -- ,constructor . Disp . (+ (3 * ptrSize)) . fromIntegral $ (ptrSize * w8)) 847 | -- if x < methodArgs meth 848 | -- then do 849 | -- ((tup'k, tup'v), assign') <- case t of 850 | -- LT.float -> do 851 | -- let assign = preFloats !! fromIntegral x 852 | -- let tup = (VR assign LT.float, HFReg . XMMReg . fromIntegral $ x) 853 | -- return (tup, assign) 854 | -- _ -> do 855 | -- let assign = preArgs !! fromIntegral x 856 | -- let constr = case t of 857 | -- LT.ptr -> SpillIReg 858 | -- LT.i32 -> SpillIReg 859 | -- LT.float -> error "can't happen" 860 | -- let tup = genVReg constr assign x LT.i32 861 | -- return (tup, assign) 862 | -- modify (\s -> s { preRegs = M.insert tup'k tup'v (preRegs s) }) 863 | -- return $ VReg (VR assign' t) 864 | -- else return $ VReg (VR (fromIntegral x) t) 865 | 866 | -- Get next numeric identifier for a new temporary 867 | nextTemp :: Integral a => ParseState a 868 | nextTemp = do 869 | curr <- gets autotmpN 870 | modify' $ \s -> s { autotmpN = curr + 1 } 871 | return . fromIntegral $ curr 872 | 873 | -- Pushes a constant on the operand stack. 874 | pushConstant :: LC.Constant -> ParseState () 875 | pushConstant cons = do 876 | -- An LLVM constant must be first converted into a ConstantOperand 877 | pushOperand $ LO.ConstantOperand cons 878 | liftIO $ printfPipe $ "Pushed constant: " ++ show cons ++ "\n" 879 | 880 | -- Pushes an operand on the operand stack. 881 | pushOperand :: LO.Operand -> ParseState () 882 | pushOperand op = do 883 | ops <- gets operandStack 884 | modify' $ \s -> s { operandStack = op : ops } 885 | 886 | -- Pops a constant off the operand stack... 887 | -- Note that the caller must know the type of the actual operand 888 | popOperand :: ParseState LO.Operand 889 | popOperand = do 890 | ops <- gets operandStack 891 | when (null ops) $ error "popOperand: stack is empty" 892 | let op = head ops 893 | modify' $ \s -> s { operandStack = tail ops } 894 | return op 895 | 896 | -- Updates the current basic block (referred to by currentBlockIdx) in-place. 897 | updateCurrentBlock :: (LG.BasicBlock -> Maybe LG.BasicBlock) -> ParseState () 898 | updateCurrentBlock f = do 899 | currIdx <- fromIntegral <$> gets currentBlockIdx 900 | modify' $ \s -> s { basicBlocks = M.update f currIdx (basicBlocks s) } 901 | 902 | -- Sets the current terminator of this basic block. The terminator is an terminal 903 | -- operation (I.E one that is the very last instruction to be called) and generally 904 | -- results in branching of control flow or a return statement 905 | setTerminator :: LI.Named LI.Terminator -> ParseState () 906 | setTerminator term = updateCurrentBlock $ setTerminator' term 907 | 908 | where 909 | setTerminator' term (LG.BasicBlock n i t) = Just $ LG.BasicBlock n i term 910 | -- if t == retvoid then term else t 911 | 912 | -- Appends an instruction to the specified basic block by creating a copy containing 913 | -- the requested instruction. 914 | appendInstruction :: LI.Named LI.Instruction -> ParseState () 915 | appendInstruction instr = updateCurrentBlock $ appendInstruction' instr 916 | where 917 | appendInstruction' i (LG.BasicBlock n is t) = Just $ LG.BasicBlock n (is ++ [i]) t 918 | 919 | -- Obtains the local variable at requested index. If the local variable 920 | -- has not yet been allocated (first-use) we allocate it with the requested 921 | -- type. 922 | getLocal :: Integral a => a -> LT.Type -> ParseState LN.Name 923 | getLocal idx typ = do 924 | let idx' = fromIntegral idx 925 | vars <- gets localVariableNames 926 | 927 | -- Allocate on-demand 928 | when (idx' >= length vars) $ do 929 | let name = LN.mkName ("L" ++ show idx') 930 | appendInstruction $ name LI.:= alloca typ 931 | modify $ \s -> s { localVariableNames = vars ++ [name] } 932 | 933 | vars' <- gets localVariableNames 934 | return $ vars' !! idx' 935 | 936 | tirLoad' :: Word8 -> LT.Type -> ParseState () 937 | tirLoad' x t = do 938 | tmpName <- LN.UnName <$> nextTemp 939 | name <- getLocal x t 940 | appendInstruction $ tmpName LI.:= load (local t name) 941 | pushOperand $ LO.LocalReference LT.i32 tmpName 942 | liftIO $ printfPipe $ "Load " ++ show tmpName ++ "\n" 943 | 944 | nul :: LT.Type -> LO.Operand 945 | nul t = case t of 946 | i32 -> cons $ int 0 947 | i64 -> cons $ int 0 948 | float -> cons $ LC.Float . LF.Single $ 0 949 | ptr -> cons $ int 0 950 | 951 | unaryOp :: (LO.Operand -> LI.Instruction) -> ParseState () 952 | unaryOp f = do 953 | x <- popOperand 954 | tmp <- newvar 955 | pushOperand $ LO.LocalReference LT.i32 tmp 956 | appendInstruction $ tmp LI.:= f x 957 | 958 | binaryOp :: (LO.Operand -> LO.Operand -> LI.Instruction) -> ParseState () 959 | binaryOp f = do 960 | x <- popOperand 961 | y <- popOperand 962 | tmp <- newvar 963 | pushOperand $ LO.LocalReference LT.i32 tmp 964 | appendInstruction $ tmp LI.:= f x y 965 | 966 | tirStore :: Word8 -> LT.Type -> ParseState () 967 | tirStore w8 t = do 968 | localName <- getLocal w8 t 969 | storeInstr <- store (local t localName) <$> popOperand 970 | appendInstruction (LI.Do storeInstr) 971 | liftIO $ printfPipe $ "Store " ++ show localName ++ "\n" 972 | 973 | newvar :: ParseState LN.Name 974 | newvar = do 975 | sims <- get 976 | put $ sims { autotmpN = autotmpN sims + 1 } 977 | LN.UnName <$> nextTemp 978 | 979 | apush :: LO.Operand -> ParseState () 980 | apush x = do 981 | s <- gets operandStack 982 | sims <- get 983 | put $ sims { operandStack = x : s } 984 | 985 | apop :: ParseState LO.Operand 986 | apop = do 987 | simstack <- gets operandStack 988 | when (null simstack) $ error "apop: stack is empty" 989 | (s:ss) <- gets operandStack 990 | modify (\m -> m { operandStack = ss }) 991 | return s 992 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import GHC.IO.Encoding 3 | 4 | import JVM.ClassFile 5 | import Java.JAR 6 | -- import Runtime.Environment 7 | import System.Environment 8 | import Data.Char 9 | import Data.List 10 | import Data.List.Split 11 | import qualified Data.ByteString.Lazy as B 12 | import qualified Data.ByteString.Lazy.Char8 as C8 13 | import Control.Monad 14 | 15 | import LLVMFrontend.CFG 16 | 17 | import MateVMRuntime.ClassPool 18 | import MateVMRuntime.MethodPool 19 | 20 | import MateVMRuntime.Types 21 | import MateVMRuntime.Debug 22 | import MateVMRuntime.RtsOptions 23 | 24 | import MateVMRuntime.Utilities 25 | 26 | import Mate.GC.Boehm 27 | 28 | import Misc.Logger 29 | 30 | bootstrapMethod :: String 31 | bootstrapMethod = "RunMe" 32 | 33 | main :: IO () 34 | main = do 35 | time "main" $ do 36 | args <- getArgs 37 | parseArgs args False 38 | printCompileTime 39 | 40 | parseArgs :: [String] -> Bool -> IO () 41 | parseArgs ("-jar":jarpath:_) stdcp = do 42 | unless stdcp $ addClassPath "./" 43 | addClassPathJAR jarpath 44 | res <- readMainClass jarpath 45 | case res of 46 | Nothing -> error "JAR: no MainClass entry found. Try to pass the jar file via -cp instead." 47 | Just mc -> do 48 | let bclspath = B.pack . map (fromIntegral . ord) $ mc 49 | cls <- getClassFile bclspath 50 | executeMain bclspath cls 51 | 52 | parseArgs ("-cp":cps) cpset = parseArgs ("-classpath":cps) cpset 53 | parseArgs ("-classpath":cps:xs) False = do 54 | mapM_ addStuff $ splitOn ":" cps 55 | parseArgs xs True 56 | where 57 | addStuff :: String -> IO () 58 | addStuff x 59 | | ".jar" `isSuffixOf` x = addClassPathJAR x 60 | | otherwise = addClassPath $ x ++ "/" 61 | parseArgs ("-classpath":xs) _ = parseArgs ("-":xs) True -- usage 62 | parseArgs (('-':_):_) _ = error "Usage: mate [-cp|-classpath ] [ | -jar ]" 63 | -- first argument which isn't prefixed by '-' should be a class file 64 | parseArgs (clspath:_) stdcp = do 65 | unless stdcp $ addClassPath "./" 66 | let bclspath = B.pack . map (fromIntegral . ord) $ clspath 67 | cls <- getClassFile bclspath 68 | executeMain bclspath cls 69 | parseArgs _ _ = parseArgs ["-"] False 70 | 71 | 72 | executeMain :: B.ByteString -> Class Direct -> IO () 73 | executeMain bclspath cls = do 74 | --required on some platforms, initializes boehmgc. [todo bernhard: maybe this should be moved somewhere else - maybe at a global place where vm initialization takes place] 75 | unless usePreciseGC initGC 76 | 77 | case find ((==) (C8.pack bootstrapMethod) . methodName) (classMethods cls) of 78 | Just m -> do 79 | let mi = MethodInfo (C8.pack bootstrapMethod) bclspath $ methodSignature m 80 | entry <- lookupMethodEntry mi 81 | printfInfo $ "executing '" ++ bootstrapMethod ++ "' now:\n" 82 | executeFuncPtr (fromIntegral entry) 83 | printfInfo "Well, goodbye Sir!\n" 84 | Nothing -> error $ bootstrapMethod ++ " not found" 85 | -------------------------------------------------------------------------------- /MateVMRuntime/BlockAllocation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | module MateVMRuntime.BlockAllocation where 4 | 5 | import Foreign hiding ((.&.)) 6 | import System.IO.Unsafe(unsafePerformIO) 7 | import Control.Monad 8 | import Control.Monad.Trans 9 | import Control.Monad.State 10 | 11 | import qualified Data.Sequence as Q 12 | import Data.Sequence ((|>)) 13 | import Data.IORef 14 | import Text.Printf 15 | import qualified Data.Map as M 16 | import Data.Map(Map,(!)) 17 | import Data.Set(Set) 18 | import qualified Data.Set as S 19 | import MateVMRuntime.RtsOptions 20 | import MateVMRuntime.Debug 21 | import qualified MateVMRuntime.GC as GC 22 | 23 | blockSize :: Int 24 | blockSize = 1 `shift` blockSizePowerOfTwo 25 | 26 | data Block = Block { beginPtr :: !IntPtr 27 | , endPtr :: !IntPtr 28 | , freePtr :: !IntPtr 29 | } deriving (Eq) 30 | 31 | instance Show Block where 32 | show x = printf "Begin: 0x%08x, End: 0x%08x, FreePtr: 0x%08x" (fromIntegral $ beginPtr x :: Int) (fromIntegral $ endPtr x :: Int) (fromIntegral $ freePtr x :: Int) 33 | 34 | -- Maps number of free bytes to a set of blocks with this 35 | -- amount of free memory 36 | type Blocks = Map Int [Block] 37 | 38 | data GenState = GenState { freeBlocks :: [Block] 39 | , activeBlocks :: Blocks 40 | , collections :: !Int 41 | , generation :: Int 42 | } deriving (Show,Eq) 43 | 44 | data GcState = GcState { generations :: Map Int GenState, 45 | allocs :: Int, 46 | allocatedBytes :: Int, 47 | loh :: Set IntPtr, 48 | allocState :: AllocC 49 | } deriving (Eq,Show) 50 | 51 | generation0 :: GcState -> GenState 52 | generation0 s = generations s !0 53 | 54 | emptyGenState :: GenState 55 | emptyGenState = GenState { freeBlocks = [], activeBlocks = M.empty, collections = 0, generation = 0 } 56 | 57 | mkGenState :: Int -> GenState 58 | mkGenState n = GenState { freeBlocks = [], activeBlocks = M.empty, collections = 0, generation = n } 59 | 60 | mkGcState :: GenState -> GcState 61 | mkGcState s = GcState { generations = M.insert 0 s M.empty, allocs = 0, allocatedBytes = 0, loh = S.empty, allocState = error "not implemented"} 62 | 63 | type Generation = Int 64 | 65 | class Monad m => Alloc a m | a -> m where 66 | alloc :: Generation -> Int -> StateT a m Block 67 | release :: Block -> StateT a m () 68 | 69 | type GenStateT m a = StateT GenState (StateT a m) 70 | type GcStateT m a = StateT GcState (StateT a m) 71 | 72 | 73 | -- | allocates memory within a generation 74 | allocGen :: Alloc a m => Int -> GenStateT m a (Ptr b) 75 | allocGen size = do 76 | -- let's see if there is some free memory in our blocks 77 | -- as heuristics, take the one with the most free memory 78 | current <- get 79 | let possibleBlocks = activeBlocks current 80 | biggestBlockM = M.maxViewWithKey (M.filter (not . null) possibleBlocks) 81 | case biggestBlockM of 82 | Just ((space,block:rest),smallBlocks) -> 83 | if space >= size 84 | then do --awesome. we got a block which is big enough 85 | let (ptr,block') = allocateInBlock block size 86 | let active' = M.insert space rest smallBlocks 87 | active'' = M.insertWith (++) (freeSpace block') [block'] active' 88 | put current { activeBlocks = active'' } 89 | return ptr 90 | else do 91 | allocateInFreshBlock (tracePipe ("current blocks:" ++ show possibleBlocks) size) 92 | _ -> tracePipe ("noActiveBlocks!!" ++ show possibleBlocks ++ "WIGH M:" ++ show biggestBlockM) $ allocateInFreshBlock size 93 | 94 | freeSpace :: Block -> Int 95 | freeSpace Block { freePtr = free', endPtr = end } = fromIntegral $ end - free' 96 | 97 | allocateInFreshBlock :: Alloc a m => Int -> GenStateT m a (Ptr b) 98 | allocateInFreshBlock size = do 99 | current <- get 100 | freeBlock <- case freeBlocks current of 101 | [] -> lift $ alloc blockSize (generation current) -- make a block 102 | (x:xs) -> do --reuse idle block 103 | put current { freeBlocks = xs } 104 | return x 105 | let (ptr,block) = allocateInBlock freeBlock size 106 | activateBlock block 107 | return ptr 108 | 109 | activateBlock :: Monad m => Block -> GenStateT m a () 110 | activateBlock b = do 111 | current <- get 112 | let active = activeBlocks current 113 | put current { activeBlocks = M.insertWith (++) (freeSpace b) [b] active } 114 | 115 | allocateInBlock :: Block -> Int -> (Ptr b, Block) 116 | allocateInBlock b@(Block { freePtr = free', endPtr = end }) size = 117 | if freePtr' > end 118 | then error $ "allocateInBlock has insufficient space. wtf" ++ (show b) ++ " with alloc size: " ++ (show size) 119 | else (intPtrToPtr free', b { freePtr = freePtr' }) 120 | where freePtr' = free' + fromIntegral size 121 | 122 | 123 | -- | allocates memory in generation 0 124 | allocGen0 :: Alloc a m => GC.GenInfo -> Int -> GcStateT m a (Ptr b) 125 | allocGen0 gen size = 126 | if size > blockSize 127 | then error $ "tried to allocate superhuge object in gen0 (" ++ show size ++ " bytes)" 128 | else do 129 | let targetGenIndex = GC.targetGen gen 130 | targetGen <- liftM (\x -> generations x!targetGenIndex) get 131 | (ptr, newState) <- lift $ runStateT (allocGen size) targetGen 132 | c <- get 133 | put $ c { generations = M.insert targetGenIndex newState (generations c) } 134 | return ptr 135 | 136 | 137 | 138 | 139 | runBlockAllocatorC :: GC.GenInfo -> Int -> StateT GcState IO (Ptr b) 140 | runBlockAllocatorC gen size = do 141 | current <- get 142 | let m = runStateT (allocGen0 gen size) current 143 | ((ptr,gcState),allocState') <- liftIO $ runStateT m (allocState current) 144 | put gcState { allocState = allocState' } 145 | return ptr 146 | 147 | 148 | data AllocC = AllocC { freeBlocksC :: Q.Seq Block } 149 | deriving (Show,Eq) 150 | 151 | instance Alloc AllocC IO where 152 | alloc = allocC 153 | release = releaseC 154 | 155 | 156 | mkAllocC :: Int -> IO AllocC 157 | mkAllocC 0 = return AllocC { freeBlocksC = Q.empty } 158 | mkAllocC n = do 159 | printfGc $ printf "heapSize = %d * blockSize = %d => %d\n" n blockSize (n*blockSize) 160 | let size' = n * blockSize 161 | ptr <- mallocBytes size' 162 | let intPtr = ptrToIntPtr ptr 163 | printfGc $ printf "allocated cached block memory: %s\n" (show ptr) 164 | let begin = shift (shift intPtr (-blockSizePowerOfTwo)) blockSizePowerOfTwo 165 | printfGc $ printf "starting at: 0x%08x\n" (fromIntegral begin :: Int) 166 | printfGc $ printf "ending at: 0x%08x\n" (fromIntegral begin + size' :: Int) 167 | let allBlockBegins = [begin,begin+fromIntegral blockSize..begin + fromIntegral size'] 168 | let allBlocks = [Block { beginPtr = x+4, endPtr = x+fromIntegral size', freePtr = x+4} | x <- allBlockBegins] 169 | return AllocC { freeBlocksC = Q.fromList allBlocks } -- all is free 170 | 171 | 172 | allocC :: Generation -> Int -> StateT AllocC IO Block 173 | allocC gen _ = do 174 | current <- get 175 | if Q.null (freeBlocksC current) 176 | then error "out of heap memory!" 177 | else do 178 | let block = Q.index (freeBlocksC current) 0 179 | writeGenToBlock block gen 180 | liftIO $ modifyIORef activeBlocksCnt (+ (1)) 181 | activeOnes <- liftIO $ readIORef activeBlocksCnt 182 | liftIO $ printfGc $ printf "activated a block %d\n" activeOnes 183 | put current { freeBlocksC = Q.drop 1 (freeBlocksC current) } 184 | --liftIO $ printfGc $ printf "we got free blocks: %s" (show $ length xs) 185 | return block { freePtr = beginPtr block } 186 | 187 | writeGenToBlock :: Block -> Generation -> StateT AllocC IO () 188 | writeGenToBlock block gen = 189 | liftIO $ poke (intPtrToPtr $ beginPtr block - 4) gen 190 | 191 | 192 | releaseC :: Block -> StateT AllocC IO () 193 | releaseC b = do 194 | current' <- get 195 | liftIO $ modifyIORef activeBlocksCnt (+ (-1)) 196 | activeOnes <- liftIO $ readIORef activeBlocksCnt 197 | liftIO $ printfGc $ printf "released a block %d\n" activeOnes 198 | put current' { freeBlocksC = freeBlocksC current' |> b } 199 | 200 | activeBlocksCnt :: IORef Int 201 | activeBlocksCnt = unsafePerformIO $ newIORef 0 202 | 203 | freeGensIOC :: [GenState] -> StateT GcState IO () 204 | freeGensIOC xs = do 205 | current <- get 206 | let blocksToDispose = concatMap ( concatMap snd . M.toList . activeBlocks ) xs 207 | (_,s) <- liftIO $ runStateT (mapM_ releaseC blocksToDispose) (allocState current) 208 | put current { allocState = s } 209 | return () 210 | 211 | 212 | -------------------------------------------------------------------------------- /MateVMRuntime/ClassHierarchy.hi-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/ClassHierarchy.hi-boot -------------------------------------------------------------------------------- /MateVMRuntime/ClassHierarchy.hs: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.ClassHierarchy 2 | ( isInstanceOf 3 | , addClassEntry 4 | , addInterfaceEntry 5 | ) where 6 | 7 | import qualified Data.Map as M 8 | import qualified Data.ByteString.Lazy as B 9 | import Data.List 10 | import Control.Monad 11 | 12 | import Foreign hiding (unsafePerformIO) 13 | import System.IO.Unsafe 14 | import Data.IORef 15 | 16 | import MateVMRuntime.NativeSizes 17 | import MateVMRuntime.Debug 18 | import MateVMRuntime.Types 19 | import MateVMRuntime.ClassPool 20 | 21 | 22 | data Class 23 | = Class NativeWord [B.ByteString] 24 | | JavaLangObject 25 | 26 | type ClassHier = M.Map NativeWord Class 27 | classHier :: IORef ClassHier 28 | {-# NOINLINE classHier #-} 29 | classHier = unsafePerformIO $ newIORef M.empty 30 | 31 | type InterfaceHier = M.Map B.ByteString [B.ByteString] 32 | interfaceHier :: IORef InterfaceHier 33 | {-# NOINLINE interfaceHier #-} 34 | interfaceHier = unsafePerformIO $ newIORef M.empty 35 | 36 | readClass :: IO ClassHier 37 | readClass = readIORef classHier 38 | readInterface :: IO InterfaceHier 39 | readInterface = readIORef interfaceHier 40 | 41 | writeClass :: ClassHier -> IO () 42 | writeClass = writeIORef classHier 43 | writeInterface :: InterfaceHier -> IO () 44 | writeInterface = writeIORef interfaceHier 45 | 46 | isInstanceOf :: NativeWord -> B.ByteString -> IO Bool 47 | isInstanceOf 0 _ = return False 48 | isInstanceOf obj classname = do 49 | obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj) 50 | ch <- readClass 51 | ih <- readInterface 52 | if M.member classname ih 53 | then do -- interface check 54 | let ai = allInterfaces obj_mtable ch 55 | return $ checkInterfaces ai classname ih 56 | else do -- class check 57 | class_mtable <- getMethodTableNoInit classname 58 | return $ checkInstance obj_mtable class_mtable ch 59 | 60 | allInterfaces :: NativeWord -> ClassHier -> [B.ByteString] 61 | allInterfaces obj_mtable ch = 62 | case ch M.! obj_mtable of 63 | JavaLangObject -> [] 64 | Class superclass ifaces -> ifaces ++ allInterfaces superclass ch 65 | 66 | checkInterfaces :: [B.ByteString] -> B.ByteString -> InterfaceHier -> Bool 67 | checkInterfaces [] _ _ = False 68 | checkInterfaces ifaces target ih 69 | | target `elem` ifaces = True 70 | | otherwise = checkInterfaces (nextifaces \\ ifaces) target ih 71 | where 72 | nextifaces = concatMap (\x -> ih M.! x) ifaces 73 | 74 | checkInstance :: NativeWord -> NativeWord -> ClassHier -> Bool 75 | checkInstance obj cl_mtable ch 76 | | obj == cl_mtable = True 77 | | otherwise = 78 | case ch M.! obj of 79 | Class super _ -> checkInstance super cl_mtable ch 80 | JavaLangObject -> False 81 | 82 | addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO () 83 | addClassEntry mtable 0 _ = do 84 | ch <- readClass 85 | writeClass (M.insert mtable JavaLangObject ch) 86 | addClassEntry mtable super_mtable ifaces = do 87 | ch <- readClass 88 | unless (M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!" 89 | writeClass (M.insert mtable (Class super_mtable ifaces) ch) 90 | 91 | addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO () 92 | addInterfaceEntry iface super_ifaces = do 93 | ch <- readInterface 94 | -- TODO: check super if's 95 | writeInterface (M.insert iface super_ifaces ch) 96 | -------------------------------------------------------------------------------- /MateVMRuntime/ClassHierarchy.hs-boot: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.ClassHierarchy 2 | ( isInstanceOf 3 | , addClassEntry 4 | , addInterfaceEntry 5 | ) where 6 | 7 | import qualified Data.ByteString.Lazy as B 8 | import MateVMRuntime.NativeSizes 9 | 10 | isInstanceOf :: NativeWord -> B.ByteString -> IO Bool 11 | addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO () 12 | addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO () 13 | -------------------------------------------------------------------------------- /MateVMRuntime/ClassHierarchy.o-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/ClassHierarchy.o-boot -------------------------------------------------------------------------------- /MateVMRuntime/ClassPool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleContexts, GADTs #-} 2 | module MateVMRuntime.ClassPool ( 3 | getClassInfo, 4 | getClassInfoNoInit, 5 | classLoaded, 6 | getClassFile, 7 | getMethodTable, 8 | getMethodTableNoInit, 9 | getMethodTableReverse, 10 | getObjectSize, 11 | getFieldCount, 12 | getStaticFieldTypes, 13 | getFieldTypes, 14 | getMethodOffset, 15 | getFieldOffset, 16 | getFieldSignatures, 17 | getStaticFieldAddr, 18 | getInterfaceMethodOffset, 19 | addClassPath, 20 | addClassPathJAR 21 | ) where 22 | 23 | import Data.Int 24 | import Data.Binary 25 | import qualified Data.Map as M 26 | import qualified Data.Set as S 27 | import Data.List 28 | import qualified Data.ByteString.Lazy as B 29 | import Data.String.Utils 30 | 31 | import Control.Arrow 32 | import Control.Applicative 33 | import Control.Monad 34 | 35 | -- import JVM.Dump 36 | 37 | import Foreign.Ptr 38 | import Foreign.C.Types 39 | import Foreign.Storable 40 | 41 | import Data.IORef 42 | import System.IO.Unsafe 43 | import System.Directory 44 | 45 | import JVM.ClassFile 46 | import JVM.Converter 47 | import Java.ClassPath hiding (Directory) 48 | import Java.JAR 49 | 50 | import {-# SOURCE #-} MateVMRuntime.MethodPool 51 | import MateVMRuntime.Types 52 | import MateVMRuntime.Debug 53 | import {-# SOURCE #-} MateVMRuntime.GarbageAlloc 54 | import MateVMRuntime.NativeSizes 55 | import {-# SOURCE #-} MateVMRuntime.ClassHierarchy 56 | 57 | getClassInfo :: B.ByteString -> IO ClassInfo 58 | getClassInfo path = do 59 | class_map <- getClassMap 60 | case M.lookup path class_map of 61 | Nothing -> loadAndInitClass path 62 | Just ci -> return ci 63 | 64 | getClassInfoNoInit :: B.ByteString -> IO ClassInfo 65 | getClassInfoNoInit path = do 66 | class_map <- getClassMap 67 | case M.lookup path class_map of 68 | Nothing -> loadClassNoInit path 69 | Just ci -> return ci 70 | 71 | classLoaded :: B.ByteString -> IO Bool 72 | classLoaded path = do 73 | class_map <- getClassMap 74 | return $ M.member path class_map 75 | 76 | getClassFile :: B.ByteString -> IO (Class Direct) 77 | getClassFile path = do 78 | ci <- getClassInfo path 79 | return $ ciFile ci 80 | 81 | getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CPtrdiff 82 | getStaticFieldOffset path field = do 83 | ci <- getClassInfo path 84 | return $ fromIntegral $ ciStaticMap ci M.! field 85 | 86 | getFieldOffset :: B.ByteString -> B.ByteString -> IO Int32 87 | getFieldOffset path field = do 88 | ci <- getClassInfo path 89 | return $ ciFieldMap ci M.! field 90 | 91 | -- class name, methodname, methodsignature 92 | getMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO NativeWord 93 | getMethodOffset path method sig = do 94 | ci <- getClassInfo path 95 | -- (+ ptrSize): one slot for "interface-table-ptr" 96 | return $ (+ ptrSize) $ fromIntegral $ 97 | ciMethodMap ci M.! (method `B.append` sig) 98 | 99 | getMethodTableNoInit :: B.ByteString -> IO NativeWord 100 | getMethodTableNoInit path = do 101 | ci <- getClassInfoNoInit path 102 | return $ ciMethodBase ci 103 | 104 | getMethodTable :: B.ByteString -> IO NativeWord 105 | getMethodTable path = do 106 | ci <- getClassInfo path 107 | return $ ciMethodBase ci 108 | 109 | getMethodTableReverse :: NativeWord -> IO (Maybe B.ByteString) 110 | getMethodTableReverse mtable = do 111 | class_map <- getClassMap 112 | let f x = ciMethodBase x == mtable 113 | return $ ciName <$> find f (M.elems class_map) 114 | 115 | getObjectSize :: B.ByteString -> IO NativeWord 116 | getObjectSize path = do 117 | fsize <- getFieldCount path 118 | -- one slot for "method-table-ptr" 119 | -- one slot for GC-data 120 | return $ (2 + fsize) * ptrSize 121 | 122 | getFieldCount :: B.ByteString -> IO NativeWord 123 | getFieldCount path = do 124 | ci <- getClassInfo path 125 | -- TODO(bernhard): correct sizes for different types... 126 | return $ ciFieldLength ci 127 | 128 | -- TODO: not implemented yet. will return empty map! 129 | getStaticFieldTypes :: B.ByteString -> IO [(Int32, FieldSignature)] 130 | getStaticFieldTypes path = do 131 | ci <- getClassInfo path 132 | return $ map (second fieldSignature) $ M.toList (ciStaticFieldTypeMap ci) 133 | 134 | -- TODO: not very well tested 135 | getFieldTypes :: B.ByteString -> IO [(Int32, FieldSignature)] 136 | getFieldTypes path = do 137 | ci <- getClassInfo path 138 | return $ map (second fieldSignature) $ M.toList (ciFieldTypeMap ci) 139 | 140 | getFieldSignatures :: FieldTypeMap -> [(Int32, FieldSignature)] 141 | getFieldSignatures m = map (second fieldSignature) $ M.toList m 142 | 143 | 144 | getStaticFieldAddr :: CPtrdiff -> IO CPtrdiff 145 | getStaticFieldAddr from = do 146 | trapmap <- getTrapMap 147 | let w32_from = fromIntegral from 148 | let sfi = trapmap M.! w32_from 149 | setTrapMap $ M.delete w32_from trapmap 150 | case sfi of 151 | (StaticField (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field 152 | _ -> error "getFieldAddr: no TrapCause found. abort" 153 | 154 | -- interface name, methodname, methodsignature 155 | getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO NativeWord 156 | getInterfaceMethodOffset ifname meth sig = do 157 | loadInterface ifname 158 | ifmmap <- getInterfaceMethodMap 159 | case M.lookup (ifname `B.append` meth `B.append` sig) ifmmap of 160 | Just w32 -> return w32 161 | Nothing -> error "getInterfaceMethodOffset: no offset set" 162 | 163 | 164 | readClass :: B.ByteString -> IO ClassInfo 165 | readClass path = do 166 | class_map' <- getClassMap 167 | case M.lookup path class_map' of 168 | Just cm -> return cm 169 | Nothing -> do 170 | cfile <- readClassFile $ toString path 171 | -- TODO(bernhard): hDumpClass 172 | -- dumpClass cfile 173 | -- load all interfaces, which are implemented by this class 174 | sequence_ [ loadInterface i | i <- interfaces cfile ] 175 | superclass <- if path /= "java/lang/Object" 176 | then do 177 | sc <- readClass $ superClass cfile 178 | return $ Just sc 179 | else return Nothing 180 | 181 | ((staticmap, statictypemap), (fieldmap, fieldtypemap, fsize)) <- 182 | calculateFields cfile superclass 183 | (methodmap, mbase, msize) <- calculateMethodMap cfile superclass 184 | immap <- getInterfaceMethodMap 185 | 186 | -- allocate interface offset table for this class 187 | -- TODO(bernhard): we have some duplicates in immap (i.e. some 188 | -- entries have the same offset), so we could 189 | -- save some memory here. 190 | iftable <- mallocClassData $ ptrSize * M.size immap 191 | let wn_iftable = fromIntegral $ ptrToIntPtr iftable :: NativeWord 192 | -- store interface-table at offset 0 in method-table 193 | pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 wn_iftable 194 | let hexDumpMap :: Integral v => String -> M.Map B.ByteString v -> IO () 195 | hexDumpMap header mmap = do 196 | let printValue :: B.ByteString -> IO () 197 | printValue key = printfCp $ printf "\t%-70s: 0x%08x\n" (toString key) val 198 | where val = fromIntegral (mmap M.! key) :: NativeWord 199 | printfCp $ printf "%s\n" header 200 | mapM_ printValue (M.keys mmap) 201 | when mateDEBUG $ do 202 | let strpath = toString path 203 | hexDumpMap ("staticmap @ " ++ strpath) staticmap 204 | hexDumpMap ("fieldmap @ " ++ strpath) fieldmap 205 | hexDumpMap ("methodmap @ " ++ strpath) methodmap 206 | hexDumpMap ("interfacemap @ " ++ strpath) immap 207 | printfCp $ printf "mbase: 0x%08x\n" mbase 208 | printfCp $ printf "iftable: 0x%08x\n" wn_iftable 209 | virtual_map <- getVirtualMap 210 | setVirtualMap $ M.insert mbase path virtual_map 211 | 212 | class_map <- getClassMap 213 | let new_ci = ClassInfo 214 | { ciName = path 215 | , ciFile = cfile 216 | , ciStaticMap = staticmap 217 | , ciStaticFieldTypeMap = statictypemap 218 | , ciFieldMap = fieldmap 219 | , ciFieldTypeMap = fieldtypemap 220 | , ciFieldLength = fsize 221 | , ciMethodMap = methodmap 222 | , ciMethodBase = mbase 223 | , ciMethodLength = msize 224 | , ciInitDone = False 225 | } 226 | setClassMap $ M.insert path new_ci class_map 227 | 228 | -- add Class to Hierarchy 229 | super_mtable <- case superclass of 230 | Nothing -> return 0 231 | Just x -> getMethodTable $ ciName x 232 | addClassEntry mbase super_mtable (interfaces cfile) 233 | 234 | return new_ci 235 | 236 | 237 | loadInterface :: B.ByteString -> IO () 238 | loadInterface path = do 239 | imap <- getInterfaceMap 240 | -- interface already loaded? 241 | case M.lookup path imap of 242 | Just _ -> return () 243 | Nothing -> do 244 | printfCp $ printf "interface: loading \"%s\"\n" $ toString path 245 | cfile <- readClassFile $ toString path 246 | -- load "superinterfaces" first 247 | sequence_ [ loadInterface i | i <- interfaces cfile ] 248 | immap <- getInterfaceMethodMap 249 | 250 | -- load map again, because there could be new entries now 251 | -- due to loading superinterfaces 252 | imap' <- getInterfaceMap 253 | let max_off = fromIntegral $ M.size immap * ptrSize 254 | -- create index of methods by this interface 255 | let mm = zipbase max_off (classMethods cfile) 256 | 257 | -- create for each method from *every* superinterface an entry too, 258 | -- but just put in the same offset as it is already in the map 259 | let (ifnames, methodnames) = unzip $ concat 260 | [ zip (repeat ifname) (classMethods $ imap' M.! ifname) 261 | | ifname <- interfaces cfile ] 262 | let sm = zipWith (\x y -> (entry y, immap M.! getname x y)) ifnames methodnames 263 | 264 | -- merge all offset tables 265 | setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap 266 | setInterfaceMap $ M.insert path cfile imap' 267 | 268 | -- add Interface to Hierarchy 269 | addInterfaceEntry path (interfaces cfile) 270 | where 271 | zipbase base = zipWith (\x y -> (entry y, x + base)) [0,ptrSize..] 272 | entry = getname path 273 | getname p y = p `B.append` methodName y `B.append` encode (methodSignature y) 274 | 275 | 276 | calculateFields :: Class Direct -> Maybe ClassInfo 277 | -> IO ((FieldMap, FieldTypeMap), (FieldMap, FieldTypeMap, NativeWord)) 278 | calculateFields cf superclass = do 279 | -- TODO(bernhard): correct sizes. int only atm 280 | 281 | let (sfields, ifields) = partition (S.member ACC_STATIC . fieldAccessFlags) (classFields cf) 282 | 283 | let sc_sm = getsupermap superclass ciStaticMap 284 | 285 | let sfields_size = fromIntegral $ length sfields 286 | let statictypemap = zipbasetype (fromIntegral sfields_size) sfields 287 | staticbase <- mallocStaticData (sfields_size * ptrSize) statictypemap 288 | let sm = zipbase (fromIntegral $ ptrToIntPtr staticbase) sfields 289 | -- new fields "overwrite" old ones, if they have the same name 290 | let staticmap = sm `M.union` sc_sm 291 | 292 | let sc_im = getsupermap superclass ciFieldMap 293 | let sc_imtype = getsupermap superclass ciFieldTypeMap 294 | let sc_size :: Num a => a 295 | sc_size = case superclass of 296 | Just x -> fromIntegral $ ciFieldLength x 297 | Nothing -> 0 298 | -- "+ (2*ptrsize)" for the method table pointer and GC data 299 | let max_off = (+ (2*ptrSize)) $ sc_size * ptrSize 300 | let im = zipbase max_off ifields 301 | let imtype = zipbasetype max_off ifields 302 | -- new fields "overwrite" old ones, if they have the same name 303 | let fieldmap = im `M.union` sc_im 304 | let fieldtypemap = imtype `M.union` sc_imtype 305 | let fsize = sc_size + fromIntegral (M.size im) 306 | 307 | return ((staticmap, statictypemap), (fieldmap, fieldtypemap, fsize)) 308 | where 309 | zipbase :: Int32 -> [Field Direct] -> FieldMap 310 | zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,ptrSize..] 311 | zipbasetype :: Int32 -> [Field Direct] -> FieldTypeMap 312 | zipbasetype base = foldr(\(x,y) -> M.insert (x + base) y) M.empty . zip [0,ptrSize..] 313 | 314 | -- helper 315 | getsupermap :: Maybe ClassInfo -> (ClassInfo -> M.Map k v) -> M.Map k v 316 | getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty 317 | 318 | 319 | calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, NativeWord, NativeWord) 320 | calculateMethodMap cf superclass = do 321 | let methods = filter 322 | (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x && 323 | ((/=) "" . methodName) x) 324 | (classMethods cf) 325 | let sc_mm = getsupermap superclass ciMethodMap 326 | let sc_size :: Num a => a 327 | sc_size = case superclass of 328 | Just x -> fromIntegral $ ciMethodLength x 329 | Nothing -> 0 330 | let max_off = sc_size * ptrSize 331 | let mm = M.fromList $ zipbase max_off methods 332 | let methodmap = mm `M.union` sc_mm 333 | 334 | let size = M.size sc_mm + sc_size 335 | -- (+1): one slot for the interface-table-ptr 336 | methodbase <- mallocClassData $ (size + 1) * ptrSize 337 | return ( methodmap 338 | , fromIntegral $ ptrToIntPtr methodbase 339 | , fromIntegral $ size) 340 | where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,ptrSize..] 341 | where entry y = methodName y `B.append` encode (methodSignature y) 342 | 343 | 344 | loadClassNoInit :: B.ByteString -> IO ClassInfo 345 | loadClassNoInit path = do 346 | class_map <- getClassMap 347 | ci <- case M.lookup path class_map of 348 | Nothing -> readClass path 349 | Just x -> return x 350 | 351 | when (path /= "java/lang/Object") (void $ loadClassNoInit $ superClass $ ciFile ci) 352 | 353 | class_map' <- getClassMap 354 | setClassMap $ M.insert path ci class_map' 355 | return ci 356 | 357 | 358 | loadAndInitClass :: B.ByteString -> IO ClassInfo 359 | loadAndInitClass path = do 360 | class_map <- getClassMap 361 | ci <- case M.lookup path class_map of 362 | Nothing -> readClass path 363 | Just x -> return x 364 | 365 | -- first try to execute class initializer of superclass 366 | when (path /= "java/lang/Object") (void $ loadAndInitClass $ superClass $ ciFile ci) 367 | 368 | -- execute class initializer 369 | unless (ciInitDone ci) $ case lookupMethod "" (ciFile ci) of 370 | Just _ -> do 371 | let mi = MethodInfo "" path $ MethodSignature [] ReturnsVoid 372 | entry <- lookupMethodEntry mi 373 | -- TODO(bernhard): test exception handling in static initalizer 374 | printfCp $ printf "executing static initializer from %s now\n" (toString path) 375 | executeFuncPtr (fromIntegral entry) 376 | printfCp $ printf "static initializer from %s done\n" (toString path) 377 | Nothing -> return () 378 | 379 | class_map' <- getClassMap 380 | let new_ci = ci { ciInitDone = True } 381 | setClassMap $ M.insert path new_ci class_map' 382 | return new_ci 383 | 384 | 385 | readClassFile :: String -> IO (Class Direct) 386 | readClassFile path' = readIORef classPaths >>= rcf 387 | where 388 | path = replace "." "/" path' 389 | rcf :: [MClassPath] -> IO (Class Direct) 390 | rcf [] = readIORef classPaths >>= \cp -> error $ "readClassFile: Class \"" ++ show path ++ "\" not found." ++ "\n" ++ show cp 391 | rcf (Directory pre:xs) = do 392 | let cf = pre ++ path ++ ".class" 393 | printfCp $ printf "rcf: searching @ %s for %s\n" (show pre) (show path) 394 | b <- doesFileExist cf 395 | if b 396 | then parseClassFile cf 397 | else rcf xs 398 | rcf (JAR p:xs) = do 399 | printfCp $ printf "rcf: searching %s in JAR\n" (show path) 400 | entry <- getEntry p path 401 | case entry of 402 | Just (LoadedJAR _ cls) -> return cls 403 | Nothing -> rcf xs 404 | _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1" 405 | 406 | data MClassPath = 407 | Directory String | 408 | JAR [Tree CPEntry] 409 | deriving (Show) 410 | 411 | classPaths :: IORef [MClassPath] 412 | {-# NOINLINE classPaths #-} 413 | classPaths = unsafePerformIO $ newIORef [] 414 | 415 | addClassPath :: String -> IO () 416 | addClassPath x = do 417 | cps <- readIORef classPaths 418 | writeIORef classPaths (Directory x:cps) 419 | 420 | addClassPathJAR :: String -> IO () 421 | addClassPathJAR x = do 422 | cps <- readIORef classPaths 423 | t <- execClassPath $ addJAR x 424 | writeIORef classPaths (JAR t:cps) 425 | -------------------------------------------------------------------------------- /MateVMRuntime/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module MateVMRuntime.Debug 4 | ( printfJit 5 | , printfTrap 6 | , printfBb 7 | , printfMp 8 | , printfCp 9 | , printfStr 10 | , printfInfo 11 | , printfEx 12 | , printfGc 13 | , printfMem 14 | , printfPipe 15 | , printfPlain 16 | , printfTime 17 | , tracePipe 18 | , mateDEBUG 19 | , mateTIME 20 | , logGcT 21 | , gcLogEnabled 22 | , showRefs 23 | , printf -- TODO: delete me 24 | ) where 25 | 26 | import Text.Printf 27 | import System.IO 28 | import System.IO.Unsafe 29 | import Control.Monad 30 | import Control.Monad.State 31 | import Foreign 32 | 33 | {-# NOINLINE logHandle #-} 34 | -- TODO(bernhard): use MVar if threaded 35 | logHandle :: Handle 36 | logHandle = if mateDEBUG 37 | then unsafePerformIO $ openFile "mate.log" WriteMode 38 | else stdout 39 | 40 | {-# INLINE mateDEBUG #-} 41 | mateDEBUG :: Bool 42 | mateDEBUG = True 43 | 44 | {-# INLINE mateTIME #-} 45 | mateTIME :: Bool 46 | mateTIME = False 47 | 48 | {-# INLINE printError #-} 49 | printError :: Bool -> String -> String -> IO () 50 | printError dbgflag prefix str = do 51 | when dbgflag $ hPutStr stderr . (++) prefix $ str 52 | hFlush stderr 53 | 54 | {-# INLINE printString #-} 55 | printString :: Bool -> String -> String -> IO () 56 | printString dbgflag prefix str = do 57 | when dbgflag $ hPutStr logHandle . (++) prefix $ str 58 | hFlush logHandle 59 | 60 | {-# INLINE printfJit #-} 61 | {-# INLINE printfTrap #-} 62 | {-# INLINE printfBb #-} 63 | {-# INLINE printfMp #-} 64 | {-# INLINE printfCp #-} 65 | {-# INLINE printfStr #-} 66 | {-# INLINE printfInfo #-} 67 | {-# INLINE printfEx #-} 68 | {-# INLINE printfGc #-} 69 | {-# INLINE printfMem #-} 70 | {-# INLINE printfPipe #-} 71 | {-# INLINE printfPlain #-} 72 | printfJit, printfTrap, printfBb, printfMp, printfCp, 73 | printfStr, printfInfo, printfEx, printfPipe, printfMem, printfGc, 74 | printfPlain, printfTime :: String -> IO () 75 | {- 76 | -- TODO(bernhard): 77 | -- http://stackoverflow.com/questions/12123082/function-composition-with-text-printf-printf 78 | -} 79 | printfJit = printString mateDEBUG "Jit: " 80 | printfTrap = printString mateDEBUG "Trap: " 81 | printfBb = printString mateDEBUG "Bb: " 82 | printfMp = printString mateDEBUG "Mp: " 83 | printfCp = printString mateDEBUG "Cp: " 84 | printfStr = printString mateDEBUG "Str: " 85 | printfInfo = printString mateDEBUG "Info: " 86 | printfEx = printString mateDEBUG "Ex: " 87 | printfGc = printString mateDEBUG "Gc: " 88 | printfMem = printString mateDEBUG "Mem: " 89 | printfPipe = printString mateDEBUG "Pipe: " 90 | printfPlain = printString mateDEBUG "" 91 | printfTime = printError mateTIME "time: " 92 | 93 | {-# NOINLINE tracePipe #-} 94 | tracePipe :: String -> a -> a 95 | tracePipe string expr = unsafePerformIO $ do 96 | printfPipe string 97 | return expr 98 | {-# INLINE gcLogEnabled #-} 99 | gcLogEnabled :: Bool 100 | gcLogEnabled = True 101 | 102 | logGcT :: String -> StateT b IO () 103 | logGcT s = when gcLogEnabled (liftIO $ printfGc s) 104 | 105 | showRefs :: [IntPtr] -> [String] 106 | showRefs = map (show . intPtrToPtr) 107 | -------------------------------------------------------------------------------- /MateVMRuntime/GC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module MateVMRuntime.GC 3 | ( RefObj(..) 4 | , traverseIO 5 | , markTree'' 6 | , markTree 7 | , patchAllRefs 8 | , AllocationManager(..) 9 | , RefUpdateAction 10 | , notNullRef 11 | , patchGCRoots 12 | , GenInfo(..) 13 | , mkGen0 14 | , evacuate' 15 | , extractLargeObjects 16 | ) where 17 | 18 | import GHC.Int 19 | import Data.List 20 | import qualified Foreign as F 21 | import Control.Monad 22 | import Control.Monad.State 23 | import qualified Data.Map as M 24 | import qualified Data.Set as S 25 | import Text.Printf 26 | import Foreign.Ptr (IntPtr, Ptr) 27 | import MateVMRuntime.Debug 28 | import MateVMRuntime.RtsOptions 29 | 30 | 31 | class (Eq a, Ord a, Show a) => RefObj a where 32 | 33 | getIntPtr :: a -> IO IntPtr 34 | size :: a -> IO Int 35 | cast :: Ptr b -> a 36 | 37 | refs :: a -> IO [a] 38 | patchRefs :: a -> [a] -> IO () 39 | setNewRef :: a -> a -> IO () 40 | getNewRef :: a -> IO a 41 | 42 | marked :: a -> IO Bool 43 | mark :: a -> IO () 44 | unmark :: a -> IO () 45 | 46 | allocationOffset :: a -> Int 47 | 48 | validObj :: a -> IO Bool 49 | 50 | printRef :: a -> IO () 51 | 52 | 53 | type RefUpdateAction = IntPtr -> IO () -- the argument is the new location of the refobj 54 | 55 | data GenInfo = GenInfo { targetGen :: Int } 56 | mkGen0 :: GenInfo 57 | mkGen0 = GenInfo { targetGen = 0 } 58 | 59 | class AllocationManager a where 60 | 61 | initMemoryManager :: Int -> IO a 62 | 63 | -- | allocates n bytes in current space to space (may be to space or gen0 space) 64 | mallocBytesT :: GenInfo -> Int -> StateT a IO (Ptr b) 65 | 66 | -- | performs full gc and which is reflected in mem managers state 67 | performCollection :: (RefObj b) => M.Map b RefUpdateAction -> StateT a IO () 68 | 69 | -- | collects large objects (first argument is set of live objs) 70 | collectLoh :: RefObj b => [b] -> StateT a IO () 71 | 72 | heapSize :: StateT a IO Int 73 | 74 | validRef :: IntPtr -> StateT a IO Bool 75 | 76 | -- | Generically marks a graph (can be used to set mark bit and reset mark bit at the same time 77 | -- using customized loopcheck and marker funcs (i.e. to set the bit check on ==1 and on ==0 otherwise) 78 | -- Furthermore it produces a list of visited nodes (this can be all live one (or dead on respectively) 79 | markTree'' :: RefObj a => (a -> IO Bool) -> (a -> IO ()) -> [a] -> a -> IO [a] 80 | markTree'' loopcheck marker ws root = do loop <- loopcheck root 81 | if loop then return ws else liftM (root :) continue 82 | where continue = marker root >> refs root >>= foldM (markTree'' loopcheck marker) ws 83 | 84 | -- | For debugging only (implements custom loop check with Data.Set!) 85 | traverseIO :: RefObj o => (o -> IO ()) -> o -> IO () 86 | traverseIO f = void . traverseIO' f S.empty 87 | 88 | traverseIO' :: RefObj a => (a -> IO ()) -> S.Set a -> a -> IO (S.Set a) 89 | traverseIO' f ws root = if S.member root ws then f root >> return ws 90 | else f root >> refs root >>= cont 91 | where cont = foldM (\wsAcc x -> do let wsAcc' = S.insert x wsAcc 92 | traverseIO' f wsAcc' x) ws' 93 | ws' = S.insert root ws 94 | 95 | markTree :: RefObj a => a -> IO () 96 | markTree root = marked root >>= (`unless` continue) 97 | where continue = mark root >> refs root >>= mapM_ markTree 98 | 99 | 100 | -- | This object is alive. so its children are alive. patch child references to point 101 | -- to childrens new references 102 | patchRefsObj :: (RefObj a) => (a -> IO Bool) -> a -> IO () 103 | patchRefsObj predicate obj = do 104 | intptr <- getIntPtr obj 105 | printfGc $ printf "patch 0x%08x" (fromIntegral intptr :: Int) 106 | printRef obj 107 | obj' <- getNewRef obj 108 | fields <- refs obj 109 | printfGc "current fields:\n" 110 | printfGc $ show fields ++ "\n" 111 | newRefs <- mapM (getNewRefIfValid predicate) fields 112 | printfGc "this are the new children: " 113 | printfGc $ show newRefs ++ "\n" 114 | patchRefs obj' newRefs 115 | patchRefs obj newRefs 116 | printfGc "which is patched: \n" 117 | printRef obj' 118 | 119 | getNewRefIfValid :: (RefObj a) => (a -> IO Bool) -> a -> IO a 120 | getNewRefIfValid predicate obj = do 121 | isValid <- predicate obj 122 | if isValid 123 | then do newRef <- getNewRef obj 124 | newOneValid <- predicate newRef 125 | if newOneValid 126 | then return newRef 127 | else return obj 128 | else do printfGc "geNewRefIfValid said obj itself is invalid. dafuqr\n" 129 | return obj 130 | 131 | patchAllRefs :: (RefObj a) => (a -> IO Bool) -> [a] -> IO () 132 | patchAllRefs valid = mapM_ (patchRefsObj valid) 133 | 134 | notNullRef :: AllocationManager a => IntPtr -> StateT a IO Bool 135 | notNullRef = return . (/=(0x0 :: Int)) . fromIntegral 136 | 137 | patchGCRoots :: (RefObj a) => M.Map a RefUpdateAction -> IO () 138 | patchGCRoots roots = mapM_ fixRef $ M.toList roots 139 | where fixRef (obj,fixupAction) = do valid <- validObj obj 140 | if valid 141 | then getNewRef obj >>= getIntPtr >>= fixupAction 142 | else return () 143 | 144 | 145 | evacuate' :: (RefObj a, AllocationManager b) => (GenInfo -> Bool) -> (a -> IO GenInfo) -> [a] -> StateT b IO () 146 | evacuate' filterF info = mapM_ (evacuate'' filterF info) 147 | 148 | evacuate'' :: (RefObj a, AllocationManager b) => (GenInfo -> Bool) -> (a -> IO GenInfo) -> a -> StateT b IO () 149 | evacuate'' filterF info obj = do 150 | (size',location) <- liftIO ((,) <$> getSizeDebug obj <*> getIntPtr obj) 151 | target <- liftIO $ info obj 152 | 153 | if filterF target 154 | then do 155 | -- malloc in toSpace 156 | newPtr <- mallocBytesT target size' 157 | liftIO (printfGc ("evacuating: " ++ show obj ++ 158 | " and set: " ++ show newPtr ++ " size: " ++ show size' ++ "\n")) 159 | -- copy data over and leave notice 160 | liftIO (F.copyBytes newPtr (F.intPtrToPtr location) size' >> 161 | setNewRef obj (cast newPtr) >> 162 | F.pokeByteOff newPtr 4 (0::Int32)) 163 | else return () 164 | 165 | getSizeDebug :: RefObj a => a -> IO Int 166 | getSizeDebug obj = do 167 | intObj <- getIntPtr obj 168 | printfGc $ printf "objTo evacuate: 0x%08x\n" (fromIntegral intObj :: Int) 169 | size' <- size obj 170 | printfGc $ printf "size was %i\n" size' 171 | return size' 172 | 173 | -- splits [a] into (large objects, normal objects) 174 | extractLargeObjects :: RefObj a => [a] -> IO ([a],[a]) 175 | extractLargeObjects xs = 176 | if not useLoh 177 | then return ([],xs) 178 | else do 179 | sizes <- mapM (\x -> size x >>= \s -> return (x,s)) xs 180 | let (lohs,objs) = partition ((>= loThreshhold) . snd) sizes 181 | return (map fst lohs, map fst objs) 182 | 183 | 184 | -------------------------------------------------------------------------------- /MateVMRuntime/GarbageAlloc.hi-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/GarbageAlloc.hi-boot -------------------------------------------------------------------------------- /MateVMRuntime/GarbageAlloc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module MateVMRuntime.GarbageAlloc( 3 | mallocClassData, 4 | mallocStaticData, 5 | mallocStringGC, 6 | mallocObjectGC, 7 | mallocObjectGC_stackstrace, 8 | getHeapMemory, 9 | printMemoryUsage, 10 | printGCStats, 11 | mallocObjectUnmanaged, 12 | mallocStringUnmanaged) where 13 | 14 | import Foreign hiding (unsafePerformIO, mallocBytes) 15 | import qualified Foreign as F 16 | import Foreign.C 17 | import System.IO.Unsafe 18 | import Data.IORef 19 | import Control.Monad.State 20 | import qualified Data.ByteString.Internal as BI 21 | import Data.String.Utils 22 | 23 | import Mate.GC.Boehm 24 | import MateVMRuntime.StackTrace 25 | import MateVMRuntime.MemoryManager hiding (heapSize) 26 | import MateVMRuntime.TwoSpaceAllocator 27 | import MateVMRuntime.JavaObjects 28 | import MateVMRuntime.ClassPool 29 | import qualified MateVMRuntime.GenerationalGC as Gen 30 | import qualified MateVMRuntime.GC as GC 31 | import qualified MateVMRuntime.BlockAllocation as B 32 | import JVM.ClassFile 33 | import MateVMRuntime.Debug 34 | import MateVMRuntime.RtsOptions 35 | import MateVMRuntime.Types 36 | 37 | foreign export ccall mallocObjectGC_stackstrace :: CPtrdiff -> CPtrdiff -> Int -> IO CPtrdiff 38 | foreign export ccall mallocObjectGC :: Int -> IO CPtrdiff 39 | 40 | -- unified place for allocating Memory 41 | 42 | mallocObjectUnmanaged :: Int -> IO CPtrdiff 43 | mallocObjectUnmanaged size = do 44 | ptr <- F.mallocBytes size 45 | BI.memset (castPtr ptr) 0 (fromIntegral size) 46 | printfMem $ printf "mallocObjectUnmanged: %d\n" size 47 | return $ fromIntegral $ ptrToIntPtr ptr 48 | 49 | mallocStringUnmanaged :: Int -> IO (Ptr a) 50 | mallocStringUnmanaged size = do 51 | printfMem $ printf "mallocStringUnamaged: %d\n" size 52 | ptr <- F.mallocBytes size 53 | BI.memset (castPtr ptr) 0 (fromIntegral size) 54 | return ptr 55 | 56 | mallocStaticData :: Int -> FieldTypeMap -> IO (Ptr a) 57 | mallocStaticData size types = do 58 | printfMem $ printf "mallocStaticData: %d\n" size 59 | mem <- F.mallocBytes size 60 | BI.memset (castPtr mem) 0 (fromIntegral size) 61 | addRootGC mem (plusPtr mem size) 62 | let memInt = fromIntegral $ ptrToIntPtr mem 63 | printfMem $ printf "got adress %s" (show mem) 64 | printfMem $ printf "Here we go: %s\n" (show types) 65 | let staticFields = [memInt + (off-1)*4 | off <- extractRerefenceTypeOffsets types] 66 | printfMem $ printf "classData fields: %s\n" (show $ showRefs2 staticFields) 67 | mapM_ (addRootPrecise . fromIntegral) staticFields 68 | return mem 69 | 70 | extractRerefenceTypeOffsets :: FieldTypeMap -> [Int32] 71 | extractRerefenceTypeOffsets = map fst . filter (isReferenceType . snd) . getFieldSignatures 72 | 73 | showRefs2 :: Integral a => [a] -> [String] 74 | showRefs2 = map (show . intPtrToPtr . fromIntegral) 75 | 76 | mallocClassData :: Int -> IO (Ptr a) 77 | mallocClassData size = do 78 | printfMem $ printf "mallocClassData: %d\n" size 79 | mem <- F.mallocBytes size 80 | BI.memset (castPtr mem) 0 (fromIntegral size) 81 | addRootGC mem (plusPtr mem size) 82 | return mem 83 | 84 | mallocStringGC :: Int -> IO (Ptr a) 85 | mallocStringGC size = do 86 | let size' = size + (size `rem` 4) 87 | printfMem $ printf "mallocString: %d\n" size' 88 | addr <- mallocObjectGC size' 89 | addRootPrecise (fromIntegral addr) 90 | let ptr' = intPtrToPtr (fromIntegral addr) 91 | printfMem $ printf "string got: %s\n" (show ptr') 92 | BI.memset ptr' 0 (fromIntegral size') 93 | return ptr' 94 | 95 | 96 | -- | allocates gc tracked obj. for precise gc no gc will take place 97 | -- use mallocObjectGC_stacktrace instead if gc should take place 98 | mallocObjectGC :: Int -> IO CPtrdiff 99 | mallocObjectGC size = do 100 | ptr <- alloc Nothing size 101 | BI.memset (castPtr ptr) 0 (fromIntegral size) 102 | printfMem $ printf "mallocObject: %d\n" size 103 | let addr = fromIntegral $ ptrToIntPtr ptr 104 | when (addr == 0) $ error "mallocObjectGC: ptr is null" 105 | return addr 106 | 107 | -- allocates using precise or boehmgc. the first argument describes whether 108 | -- gc may take place (if nothing, no rebp provided and no precise gc can ever work) 109 | alloc :: Maybe (CPtrdiff, CPtrdiff) -> Int -> IO (Ptr a) 110 | alloc regs size = 111 | if usePreciseGC 112 | then allocObjAndDoGCPrecise regs size 113 | else allocObjBoehm regs size 114 | 115 | 116 | -- | allocates gc tracked obj. sptr and rebp must be given. If now available use 117 | -- mallocObjectGC instead 118 | mallocObjectGC_stackstrace :: CPtrdiff -> CPtrdiff -> Int -> IO CPtrdiff 119 | mallocObjectGC_stackstrace eip rebp size = do 120 | printfMem $ printf "mallocObject: %d\n" size 121 | printfMem $ printf "ebp @ malloc: 0x%08x\n" (fromIntegral rebp :: Word32) 122 | printfMem $ printf "eip @ malloc: 0x%08x\n" (fromIntegral eip :: Word32) 123 | ptr <- alloc (Just (eip, rebp)) size 124 | BI.memset (castPtr ptr) 0 (fromIntegral size) 125 | return $ fromIntegral $ ptrToIntPtr ptr 126 | 127 | allocObjBoehm :: Maybe (CPtrdiff,CPtrdiff) -> Int -> IO (Ptr a) 128 | allocObjBoehm _ size = do 129 | printfMem "do alloc boehm. \n" 130 | mallocBytesGC size 131 | 132 | getHeapMemory :: IO Int 133 | getHeapMemory = getHeapSizeGC 134 | 135 | foreign export ccall printMemoryUsage :: IO () 136 | printMemoryUsage :: IO () 137 | printMemoryUsage = getHeapMemory >>= print 138 | 139 | foreign export ccall printGCStats :: IO () 140 | printGCStats :: IO () 141 | printGCStats = putStrLn "Should print GC Stats" 142 | 143 | -- from now: very hacky and very very evil test stuff 144 | 145 | -- returns stacktrace if (eip,rebp) is valid and the stack is 146 | -- initiated from calls. 147 | getStackIfPossible :: Maybe (CPtrdiff,CPtrdiff) -> IO [StackDescription] 148 | getStackIfPossible (Just (eip,rebp)) = getStack eip rebp 149 | getStackIfPossible Nothing = printfGc "no sptr, rebp provided. no gc should take place\n" >> return [] 150 | 151 | -- | gets stack according to valid sptr and rebp. if stack is invalid 152 | -- an empty stack is returned 153 | getStack :: CPtrdiff -> CPtrdiff -> IO [StackDescription] 154 | getStack eip rebp = do 155 | stacktrace <- printStackTrace' eip rebp 156 | if isValidTrace stacktrace 157 | then printfGc "valid stack\n" >> return stacktrace 158 | else printfGc "invalid stack for gc\n" >> return [] 159 | 160 | -- | checks whether a stack should be used to retrieve gc root set 161 | -- i.e. GC can take place at this point 162 | isValidTrace :: [StackDescription] -> Bool 163 | isValidTrace (x:_) = not $ startswith "" (toString (rsiMethodname $ stackinfo x)) 164 | isValidTrace [] = True 165 | 166 | -- | allocates obj and performs gc if possible 167 | allocObjAndDoGCPrecise :: Maybe (CPtrdiff,CPtrdiff) -> Int -> IO (Ptr a) 168 | allocObjAndDoGCPrecise regs size = do 169 | if useLeakingGCForJitBenches 170 | then do 171 | printfGc "alloc using GenerationalGC but will not perform GC. (useLeakingGCForJitBenches)" 172 | gcState <- readIORef genGC 173 | (ptr,gcState') <- runStateT (Gen.mallocBytesGen GC.mkGen0 size :: StateT B.GcState IO (Ptr b)) gcState 174 | writeIORef genGC gcState' 175 | return ptr 176 | else do 177 | printfGc "allocObjAndDoGCPrecise begin...\n" 178 | stack <- getStackIfPossible regs 179 | 180 | if useBlockAllocator 181 | then do 182 | permRoots <- return []--readIORef permGenRoots 183 | gcState <- readIORef genGC 184 | 185 | xs <- readIORef permGenRoots 186 | printfGc $ printf "gc root: %s" (show $ map intPtrToPtr xs) 187 | ys <- (mapM (peek . intPtrToPtr) xs) :: IO [IntPtr] 188 | printfGc $ printf "*gc root: %s" (show $ map intPtrToPtr ys) 189 | 190 | patches <- Gen.buildPatchAction stack permRoots 191 | 192 | let collectAndAlloc = (if null stack 193 | then return () 194 | else Gen.collectGen patches) >> 195 | Gen.mallocBytesGen GC.mkGen0 size :: StateT B.GcState IO (Ptr b) 196 | 197 | printfGc "running statetGC\n\n" 198 | (ptr,gcState') <- runStateT collectAndAlloc gcState 199 | writeIORef genGC gcState' 200 | printfGc "GC finished\n\n" 201 | 202 | return ptr 203 | else do 204 | permRoots <- readIORef permGenRoots 205 | let gcAction = buildGCAction (error "no geninfo") stack permRoots size 206 | 207 | memoryManager <- readIORef twoSpaceGC 208 | (ptr,memoryManager') <- runStateT gcAction memoryManager 209 | writeIORef twoSpaceGC memoryManager' 210 | 211 | printfGc "allocObjAndDoGCPrecise completed.\n" 212 | return ptr 213 | 214 | {-# NOINLINE twoSpaceGC #-} 215 | twoSpaceGC :: IORef TwoSpace 216 | twoSpaceGC = if not useBlockAllocator 217 | then unsafePerformIO $ initTwoSpace 0x1000000 >>= newIORef 218 | else error "tried to initialize twospace allocator but block allocator is set according to Flags" 219 | 220 | {-# NOINLINE permGenRoots #-} 221 | permGenRoots :: IORef [IntPtr] 222 | permGenRoots = unsafePerformIO $ newIORef [] 223 | 224 | addRootPrecise :: IntPtr -> IO () 225 | addRootPrecise ptr = modifyIORef permGenRoots (ptr:) 226 | 227 | {-# NOINLINE genGC #-} 228 | genGC :: IORef B.GcState 229 | genGC = if useBlockAllocator 230 | then unsafePerformIO $ Gen.initGen heapSize >>= newIORef 231 | else error "tried to initialize generational gc but block allocation is disabled (enable flag!)" 232 | -------------------------------------------------------------------------------- /MateVMRuntime/GarbageAlloc.hs-boot: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.GarbageAlloc where 2 | 3 | import MateVMRuntime.Types 4 | import Foreign 5 | import Foreign.C 6 | 7 | mallocClassData :: Int -> IO (Ptr a) 8 | mallocStaticData :: Int -> FieldTypeMap -> IO (Ptr a) 9 | mallocObjectUnmanaged :: Int -> IO CPtrdiff 10 | mallocStringUnmanaged :: Int -> IO (Ptr a) 11 | mallocStringGC :: Int -> IO (Ptr a) 12 | mallocObjectGC :: Int -> IO CPtrdiff 13 | mallocObjectGC_stackstrace :: CPtrdiff -> CPtrdiff -> Int -> IO CPtrdiff 14 | 15 | 16 | printGCStats :: IO () 17 | printMemoryUsage :: IO () 18 | getHeapMemory :: IO Int 19 | -------------------------------------------------------------------------------- /MateVMRuntime/GarbageAlloc.o-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/GarbageAlloc.o-boot -------------------------------------------------------------------------------- /MateVMRuntime/GarbageAlloc_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsInt64 mallocObjectGC_stackstrace(HsInt64 a1, HsInt64 a2, HsInt a3); 6 | extern HsInt64 mallocObjectGC(HsInt a1); 7 | extern void printMemoryUsage(void); 8 | extern void printGCStats(void); 9 | #ifdef __cplusplus 10 | } 11 | #endif 12 | 13 | -------------------------------------------------------------------------------- /MateVMRuntime/GenerationalGC.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module MateVMRuntime.GenerationalGC where 3 | 4 | import Foreign 5 | import qualified Foreign.Marshal.Alloc as Alloc 6 | import Control.Monad.State 7 | import qualified Data.Map as M 8 | import Data.Map(Map,(!)) 9 | import qualified Data.Set as S 10 | import Data.List 11 | 12 | import MateVMRuntime.BlockAllocation 13 | import MateVMRuntime.GC 14 | import MateVMRuntime.Debug 15 | import MateVMRuntime.MemoryManager 16 | import MateVMRuntime.RtsOptions 17 | import qualified MateVMRuntime.StackTrace as T 18 | 19 | maxGen :: Int 20 | maxGen = 2 -- means 0,1,2 21 | 22 | instance AllocationManager GcState where 23 | initMemoryManager = initGen 24 | mallocBytesT = mallocBytesGen 25 | performCollection = collectGen 26 | collectLoh = collectLohTwoSpace 27 | heapSize = error "heap size in GenGC not implemented" 28 | validRef = error "valid ref in GenGC not implemented" 29 | 30 | initGen :: Int -> IO GcState 31 | initGen size' = do 32 | freshAllocState <- mkAllocC size' 33 | return GcState { generations = foldr (\i m -> M.insert i (generation' i) m) M.empty [0..maxGen], 34 | allocs = 0, 35 | allocatedBytes = 0 , 36 | loh = S.empty, 37 | allocState = freshAllocState } 38 | where generation' i = GenState { freeBlocks = [], 39 | activeBlocks = M.empty, 40 | collections = 0, 41 | generation = i } 42 | 43 | 44 | mallocBytesGen :: GenInfo -> Int -> StateT GcState IO (Ptr b) 45 | mallocBytesGen gen size' = 46 | if size' > loThreshhold 47 | then allocateLoh size' 48 | else do 49 | ptr <- runBlockAllocatorC gen size' 50 | current <- get 51 | put $ current { allocs = 1 + allocs current } 52 | logGcT $ printf "object got: %s\n" (show ptr) 53 | return ptr 54 | 55 | allocateLoh :: Int -> StateT GcState IO (Ptr b) 56 | allocateLoh size' = do 57 | current <- get 58 | let currentLoh = loh current 59 | ptr <- liftIO $ Alloc.mallocBytes size' 60 | put $ current { loh = S.insert (ptrToIntPtr ptr) currentLoh } 61 | liftIO $ printfGc $ printf "LOH: allocated %d bytes in loh %s" size' (show ptr) 62 | return ptr 63 | 64 | collectLohTwoSpace :: (RefObj a) => [a] -> StateT GcState IO () 65 | collectLohTwoSpace xs = do 66 | current <- get 67 | intptrs <- liftIO $ mapM getIntPtr xs 68 | let oldLoh = loh current 69 | let newSet = S.fromList intptrs 70 | let toRemove = oldLoh `S.difference` newSet 71 | liftIO $ printfGc $ printf "objs in loh: %d" (S.size oldLoh) 72 | liftIO $ printfGc $ printf "old loh: %s" (show $ showRefs $ S.toList oldLoh) 73 | liftIO $ printfGc $ printf "to remove: %s" (show $ showRefs $ S.toList toRemove) 74 | liftIO $ mapM (free . intPtrToPtr) (S.toList toRemove) 75 | put current { loh = newSet } 76 | 77 | -- given an element in generation x -> where to evaucuate to 78 | sourceGenToTargetGen :: Int -> Int 79 | sourceGenToTargetGen 0 = 1 80 | sourceGenToTargetGen 1 = 2 81 | sourceGenToTargetGen 2 = 2 82 | sourceGenToTargetGen x = error $ "source object is in strange generation: " ++ show x 83 | 84 | collectGen :: (RefObj b) => Map b RefUpdateAction -> StateT GcState IO () 85 | collectGen roots = do 86 | cnt <- liftM allocs get 87 | performCollectionGen (calculateGeneration cnt) roots 88 | --performCollectionGen Nothing roots 89 | 90 | calculateGeneration :: Int -> Maybe Int 91 | calculateGeneration x | x < 20 = Nothing 92 | | x < 50 = Just 0 93 | | x < 60 = Just 1 94 | | otherwise = Just 2 95 | 96 | performCollectionGen :: (RefObj b) => Maybe Int -> Map b RefUpdateAction -> StateT GcState IO () 97 | performCollectionGen Nothing _ = logGcT "skipping GC. not necessary atm. tune gc settings if required" 98 | performCollectionGen (Just generation') roots = do 99 | current <- get 100 | put current { allocs = 0 } 101 | logGcT $ printf "!!! runn gen%d collection" generation' 102 | let rootList = map fst $ M.toList roots 103 | logGcT $ printf "rootSet: %s\n " (show rootList) 104 | toKill <- performCollectionGen' generation' rootList 105 | logGcT "patch gc roots.." 106 | liftIO $ patchGCRoots roots 107 | logGcT "all done \\o/" 108 | freeGensIOC toKill 109 | 110 | 111 | buildPatchAction :: [T.StackDescription] -> [IntPtr] -> IO (Map (Ptr b) RefUpdateAction) 112 | buildPatchAction [] _ = return M.empty 113 | buildPatchAction stack roots = do 114 | let rootsOnStack = roots ++ concatMap T.candidates stack 115 | rootCandidates <- mapM dereference rootsOnStack 116 | let realRoots = filter ((/= 0) . snd) rootCandidates 117 | return $ foldr buildRootPatcher2 M.empty realRoots 118 | 119 | 120 | buildRootPatcher2 :: (IntPtr,IntPtr) -> Map (Ptr b) RefUpdateAction -> Map (Ptr b) RefUpdateAction 121 | buildRootPatcher2 (ptr,obj) = M.insertWith both ptr' patch 122 | where patch newLocation = do printfGc $ printf "patch new ref: 0x%08x on stackloc: 0x%08x .. " 123 | (fromIntegral newLocation :: Int) (fromIntegral ptr :: Int) 124 | poke (intPtrToPtr ptr) newLocation 125 | printfPlain "=>patched.\n" 126 | ptr' = intPtrToPtr obj 127 | 128 | both newPatch oldPatch newLocation = do newPatch newLocation 129 | oldPatch newLocation 130 | 131 | replaceIndices :: Eq a => [Int] -> Map Int a -> (Int -> a) -> Map Int a 132 | replaceIndices indices m repl = foldr replace m indices 133 | where replace index = M.insert index (repl index) 134 | 135 | takeIndices :: Map Int a -> [Int] -> [a] 136 | takeIndices xs = map (\x -> xs!x) 137 | 138 | switchStates :: Int -> StateT GcState IO [GenState] 139 | switchStates collection = do 140 | let toBeReplaced = [0..collection] --all collections up to collection should be replaced by empty ones 141 | current <- get 142 | let gens = generations current 143 | let newGens = replaceIndices toBeReplaced gens mkGenState 144 | logGcT $ printf "new generations: %s" (show newGens) 145 | put current { generations = newGens } 146 | logGcT $ printf "generations to be killed: %s" (show toBeReplaced) 147 | return $ takeIndices gens toBeReplaced 148 | 149 | performCollectionGen' :: (RefObj a) => Int -> [a] -> StateT GcState IO [GenState] 150 | performCollectionGen' collection refs' = do 151 | toKill <- switchStates collection 152 | logGcT "==>Phase 1. Marking..\n" 153 | objFilter <- markedOrInvalid 154 | allLifeRefs <- liftIO $ liftM (nub . concat) $ mapM (markTree'' objFilter mark refs') refs' 155 | logGcT "==>Done Phase 1.\n" 156 | toEvacuate <- liftIO $ filterM (getIntPtr >=> return . hasMTable) allLifeRefs 157 | if gcLogEnabled 158 | then liftIO $ mapM_ (getIntPtr >=> \x -> printfGc $ printf " 0x%08x" (fromIntegral x ::Int) ) toEvacuate 159 | else return () 160 | (largeObjs,lifeRefs) <- liftIO $ extractLargeObjects toEvacuate 161 | logGcT "\nPhase 2. Evacuating...\n" 162 | evacuate' (\objGen -> targetGen objGen <= collection) getRefInfo lifeRefs 163 | logGcT "Phase 2. Done.\n" 164 | if useLoh 165 | then do 166 | logGcT "killing unsued large objs\n" 167 | collectLoh largeObjs 168 | logGcT "cleaned up loh\n" 169 | else return (); 170 | liftIO $ patchAllRefs (getIntPtr >=> \x -> return $ x /= 0) lifeRefs 171 | logGcT "patched2.\n" 172 | return toKill 173 | 174 | 175 | getRefInfo :: (RefObj a) => a -> IO GenInfo 176 | getRefInfo obj = do 177 | intPtr <- getIntPtr obj 178 | let begin = shift (shift intPtr (-blockSizePowerOfTwo)) blockSizePowerOfTwo 179 | generation' <- peek (intPtrToPtr begin) 180 | printfGc $ printf "got a reference in generation: %d\n" generation' 181 | return GenInfo { targetGen = min 2 generation' } 182 | -------------------------------------------------------------------------------- /MateVMRuntime/JavaObjects.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module MateVMRuntime.JavaObjects 4 | ( getUniqueStringAddr 5 | , allocAndInitObject 6 | , cloneObject 7 | , getObjectSizePtr 8 | , getObjectFieldCountPtr 9 | , getClassNamePtr 10 | , isReferenceType 11 | ) where 12 | 13 | import Data.Word 14 | import qualified Data.Map as M 15 | import qualified Data.ByteString.Lazy as B 16 | import qualified Data.ByteString.Internal as BI 17 | import Control.Applicative 18 | import Control.Monad 19 | 20 | import JVM.ClassFile 21 | 22 | import Foreign 23 | import Foreign.C.Types 24 | 25 | import MateVMRuntime.NativeSizes 26 | import MateVMRuntime.ClassPool 27 | import {-# SOURCE #-} MateVMRuntime.GarbageAlloc 28 | import {-# SOURCE #-} MateVMRuntime.MethodPool 29 | 30 | import MateVMRuntime.Debug 31 | import MateVMRuntime.Types 32 | 33 | getUniqueStringAddr :: B.ByteString -> IO NativeWord 34 | getUniqueStringAddr str = do 35 | smap <- getStringMap 36 | case M.lookup str smap of 37 | Nothing -> do 38 | addr <- allocateJavaString str 39 | setStringMap $ M.insert str addr smap 40 | return addr 41 | Just addr -> return addr 42 | 43 | allocateJavaString :: B.ByteString -> IO NativeWord 44 | allocateJavaString str = do 45 | {- we have to build a java object layout here, where String object looks like 46 | - 47 | - this -+ 48 | - | 49 | - v 50 | - +-------------+---------+-------+-------+----------------+--------+ 51 | - | MethodTable | GC Data | value | count | cachedhashcode | offset | 52 | - +-------------+---------+-------+-------+----------------+--------+ 53 | - | | 54 | - | +------+ 55 | - v v 56 | - java/lang/String +-------+--------+--------+--------+--------+-----+------------------+ 57 | - | mtbl | gcinfo | length | str[0] | str[1] | ... | str [length - 1] | 58 | - +-------+--------+--------+--------+--------+-----+------------------+ 59 | - all cells are 32bit wide, except str[i] of course (they're 8bit [but 60 | - should be 16bit, TODO]). 61 | - mtbl is a fake mtable as for all arrays, same for gcinfo. 62 | -} 63 | -- build object layout 64 | fsize <- getObjectSize "java/lang/String" 65 | printfStr $ printf "string: fsize: %d (should be 4 * 6)\n" fsize 66 | tblptr <- mallocObjectUnmanaged $ fromIntegral fsize 67 | let ptr = intPtrToPtr (fromIntegral tblptr) :: Ptr CPtrdiff 68 | mtbl <- getMethodTable "java/lang/String" 69 | 70 | -- build array layout 71 | let strlen = fromIntegral $ B.length str 72 | 73 | -- array objects have || method_table_fake | gc_data | length | ... \0 (for strings) || 74 | -- [hs] i kept length + \0 and object correction separate for clarity 75 | let arrayObjCorr = 2 * ptrSize 76 | -- (+1) for \0, (+4) for length 77 | newstr <- mallocStringGC (strlen + 5 + arrayObjCorr) 78 | BI.memset newstr 0 (fromIntegral $ strlen + 5 + arrayObjCorr) 79 | -- set array fake mtbl and gcinfo 80 | poke (plusPtr newstr arrayMagic) primitiveArrayMagic 81 | poke (plusPtr newstr arrayGC) (0x0 :: Word32) 82 | arr <- newArray ((map fromIntegral $ B.unpack str) :: [Word8]) 83 | copyBytes (plusPtr newstr (4 + arrayObjCorr)) arr strlen 84 | printfStr $ printf "new str ptr: (%s)@%d\n" (toString str) strlen 85 | 86 | poke (plusPtr newstr arrayLength) (fromIntegral strlen :: Int32) 87 | 88 | -- set mtable 89 | poke (plusPtr ptr objectMtable) (fromIntegral mtbl :: CPtrdiff) 90 | -- set GC Data (0 is ok for gc data) 91 | poke (plusPtr ptr objectGC) (0 :: CPtrdiff) 92 | -- set value pointer 93 | poke (plusPtr ptr 0x8) (fromIntegral (ptrToIntPtr newstr) :: CPtrdiff) 94 | -- set count field 95 | poke (plusPtr ptr 0xc) (fromIntegral strlen :: CPtrdiff) 96 | -- set hash code (TODO) 97 | poke (plusPtr ptr 0x10) (0 :: CPtrdiff) 98 | -- set offset 99 | poke (plusPtr ptr 0x14) (0 :: CPtrdiff) 100 | 101 | return $ fromIntegral tblptr 102 | 103 | 104 | foreign import ccall "dynamic" 105 | code_ref :: FunPtr (CPtrdiff -> IO ()) -> CPtrdiff -> IO () 106 | 107 | allocAndInitObject :: B.ByteString -> IO CPtrdiff 108 | allocAndInitObject p = do 109 | let mi = MethodInfo "" p $ MethodSignature [] ReturnsVoid 110 | obj <- fromIntegral <$> getObjectSize p >>= mallocObjectGC 111 | let objptr = intPtrToPtr (fromIntegral obj) 112 | mtable <- getMethodTable p 113 | poke (plusPtr objptr objectMtable) mtable 114 | poke (plusPtr objptr objectGC) (0x1337babe :: CPtrdiff) 115 | entry <- lookupMethodEntry mi 116 | let fptr = (castPtrToFunPtr . intPtrToPtr . fromIntegral $ entry) :: FunPtr (CPtrdiff -> IO ()) 117 | code_ref fptr obj 118 | return obj 119 | 120 | -- [TODO hs] fix cloneObject 121 | foreign export ccall cloneObject :: CPtrdiff -> IO CPtrdiff 122 | cloneObject :: CPtrdiff -> IO CPtrdiff 123 | cloneObject obj_to_clone = do 124 | let ptr = intPtrToPtr $ fromIntegral obj_to_clone :: Ptr NativeWord 125 | mtable <- peek ptr 126 | maybeObjTable <- getMethodTableReverse mtable 127 | case maybeObjTable of 128 | Nothing -> error "cloneObject performed which returned Nothing." 129 | Just v -> do size <- getObjectSize v 130 | obj <- mallocObjectGC (fromIntegral size) 131 | let objptr = intPtrToPtr (fromIntegral obj) 132 | copyBytes objptr ptr (fromIntegral size) 133 | return obj 134 | 135 | 136 | {-nativeWordToPtr :: NativeWord -> Ptr a 137 | nativeWordToPtr = intPtrToPtr . fromIntegral 138 | 139 | ptrToNativeWord :: Ptr a -> NativeWord 140 | ptrToNativeWord = fromIntegral . ptrToIntPtr 141 | -} 142 | 143 | getClassNamePtr :: Ptr a -> IO (Maybe B.ByteString) 144 | getClassNamePtr ptr = do 145 | method_table <- peek (castPtr ptr) :: IO Word32 146 | getMethodTableReverse method_table 147 | 148 | getObjectSizePtr :: Ptr a -> IO Int 149 | getObjectSizePtr ptr = do 150 | clazzNameM <- getClassNamePtr ptr 151 | case clazzNameM of 152 | Nothing -> error $ "getObjectSizePtr called on non mate object (getClassNamePtr returned Nothing)" ++ (show ptr) 153 | Just clazzName -> liftM fromIntegral $ getObjectSize clazzName 154 | 155 | getObjectFieldCountPtr :: Ptr a -> IO Int 156 | getObjectFieldCountPtr ptr = do 157 | clazzNameM <- getClassNamePtr ptr 158 | case clazzNameM of 159 | Nothing -> error "getObjectFieldCountPtr called on non mate object (getClassNamePtr returned Nothing)" 160 | Just clazzName -> liftM fromIntegral $ getFieldCount clazzName 161 | 162 | 163 | isReferenceType :: FieldSignature -> Bool 164 | isReferenceType (ObjectType _) = True 165 | isReferenceType (Array _ _) = True 166 | isReferenceType _ = False 167 | -------------------------------------------------------------------------------- /MateVMRuntime/JavaObjectsGC.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module MateVMRuntime.JavaObjectsGC 3 | ( RefObj(..) 4 | , printRef' 5 | , validMateObj 6 | , hasMTable 7 | ) where 8 | 9 | import MateVMRuntime.GC 10 | 11 | import Foreign.Ptr 12 | import Foreign.Marshal.Array 13 | import Foreign.Storable 14 | import GHC.Int 15 | 16 | import Text.Printf 17 | import Control.Monad 18 | import JVM.ClassFile 19 | import MateVMRuntime.JavaObjects 20 | import MateVMRuntime.Debug 21 | import MateVMRuntime.ClassPool 22 | import qualified MateVMRuntime.Types as T 23 | 24 | instance RefObj (Ptr a) where 25 | getIntPtr = return . ptrToIntPtr 26 | size = getSize 27 | refs = unpackRefs 28 | marked = markedRef 29 | mark = markRef (0x1::Int32) 30 | unmark = markRef (0x0::Int32) 31 | setNewRef = setNewRefPtr 32 | patchRefs = patchRefsPtr 33 | cast = castPtr 34 | getNewRef ptr = do 35 | ptr' <- peekByteOff ptr newPtrOffset 36 | if 1 == (fromIntegral $ ptrToIntPtr ptr' :: Int32) -- only marked (case for large obs) 37 | then do printfGc "not movable obj\n" 38 | return ptr 39 | else return ptr' 40 | allocationOffset _ = 0 41 | 42 | validObj ptr = do 43 | objAsPtr <- getIntPtr ptr 44 | return $ objAsPtr /= 0 && objAsPtr /= 0x1228babe && objAsPtr /= 0x1227b 45 | 46 | printRef = printRef' 47 | 48 | 49 | newPtrOffset :: Int 50 | newPtrOffset = T.objectGC 51 | 52 | isArrayMagicNumber :: Int32 -> Bool 53 | isArrayMagicNumber ptr = ptr == fromIntegral T.referenceArrayMagic || ptr == fromIntegral T.primitiveArrayMagic 54 | 55 | hasMTable :: IntPtr -> Bool 56 | hasMTable objAsPtr = objAsPtr /= 0 && objAsPtr /= fromIntegral T.primitiveArrayMagic 57 | && objAsPtr /= fromIntegral T.referenceArrayMagic 58 | 59 | -- [TODO hs] fix for array[array] 60 | unpackRefs :: Ptr a -> IO [Ptr a] 61 | unpackRefs ptr = do 62 | isarray <- isArray ptr 63 | if isarray 64 | then do 65 | method_table <- peekByteOff ptr 0 :: IO Int32 66 | if method_table == fromIntegral T.referenceArrayMagic 67 | then do len <- peekByteOff ptr 8 :: IO Int 68 | printfGc "got reference type array\n" 69 | peekArray len (ptr `plusPtr` 12) 70 | else do printfGc "got primitive array\n" 71 | return [] -- is array but primitives 72 | else do 73 | classPtr <- getClassNamePtr ptr 74 | fieldOffsets <- case classPtr of 75 | Just v -> 76 | do fieldTypes <- getFieldTypes v 77 | printfGc $ printf "got types blubber %s with fields: %s\n" (show v) (show fieldTypes) 78 | let referenceFieldOffsets = filterReferenceFields fieldTypes 79 | return referenceFieldOffsets 80 | Nothing -> printfGc "could not get class name ptr" >> return [] 81 | -- this is wrong - use reference types only here. 82 | -- numberOfFields <- getObjectFieldCountPtr ptr 83 | -- peekArray numberOfFields (ptr `plusPtr` fieldsOffset) 84 | mapM ( peek . plusPtr ptr) fieldOffsets 85 | 86 | filterReferenceFields :: [(Int32, FieldSignature)] -> [Int] 87 | filterReferenceFields = 88 | map (fromIntegral . fst) . filter (isReferenceType . snd) 89 | 90 | 91 | isArray :: Ptr a -> IO Bool 92 | isArray ptr = do 93 | method_table <- peekByteOff ptr 0 :: IO Int32 94 | return $ isArrayMagicNumber method_table 95 | 96 | validMateObj :: IntPtr -> IO Bool 97 | validMateObj intPtr = do let ptr = intPtrToPtr intPtr 98 | isarray <- isArray ptr 99 | if isarray 100 | then return True 101 | else do 102 | clazzNameM <- getClassNamePtr ptr 103 | case clazzNameM of 104 | Nothing -> do printfGc "invalid.\n" 105 | return False 106 | Just _ -> return True 107 | 108 | getSize :: Ptr a -> IO Int 109 | getSize ptr = do 110 | isarray <- isArray ptr 111 | if isarray 112 | then getArrayObjectSize ptr 113 | else getObjectSizePtr ptr 114 | 115 | getArrayObjectSize :: Ptr a -> IO Int 116 | getArrayObjectSize ptr = do 117 | len <- peekByteOff ptr 8 :: IO Int 118 | return $ 12 + len * 4 119 | 120 | markedRef :: Ptr a -> IO Bool 121 | markedRef ptr = liftM (/= (0::Int32)) (peekByteOff ptr T.objectGC :: IO Int32) 122 | 123 | markRef :: Int32 -> Ptr a -> IO () 124 | markRef val ptr = pokeByteOff ptr T.objectGC val 125 | 126 | setNewRefPtr :: Ptr a -> Ptr a -> IO () 127 | setNewRefPtr ptr = pokeByteOff ptr newPtrOffset 128 | 129 | patchRefsPtr :: Ptr a -> [Ptr a] -> IO () 130 | patchRefsPtr ptr xs = do 131 | isarray <- isArray ptr 132 | if isarray 133 | then pokeArray (ptr `plusPtr` T.arrayBase) xs 134 | else pokeArray (ptr `plusPtr` T.objectField) xs 135 | 136 | printInt32 :: String -> Int32 -> IO () 137 | printInt32 str ptr = printfGc $ printf str ptr 138 | 139 | doLoop :: IO a 140 | doLoop = doLoop 141 | 142 | printRef' :: Ptr a -> IO () 143 | printRef' ptr = do 144 | printInt32 "Print Obj: address 0x%08x\n" =<< (liftM fromIntegral (getIntPtr ptr) :: IO Int32) 145 | printInt32 "method_table: 0x%08x\n" =<< (peekByteOff ptr 0 :: IO Int32) 146 | method_table <- peekByteOff ptr 0 :: IO Int32 147 | 148 | let printObj = do 149 | printfGc $ printf "we got an object: %s" (show ptr) 150 | clazzNameM <- getClassNamePtr ptr 151 | clazzName <- case clazzNameM of 152 | Just v -> return v 153 | Nothing -> do printfGc $ "getClassNamePtr called on non mate obj1: " ++ show ptr ++ "\n" 154 | printfGc $ printf "trying to dump on %s" (show ptr) 155 | mem <- peekArray 12 (castPtr ptr) :: IO [Ptr Int32] 156 | printfGc $ printf "dump: %s" (show mem) 157 | doLoop 158 | printfGc $ printf "type: %s\n" $ toString clazzName 159 | fieldCnt <- getObjectFieldCountPtr ptr 160 | printfGc $ printf "children 0x%08x\n" fieldCnt 161 | markedBit <- peekByteOff ptr T.objectGC :: IO Int32 162 | printInt32 "marked 0x%08x\n" markedBit 163 | printInt32 "newRef 0x%08x\n" =<< (peekByteOff ptr newPtrOffset :: IO Int32) 164 | printChildren ptr 165 | printfGc "\n" 166 | 167 | let printArray = 168 | do 169 | printfGc $ printf "we got an array\n" 170 | len <- peekByteOff ptr 8 :: IO Int32 171 | printfGc $ printf "length: 0x%08x\n" len 172 | printChildren ptr 173 | 174 | 175 | if isArrayMagicNumber method_table 176 | then printArray 177 | else printObj 178 | 179 | printChildren :: Ptr a -> IO () 180 | printChildren ptr = do children <- refs ptr 181 | printfGc $ "children" ++ show children 182 | -------------------------------------------------------------------------------- /MateVMRuntime/JavaObjects_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsInt64 cloneObject(HsInt64 a1); 6 | #ifdef __cplusplus 7 | } 8 | #endif 9 | 10 | -------------------------------------------------------------------------------- /MateVMRuntime/MemoryManager.hs: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.MemoryManager 2 | ( AllocationManager(..) 3 | , buildGCAction 4 | , dereference 5 | , RootSet 6 | , buildRootPatcher 7 | , extractLargeObjects 8 | , markedOrInvalid 9 | , hasMTable) where 10 | 11 | import Foreign 12 | 13 | import Text.Printf 14 | import Control.Monad.State 15 | import qualified Data.Map as M 16 | 17 | import MateVMRuntime.Debug 18 | import MateVMRuntime.GC hiding (size) 19 | import qualified MateVMRuntime.StackTrace as T 20 | import qualified MateVMRuntime.JavaObjectsGC as GCObj 21 | import MateVMRuntime.JavaObjectsGC(hasMTable) -- only instances for Ptr a 22 | 23 | type RootSet a = M.Map (Ptr a) RefUpdateAction 24 | 25 | 26 | markedOrInvalid :: (RefObj a, AllocationManager b) => StateT b IO (a -> IO Bool) 27 | markedOrInvalid = 28 | return $ \obj -> do objAsPtr <- getIntPtr obj 29 | printfGc $ printf "check obj: 0x%08x" (fromIntegral objAsPtr :: Int) 30 | --let valid = validRef' objAsPtr memManager 31 | if hasMTable objAsPtr-- this was not necassary before perm gens (now direct refs onto objs) 32 | then do validObj' <- GCObj.validMateObj objAsPtr 33 | if validObj' 34 | then do 35 | printfGc "gheck makred\n" 36 | liftIO $ marked obj 37 | else do 38 | printfGc "not valid1\n" 39 | return True 40 | else do printfGc "not valid1\n" 41 | return True -- not valid reference 42 | 43 | 44 | buildGCAction :: AllocationManager a => GenInfo -> [T.StackDescription] -> [IntPtr] -> Int -> StateT a IO (Ptr b) 45 | buildGCAction info [] _ size = mallocBytesT info size 46 | buildGCAction info stack perm size = 47 | do let rootsOnStack = perm ++ concatMap T.candidates stack --concatMap T.possibleRefs stack 48 | rootCandidates <- lift $ mapM dereference rootsOnStack 49 | realRoots <- filterM (notNullRef . snd) rootCandidates 50 | performCollection $ foldr buildRootPatcher M.empty realRoots 51 | mallocBytesT info size 52 | 53 | 54 | dereference :: IntPtr -> IO (IntPtr,IntPtr) 55 | dereference intPtr = do 56 | printfGc $ printf "rootReference (stacklocation): 0x%08x\n" (fromIntegral intPtr :: Int) 57 | obj <- peek $ intPtrToPtr intPtr :: IO IntPtr 58 | printfGc $ printf "*(rootElement): " 59 | printfGc (show (intPtrToPtr obj) ++ "\n") 60 | return (intPtr,obj) 61 | 62 | -- (stackLocation,obj) 63 | buildRootPatcher :: (IntPtr,IntPtr) -> RootSet a -> RootSet a 64 | buildRootPatcher (ptr,obj) = M.insertWith both ptr' patch 65 | where patch newLocation = do printfGc $ printf "patch new ref: 0x%08x on stackloc: 0x%08x .. " 66 | (fromIntegral newLocation :: Int) (fromIntegral ptr :: Int) 67 | poke (intPtrToPtr ptr) newLocation 68 | printfPlain "=>patched.\n" 69 | ptr' = intPtrToPtr obj 70 | 71 | both newPatch oldPatch newLocation = do newPatch newLocation 72 | oldPatch newLocation 73 | -------------------------------------------------------------------------------- /MateVMRuntime/MethodPool.hi-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/MethodPool.hi-boot -------------------------------------------------------------------------------- /MateVMRuntime/MethodPool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module MateVMRuntime.MethodPool 4 | ( lookupMethodEntry 5 | , executeFuncPtr 6 | ) where 7 | 8 | import qualified Data.Map as M 9 | import qualified Data.Set as S 10 | import qualified Data.ByteString.Char8 as C8 11 | import qualified Data.ByteString.Lazy as B 12 | import Data.Binary 13 | import Data.Maybe (fromJust) 14 | 15 | import Foreign 16 | import Foreign.C.Types 17 | import Unsafe.Coerce 18 | 19 | import JVM.ClassFile 20 | import JVM.Assembler 21 | 22 | import MateVMRuntime.Debug 23 | import MateVMRuntime.Types 24 | 25 | import MateVMRuntime.NativeSizes 26 | import MateVMRuntime.Utilities 27 | import MateVMRuntime.ClassPool 28 | import MateVMRuntime.NativeMethods 29 | 30 | import qualified LLVM.AST as AST 31 | import qualified LLVM.AST.Global as LG 32 | import qualified LLVM.AST.Linkage as LL 33 | import qualified LLVM.ExecutionEngine as EE 34 | import qualified LLVM.AST.Constant as LC 35 | import LLVM.Context 36 | import LLVM.CodeModel 37 | import LLVM.Target 38 | import qualified LLVM.Module as Mod 39 | import LLVM.PassManager 40 | import LLVMFrontend.Helpers 41 | import LLVMFrontend.MkGraph 42 | import LLVM.Transforms 43 | import System.IO 44 | 45 | 46 | foreign import ccall "dynamic" 47 | code_void :: FunPtr (IO ()) -> IO () 48 | 49 | foreign import ccall "dynamic" 50 | code_int :: FunPtr (IO Int) -> IO Int 51 | 52 | lookupMethodEntry:: MethodInfo -> IO CPtrdiff 53 | lookupMethodEntry mi@(MethodInfo method cm sig) = do 54 | mmap <- getMethodMap 55 | case M.lookup mi mmap of 56 | Nothing -> do 57 | cls <- getClassFile cm 58 | printfMp $ printf "getMethodEntry: no method \"%s\" found. compile it\n" (show mi) 59 | mm <- lookupMethodRecursive method sig [] cls 60 | case mm of 61 | Just (mm', clsnames, cls') -> do 62 | let flags = methodAccessFlags mm' 63 | nf <- if S.member ACC_NATIVE flags 64 | then nativeAddr (toString cm) (toString method) (toString $ encode sig) 65 | else do -- plain java method 66 | entry <- compile $ MethodInfo method (thisClass cls') sig 67 | insertCompiledMethod entry mi clsnames 68 | return $ fromIntegral entry 69 | setMethodMap $ M.insert mi nf mmap 70 | return $ fromIntegral nf 71 | Nothing -> error $ printf "\"%s\" not found. abort" (toString method) 72 | Just w32 -> return $ fromIntegral w32 73 | 74 | lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct 75 | -> IO (Maybe (Method Direct, [B.ByteString], Class Direct)) 76 | lookupMethodRecursive name sig clsnames cls = do 77 | printfCp $ printf "looking @ %s\n" (toString thisname) 78 | case res of 79 | Just x -> return $ Just (x, nextclsn, cls) 80 | Nothing -> if thisname == "java/lang/Object" 81 | then return Nothing 82 | else do 83 | supercl <- getClassFile (superClass cls) 84 | lookupMethodRecursive name sig nextclsn supercl 85 | where 86 | res = lookupMethodWithSig name sig cls 87 | thisname = thisClass cls 88 | nextclsn :: [B.ByteString] 89 | nextclsn = thisname:clsnames 90 | 91 | insertCompiledMethod :: NativeWord -> MethodInfo -> [B.ByteString] -> IO () 92 | insertCompiledMethod entry (MethodInfo mmname _ msig) clsnames = do 93 | mmap <- getMethodMap 94 | let newmap = foldr 95 | (\i -> M.insert (MethodInfo mmname i msig) entry) 96 | M.empty 97 | clsnames 98 | setMethodMap $ mmap `M.union` newmap 99 | 100 | -- Create dummy module to be invoked by JIT 101 | initModule :: AST.Module 102 | initModule = AST.defaultModule { AST.moduleName = "dummy" } 103 | 104 | mkName' :: B.ByteString -> AST.Name 105 | mkName' = AST.mkName . map unsafeCoerce . B.unpack 106 | 107 | parseFields :: Class Direct -> [AST.Definition] 108 | parseFields cls = 109 | flip map (classFields cls) $ \field -> 110 | let nameType = fieldNameType field in 111 | AST.GlobalDefinition $ LG.globalVariableDefaults { 112 | LG.name = mkName' $ ntName nameType, 113 | LG.type' = jvm2llvmType $ ntSignature nameType, 114 | LG.linkage = LL.Private, 115 | LG.initializer = Just $ LC.Int 32 0 116 | } 117 | 118 | -- Stubbed for now... 119 | -- TODO: Do LLVM 120 | compileMethod :: B.ByteString -> MethodSignature -> Class Direct -> IO (a,b) 121 | compileMethod name sig cls = do 122 | let meth = fromJust $ lookupMethod name cls 123 | let code = M.fromList (arlist (methodAttributes meth)) M.! "Code" 124 | 125 | cfg <- pipeline cls meth (codeInstructions . decodeMethod $ code) 126 | -- cfg <- parseCFG (decodeMethod code) 127 | let mod = AST.defaultModule { AST.moduleDefinitions = parseFields cls ++ [defineFn (returnType sig) "main" (M.elems $ basicBlocks cfg)], AST.moduleName = "Dummy" } 128 | ast <- compileMethod' mod 129 | error . show $ ast 130 | 131 | error "JIT Compilation not implemented...\n" 132 | 133 | compileMethod' mod = 134 | -- Create a context used within this scope, which contains all LLVM-specific information 135 | withContext $ \c -> 136 | -- Create an execution engine within this scope... 137 | EE.withMCJIT c (Just 0) Nothing Nothing Nothing $ \ee -> 138 | -- Create an LLVM module from the AST generated... 139 | Mod.withModuleFromAST c mod $ \m -> 140 | -- Make a simple optimization pass 141 | withPassManager defaultCuratedPassSetSpec { optLevel = Just 3 } $ \pm -> do 142 | optmod <- Mod.moduleAST m -- Optimized-copy of module 143 | s <- Mod.moduleLLVMAssembly m -- Convert from module to assembly 144 | writeFile "unoptimizedIR.ll" (C8.unpack s) 145 | runPassManager pm m 146 | s' <- Mod.moduleLLVMAssembly m -- Convert from module to assembly 147 | writeFile "optimizedIR.ll" (C8.unpack s') 148 | 149 | -- Actually execute module... execution engine is modified to contain the 150 | -- actual code... 151 | EE.withModuleInEngine ee m $ \ee' -> do 152 | -- Find and execute main method... 153 | mainfn <- EE.getFunction ee' "main" 154 | case mainfn of 155 | Just fn -> do 156 | result <- code_int (castFunPtr fn :: FunPtr (IO Int)) 157 | printfJit . show $ result 158 | writeFile "out.txt" $ show result 159 | 160 | Nothing -> return () 161 | 162 | -- Optimized module used only in next pass... 163 | return optmod 164 | 165 | compile :: MethodInfo -> IO NativeWord 166 | compile methodinfo = time (printf "compile \"%s\"" $ toString $ methName methodinfo) $ do 167 | tmap <- getTrapMap 168 | 169 | cls <- getClassFile (methClassName methodinfo) 170 | printfJit $ printf "emit code of \"%s\" from \"%s\":\n" 171 | (toString $ methName methodinfo) 172 | (toString $ methClassName methodinfo) 173 | (entry, new_trapmap) <- compileMethod (methName methodinfo) 174 | (methSignature methodinfo) 175 | cls 176 | setTrapMap $ tmap `M.union` new_trapmap -- prefers elements in tmap 177 | printfJit $ printf "generated code of \"%s\" @ \"%s\" from \"%s\". DONE\n" 178 | (toString $ methName methodinfo) 179 | (show $ methSignature methodinfo) 180 | (toString $ methClassName methodinfo) 181 | 182 | -- UNCOMMENT NEXT LINES FOR GDB FUN 183 | -- if (toString $ methName methodinfo) == "thejavamethodIwant2debug" 184 | -- then putStrLn "press CTRL+C now for setting a breakpoint. then `c' and ENTER for continue" >> getLine 185 | -- else return "foo" 186 | -- (1) build a debug build (see HACKING) and execute `make tests/Fib.gdb' 187 | -- for example, where the suffix is important 188 | -- (2) on getLine, press CTRL+C 189 | -- (3) `br *0x'; obtain the address from the disasm above 190 | -- (4) `cont' and press enter 191 | return entry 192 | 193 | executeFuncPtr :: NativeWord -> IO () 194 | executeFuncPtr entry = 195 | code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ())) 196 | -------------------------------------------------------------------------------- /MateVMRuntime/MethodPool.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module MateVMRuntime.MethodPool 4 | ( lookupMethodEntry 5 | , executeFuncPtr 6 | ) where 7 | 8 | import MateVMRuntime.Types 9 | import MateVMRuntime.NativeSizes 10 | import Foreign.C.Types 11 | 12 | lookupMethodEntry :: MethodInfo -> IO CPtrdiff 13 | executeFuncPtr :: NativeWord -> IO () 14 | -------------------------------------------------------------------------------- /MateVMRuntime/MethodPool.o-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/MateVMRuntime/MethodPool.o-boot -------------------------------------------------------------------------------- /MateVMRuntime/MockBlockAllocation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module MateVMRuntime.MockBlockAllocation where 3 | 4 | 5 | import Foreign hiding ((.&.),unsafePerformIO) 6 | import Control.Monad 7 | import Control.Monad.Trans 8 | import Control.Monad.State 9 | import Control.Monad.Identity 10 | import Test.QuickCheck hiding ((.&.)) 11 | 12 | import Text.Printf 13 | import qualified Data.Map as M 14 | import qualified Data.Set as S 15 | import MateVMRuntime.Debug 16 | import qualified MateVMRuntime.GC as GC 17 | 18 | 19 | import MateVMRuntime.BlockAllocation 20 | 21 | data AllocIO = AllocIO deriving Show 22 | type AllocIOT a = StateT AllocIO IO a 23 | 24 | -- This is the mock allocator 25 | data AllocM = AllocM { freeS :: IntPtr } deriving (Eq) 26 | 27 | emptyAllocM :: AllocM 28 | emptyAllocM = AllocM { freeS = 0 } 29 | instance Show AllocM where 30 | show x = printf "freeS: 0x%08x" (fromIntegral $ freeS x :: Int) 31 | 32 | instance Alloc AllocM Identity where 33 | alloc _ = mkBlockM 34 | release _ = return () 35 | 36 | type AllocMT a = StateT AllocM Identity a 37 | 38 | instance Alloc AllocIO IO where 39 | alloc _ = mkBlockIO 40 | release = releaseBlockIO 41 | 42 | currentFreePtrM :: AllocMT IntPtr 43 | currentFreePtrM = liftM freeS get 44 | 45 | mkBlockM :: Int -> AllocMT Block 46 | mkBlockM size = do 47 | start <- currentFreePtrM 48 | let end = start + fromIntegral size 49 | put AllocM { freeS = end + 1 } -- in reality do padding here 50 | return Block { beginPtr = start, endPtr = end, freePtr = start } 51 | 52 | mkBlockIO :: Int -> AllocIOT Block 53 | mkBlockIO size = do 54 | ptr <- liftIO $ mallocBytes size 55 | let block = Block { beginPtr = ptrToIntPtr ptr, 56 | endPtr = ptrToIntPtr $ ptr `plusPtr` size, 57 | freePtr = ptrToIntPtr ptr } 58 | liftIO $ printfGc $ printf "made block: %s\n" (show block) 59 | return block 60 | 61 | releaseBlockIO :: Block -> AllocIOT () 62 | releaseBlockIO = liftIO . freeBlock 63 | where action = return . intPtrToPtr . beginPtr 64 | freeBlock = (freeDbg =<<) . action 65 | freeDbg ptr = do 66 | printfGc $ printf "releaseBlock free ptr: %s" (show ptr) 67 | free ptr 68 | 69 | freeGen :: GenState -> AllocIOT () 70 | freeGen = mapM_ (mapM_ releaseBlockIO . snd) . M.toList . activeBlocks 71 | 72 | freeGens :: [GenState] -> AllocIOT () 73 | freeGens = mapM_ freeGen 74 | 75 | freeGensIO :: [GenState] -> IO () 76 | freeGensIO xs = evalStateT (freeGens xs) AllocIO 77 | 78 | blockAdresses :: Num a => a -> [(a,a)] 79 | blockAdresses k = iterate next first 80 | where first = (0,k-1) 81 | next (l,u) = (l+k,u+k) 82 | 83 | gcState1 :: GcState 84 | gcState1 = GcState { generations = M.insert 0 emptyGenState M.empty, allocs = 0, allocatedBytes = 0, loh = S.empty, 85 | allocState = error "not implemented" } 86 | 87 | 88 | runBlockAllocator :: Int -> GcState -> IO (Ptr b, GcState) 89 | runBlockAllocator size current = evalStateT allocT AllocIO 90 | where allocT = runStateT (allocGen0 GC.mkGen0 size) current 91 | 92 | 93 | --dont be too frightened here. cornholio 94 | runTest :: StateT GcState (StateT AllocM Identity) (Ptr a) -> GcState -> AllocM -> ((Ptr a, GcState), AllocM) 95 | runTest x gcState allocState' = let allocation = runStateT x gcState 96 | resultT = runStateT allocation allocState' 97 | result = runIdentity resultT 98 | in result 99 | 100 | 101 | test1 :: ((Ptr b, GcState), AllocM) 102 | test1 = let x = runStateT (allocGen0 GC.mkGen0 12) gcState1 103 | y = runStateT x emptyAllocM 104 | in runIdentity y 105 | 106 | test2 :: IO ((Ptr b, GcState), AllocIO) 107 | test2 = let x = runStateT (allocGen0 GC.mkGen0 12) gcState1 108 | y = runStateT x AllocIO 109 | in y 110 | 111 | int2Ptr :: Int -> Ptr b 112 | int2Ptr = intPtrToPtr . fromIntegral 113 | 114 | emptyTest :: Int -> Property 115 | emptyTest x = let ((ptr,_),_) = runTest (allocGen0 GC.mkGen0 x) start emptyAllocM 116 | in x <= blockSize ==> ptr == int2Ptr 0 117 | where start = mkGcState 118 | GenState { freeBlocks = [], activeBlocks = M.empty, collections = 0, generation = 0} 119 | {- 120 | test3 :: Property 121 | test3 = let ((ptr,gcS),_) = runTest (allocGen0 GC.mkGen0 12) start emptyAllocM 122 | in True ==> ptr == int2Ptr 0xc && (freeBlocks . head . generations) gcS == [] 123 | where aBlock = Block { beginPtr = 0x0, endPtr = 0x400, freePtr = 0xc } 124 | start = mkGcState 125 | GenState { freeBlocks = [aBlock], activeBlocks = M.empty, collections = 0, generation = 0 } 126 | 127 | test4 :: Property 128 | test4 = let ((ptr,gcS),_) = runTest (allocGen0 GC.mkGen0 12) start emptyAllocM 129 | in True ==> ptr == int2Ptr 0x401 && (freeBlocks . head . generations) gcS == [] 130 | where aBlock = Block { beginPtr = 0x0, endPtr = 0x400, freePtr = 0x400 } 131 | aBlock2 = Block { beginPtr = 0x401, endPtr = 0x800, freePtr = 0x401 } 132 | active' = M.insert (freeSpace aBlock) [aBlock] M.empty 133 | active'' = M.insert (freeSpace aBlock2) [aBlock2] active' 134 | start = mkGcState 135 | GenState { freeBlocks = [], activeBlocks = active'', collections = 0, generation = 0 } 136 | 137 | test5 :: Int -> Property 138 | test5 s = let ((ptr,gcS),_) = runTest (allocGen0 GC.mkGen0 s) start AllocM { freeS = 0x801 } 139 | in s > 1 && s < blockSize ==> ptr == int2Ptr 0x801 && (length . M.toList . activeBlocks . head . generations) gcS == 3 140 | where aBlock = Block { beginPtr = 0x0, endPtr = 0x400, freePtr = 0x400 } 141 | aBlock2 = Block { beginPtr = 0x401, endPtr = 0x800, freePtr = 0x7FF } 142 | active' = M.insertWith (++) (freeSpace aBlock) [aBlock] M.empty 143 | active'' = M.insertWith (++) (freeSpace aBlock2) [aBlock2] active' 144 | start = mkGcState 145 | GenState { freeBlocks = [], activeBlocks = active'', collections = 0, generation = 0 } 146 | -} 147 | -------------------------------------------------------------------------------- /MateVMRuntime/NativeMethods.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module MateVMRuntime.NativeMethods 4 | ( nativeAddr 5 | ) where 6 | 7 | import qualified Data.ByteString.Lazy as B 8 | import Data.String.Utils 9 | import System.Plugins 10 | import Foreign.C.String 11 | 12 | import Control.Monad 13 | 14 | import Foreign 15 | import Foreign.C.Types 16 | 17 | import JVM.ClassFile 18 | 19 | import MateVMRuntime.JavaObjects() 20 | import MateVMRuntime.Debug 21 | import MateVMRuntime.NativeSizes 22 | 23 | 24 | foreign import ccall "&printMemoryUsage" 25 | printMemoryUsageAddr :: FunPtr (IO ()) 26 | 27 | foreign import ccall "&printGCStats" 28 | printGCStatsAddr :: FunPtr (IO ()) 29 | 30 | foreign import ccall "&cloneObject" 31 | cloneObjectAddr :: FunPtr (CPtrdiff -> IO CPtrdiff) 32 | 33 | foreign import ccall "&printf0" 34 | printf0Addr :: FunPtr (CPtrdiff -> IO CInt) 35 | foreign import ccall "&printf1" 36 | printf1Addr :: FunPtr (CPtrdiff -> CPtrdiff -> IO CInt) 37 | foreign import ccall "&printf2" 38 | printf2Addr :: FunPtr (CPtrdiff -> CPtrdiff -> CPtrdiff -> IO CInt) 39 | foreign import ccall "&printf3" 40 | printf3Addr :: FunPtr (CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> IO CInt) 41 | foreign import ccall "&printf4" 42 | printf4Addr :: FunPtr (CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> IO CInt) 43 | foreign import ccall "&printf5" 44 | printf5Addr :: FunPtr (CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> CPtrdiff -> IO CInt) 45 | 46 | 47 | funPtrToAddr :: Num b => FunPtr a -> b 48 | funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr 49 | 50 | nativeAddr :: Num a => String -> String -> String -> IO a 51 | nativeAddr scm smethod sig = do 52 | let ret = return . funPtrToAddr 53 | printfMp $ printf "native-call: %s: %s / %s\n" scm smethod sig 54 | case scm of 55 | "jmate/lang/MateRuntime" -> 56 | case smethod of 57 | "printGCStats" -> ret printGCStatsAddr 58 | "printMemoryUsage" -> ret printMemoryUsageAddr 59 | _ -> error $ "native-call: " ++ smethod ++ " @ " ++ scm ++ " not found." 60 | "java/lang/VMObject" -> 61 | case smethod of 62 | "clone" -> ret cloneObjectAddr 63 | _ -> error $ "native-call: " ++ smethod ++ " @ " ++ scm ++ " not found." 64 | "jmate/io/PrintStream" -> 65 | case smethod of 66 | "printf_0" -> ret printf0Addr 67 | "printf_1" -> ret printf1Addr 68 | "printf_2" -> ret printf2Addr 69 | "printf_3" -> ret printf3Addr 70 | "printf_4" -> ret printf4Addr 71 | "printf_5" -> ret printf5Addr 72 | _ -> error $ "native-call: " ++ smethod ++ " @ " ++ scm ++ " not found." 73 | _ -> do 74 | -- TODO(bernhard): cleaner please... *do'h* 75 | let sym1 = replace "/" "_" scm 76 | parenth = replace "(" "_" $ replace ")" "_" sig 77 | sym2 = replace ";" "_" $ replace "/" "_" parenth 78 | symbol = sym1 ++ "__" ++ smethod ++ "__" ++ sym2 79 | printfMp $ printf "native-call: symbol: %s\n" symbol 80 | nf <- loadNativeFunction symbol 81 | return $ fromIntegral nf 82 | 83 | -- TODO(bernhard): UBERHAX. ghc patch? 84 | foreign import ccall safe "lookupSymbol" 85 | c_lookupSymbol :: CString -> IO (Ptr a) 86 | 87 | loadNativeFunction :: String -> IO NativeWord 88 | loadNativeFunction sym = do 89 | _ <- loadRawObject "ffi/native.o" 90 | -- TODO(bernhard): WTF 91 | resolveObjs (return ()) 92 | ptr <- withCString sym c_lookupSymbol 93 | if ptr == nullPtr 94 | then error $ "dyn. loading of \"" ++ sym ++ "\" failed." 95 | else return $ fromIntegral $ ptrToIntPtr ptr 96 | 97 | 98 | type JavaObject = CPtrdiff 99 | 100 | fromJavaString :: JavaObject -> IO String 101 | fromJavaString objaddr = do 102 | straddr <- peek $ intPtrToPtr (fromIntegral $ objaddr + 0x8) :: IO CPtrdiff 103 | len <- peek $ intPtrToPtr (fromIntegral $ objaddr + 0xc) :: IO CPtrdiff 104 | let rptr = intPtrToPtr (fromIntegral $ straddr + 0xc) :: Ptr CPtrdiff 105 | vals <- forM [0..(len - 1)] $ \i -> 106 | peek (plusPtr rptr (fromIntegral i)) :: IO Word8 107 | return $ toString $ B.pack vals 108 | 109 | fromJavaInteger :: JavaObject -> IO Int32 110 | fromJavaInteger objaddr = peek $ intPtrToPtr $ fromIntegral $ objaddr + 0x8 111 | 112 | foreign export ccall printf0 :: JavaObject -> IO CInt 113 | printf0 :: JavaObject -> IO CInt 114 | printf0 fmt = do 115 | hfmt <- fromJavaString fmt 116 | printf hfmt 117 | return 0 118 | 119 | foreign export ccall printf1 :: JavaObject -> JavaObject -> IO CInt 120 | printf1 :: JavaObject -> JavaObject -> IO CInt 121 | printf1 fmt i1 = do 122 | hfmt <- fromJavaString fmt 123 | hi1 <- fromJavaInteger i1 124 | printf hfmt hi1 125 | return 0 126 | 127 | foreign export ccall printf2 :: JavaObject -> JavaObject -> JavaObject -> IO CInt 128 | printf2 :: JavaObject -> JavaObject -> JavaObject -> IO CInt 129 | printf2 fmt i1 i2 = do 130 | hfmt <- fromJavaString fmt 131 | hi1 <- fromJavaInteger i1 132 | hi2 <- fromJavaInteger i2 133 | printf hfmt hi1 hi2 134 | return 0 135 | 136 | foreign export ccall printf3 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 137 | printf3 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 138 | printf3 fmt i1 i2 i3 = do 139 | hfmt <- fromJavaString fmt 140 | hi1 <- fromJavaInteger i1 141 | hi2 <- fromJavaInteger i2 142 | hi3 <- fromJavaInteger i3 143 | printf hfmt hi1 hi2 hi3 144 | return 0 145 | 146 | foreign export ccall printf4 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 147 | printf4 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 148 | printf4 fmt i1 i2 i3 i4 = do 149 | hfmt <- fromJavaString fmt 150 | hi1 <- fromJavaInteger i1 151 | hi2 <- fromJavaInteger i2 152 | hi3 <- fromJavaInteger i3 153 | hi4 <- fromJavaInteger i4 154 | printf hfmt hi1 hi2 hi3 hi4 155 | return 0 156 | 157 | foreign export ccall printf5 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 158 | printf5 :: JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> JavaObject -> IO CInt 159 | printf5 fmt i1 i2 i3 i4 i5 = do 160 | hfmt <- fromJavaString fmt 161 | hi1 <- fromJavaInteger i1 162 | hi2 <- fromJavaInteger i2 163 | hi3 <- fromJavaInteger i3 164 | hi4 <- fromJavaInteger i4 165 | hi5 <- fromJavaInteger i5 166 | printf hfmt hi1 hi2 hi3 hi4 hi5 167 | return 0 168 | -------------------------------------------------------------------------------- /MateVMRuntime/NativeMethods_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsInt32 printf0(HsInt64 a1); 6 | extern HsInt32 printf1(HsInt64 a1, HsInt64 a2); 7 | extern HsInt32 printf2(HsInt64 a1, HsInt64 a2, HsInt64 a3); 8 | extern HsInt32 printf3(HsInt64 a1, HsInt64 a2, HsInt64 a3, HsInt64 a4); 9 | extern HsInt32 printf4(HsInt64 a1, HsInt64 a2, HsInt64 a3, HsInt64 a4, HsInt64 a5); 10 | extern HsInt32 printf5(HsInt64 a1, HsInt64 a2, HsInt64 a3, HsInt64 a4, HsInt64 a5, HsInt64 a6); 11 | #ifdef __cplusplus 12 | } 13 | #endif 14 | 15 | -------------------------------------------------------------------------------- /MateVMRuntime/NativeSizes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module MateVMRuntime.NativeSizes where 3 | 4 | import Data.Word 5 | 6 | ptrSize, longSize :: Num a => a 7 | ptrSize = 4 8 | longSize = 8 9 | 10 | type NativeWord = Word32 11 | -------------------------------------------------------------------------------- /MateVMRuntime/README.md: -------------------------------------------------------------------------------- 1 | # NOTE: RIPPED FROM MATEVM 2 | 3 | Adventures in RTS - or - Status of the GCs available in MateVM 4 | ============================================================== 5 | 6 | As reference GC we implemented a simple wrapper[1] for BoehmGC[2]. If something 7 | goes wrong (tests fail) it is always a good idea to witch to BoehmGC - 8 | to be sure the GC does not mess up something. 9 | The C binding is split into a separate cabal package because the build process is not as 10 | straightforward as for MateVM so we decided to keep this stuff out. 11 | 12 | Given this (ground zero) our mission was to show a way to implement parts of the 13 | runtime system in Haskell as well. It turned out to work better than expected :) 14 | 15 | First we implemented a simple copying gc sheme: 16 | * two fixed blocks of memory 17 | * evacuate objects alive into the other area 18 | * switch to and from space and continue execution 19 | * evacuate objects again into the oter memory area... 20 | * Large objects are in separate space and get freed immediately (i.e. not moved) 21 | This is realized in TwoSpaceAllocator.hs 22 | 23 | A slightly improved memory manager is available in BlockAllocation.hs. 24 | Active memory is divided into (power of two large) blocks - whenever a block 25 | is conceptually freed it is put into a free list. Another allocation may 26 | use this memory again. In principle it would be possible resize the underlying 27 | memory buffer depending on the VMs needs. However this is currently not implemented 28 | but should be quite straightforward. 29 | 30 | As next step we introduced a generational GC (inspired by[3]). The assumption is, 31 | that many objects live shortly. Gen0 collections take place quite frequently, 32 | higher collections less frequent. This is sketched in GenerationalGC.hs. 33 | 34 | ## Future Work 35 | 36 | GC.hs provides a nice and abstract way to traverse object trees (which are in fact nothing 37 | but (Ptr a)'s). RefObj typeclass provides this abstract interface (mostly in IO). 38 | JavaObjectsGC.hs defines a RefObj instance for Ptr. The implementations mentioned above 39 | use a rich set of simple functions in GC.hs which operate on RefObjs. There exist efficient 40 | implementations of Obj-Tree traversals and so on. However TwoSpaceAllocator and GenerationalGC 41 | often use rather inefficient entry points - this is artifact of development and debugging. 42 | That is the main reason all implemented GCs (Except boehm) are *very* inefficient. 43 | If GC does not take place very often this is not a big issue - nevertheless - it sucks. 44 | Here is definitely work to do... 45 | 46 | Other issues are: 47 | * rarely already patched (moved) objects pop up in gc points. This may be due to inproper 48 | patching of the object tree or something else. GenerationalGC implements a stupid 49 | hack to overcome this issue - free blocks are queued, stay inactive but accessible. This 50 | way old references are still valid and get hopefully patched within the next GC invocation. 51 | Empirical analysis showed that these invalid references show up immediately after previous GC 52 | and vanish after the next one. However, this is just intution and sucks as well. 53 | * Builtin efficiency problems - I suspecd many many functions to be unnecessarily lazy. If 54 | the previously mentioned issued are solved it is time to do awesome memory profiling. 55 | 56 | 57 | To sum up there is still much to do, but we found it is possible to implement parts of the 58 | RuntimeSystem in haskell in a quite nice and abstract way. 59 | 60 | [1] https://github.com/MateVM/hs-boehmgc 61 | 62 | [2] http://www.hpl.hp.com/personal/Hans_Boehm/gc/ 63 | 64 | [3] http://dl.acm.org/citation.cfm?id=808261 65 | -------------------------------------------------------------------------------- /MateVMRuntime/RtsOptions.hs: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.RtsOptions where 2 | 3 | {-# INLINE usePreciseGC #-} 4 | usePreciseGC :: Bool 5 | usePreciseGC = False 6 | 7 | {-# INLINE useBlockAllocator #-} 8 | useBlockAllocator :: Bool 9 | useBlockAllocator = True 10 | 11 | --- objects bigger than this get allocated in LOH 12 | loThreshhold :: Int 13 | loThreshhold = 2040 14 | 15 | useLoh :: Bool 16 | useLoh = True 17 | 18 | -- | use this flag in combination with usePreciseGC to get 19 | -- very fast object allocation (way faster than pure malloc) 20 | -- but with one huge evil memory leak. However this might be 21 | -- useful for pure JIT benchmarks. 22 | useLeakingGCForJitBenches :: Bool 23 | useLeakingGCForJitBenches = False 24 | 25 | blockSizePowerOfTwo :: Int 26 | blockSizePowerOfTwo = 10 27 | 28 | heapSize :: Int 29 | heapSize = 32768 -- (*) blockSize 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /MateVMRuntime/StackTrace.hs: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.StackTrace 2 | ( StackDescription(..) 3 | , stackFrames 4 | , printStackTrace' 5 | , printStackTrace 6 | , printStackFramesPrecise 7 | ) where 8 | 9 | import Foreign 10 | import Foreign.C 11 | import Control.Monad 12 | import qualified Data.Map as M 13 | import Data.String.Utils 14 | 15 | import JVM.ClassFile -- because toString 16 | 17 | import MateVMRuntime.Debug 18 | import MateVMRuntime.Types 19 | 20 | data StackDescription = StackDescription { --base :: CPtrdiff, end :: CPtrdiff, 21 | stackinfo :: RuntimeStackInfo, 22 | candidates :: [IntPtr] } deriving Show 23 | 24 | cPtrToIntPtr :: CPtrdiff -> Ptr a 25 | cPtrToIntPtr = intPtrToPtr . fromIntegral 26 | 27 | -- accumulator (tailrecursive) stackframes stream (may be written as predefined function?) 28 | stackFrames :: [StackDescription] -> CPtrdiff -> CPtrdiff -> IO [StackDescription] 29 | stackFrames accum reip rebp = do 30 | stblptr <- peek (cPtrToIntPtr rebp) :: IO Word32 31 | nextreip <- peek (cPtrToIntPtr (rebp + 0x8)) :: IO Word32 32 | let sptr = castPtrToStablePtr $ intPtrToPtr $ fromIntegral stblptr 33 | stackinfo' <- deRefStablePtr sptr :: IO RuntimeStackInfo 34 | printfMem $ printf "stackFrames: eip: %08x\n" (fromIntegral reip :: Word32) 35 | printfMem $ printf "stackFrames: elem:\n" 36 | candidates' <- case M.lookup (fromIntegral reip) (rsiGCPoints stackinfo') of 37 | Nothing -> do printfMem $ printf "stackFrames: no entry found :(\n" 38 | return [] 39 | Just points -> do 40 | printfMem $ printf "stackFrames: found entry \\o/\n" 41 | forM_ points $ \x -> do 42 | let point :: Word32 43 | -- TODO(bernhard): I'm not sure here, maybe s/rebp/prevRbp/ 44 | point = x + fromIntegral rebp 45 | printfMem $ printf "stackFrames: candidate: %08x\n" point 46 | return $ map ((+ fromIntegral rebp) . fromIntegral) points 47 | let accum' = StackDescription { stackinfo = stackinfo', candidates = candidates' } : accum 48 | if bottomOfStack stackinfo' 49 | then return accum' -- done here. bottomOfStack claims that there are no frames left 50 | else -- otherwise grab the next frame, put current frame into list and continue 51 | peek (cPtrToIntPtr (rebp + 4)) >>= stackFrames accum' (fromIntegral nextreip) 52 | 53 | -- Prints precice stacktrace to printStr. Furthermore a list 54 | -- of stackdescriptions is produced 55 | printStackTrace' :: CPtrdiff -> CPtrdiff -> IO [StackDescription] 56 | printStackTrace' eip ptr = do 57 | printfStr "Stacktrace:\n" 58 | frames <- stackFrames [] eip ptr -- build with cps toget rid of reverse? 59 | forM_ (reverse frames) (printfStr . printf "---> %s\n" . toString . rsiMethodname . stackinfo) 60 | printfStr "End of Stack\n" 61 | printStackFramesPrecise frames 62 | return frames 63 | 64 | printStackFramesPrecise :: [StackDescription] -> IO () 65 | printStackFramesPrecise = mapM_ printPrecise 66 | where printPrecise f = do 67 | --let refs = possibleRefs f 68 | printfStr $ printf "Method: %s\n" (name f) 69 | --printfStr $ refsToString refs 70 | name = toString . rsiMethodname . stackinfo 71 | 72 | {- 73 | refsToString :: [IntPtr] -> String 74 | refsToString ptrs = printf "Reference Candidates: %s\n" (ptrStr ptrs) 75 | where ptrStr = intercalate "," . map printElement 76 | printElement ptr = printf "0x%08x" (fromIntegral ptr :: Word32) 77 | -} 78 | 79 | bottomOfStack :: RuntimeStackInfo -> Bool 80 | bottomOfStack = mainOrInit . toString . rsiMethodname 81 | 82 | -- | Determines wheter a method signature (as found in RuntimeStackInfos) is bottom of stack 83 | mainOrInit :: String -> Bool 84 | mainOrInit sig | startswith "main" sig = True 85 | | startswith "" sig = True 86 | | otherwise = False 87 | 88 | -- | Prints stacktrace until bottom of stack is reached (or native code transition or trap [TODO] 89 | -- The Int argument describes current stack depth (for pretty printing) 90 | printStackTrace :: Int -> CPtrdiff -> IO () 91 | printStackTrace depth rebp = do 92 | stblptr <- peek (intPtrToPtr . fromIntegral $ rebp) :: IO Word32 93 | let sptr = castPtrToStablePtr $ intPtrToPtr $ fromIntegral stblptr 94 | stackinfo' <- deRefStablePtr sptr :: IO RuntimeStackInfo 95 | bottomOfStack' <- printFrame depth mainOrInit stackinfo' 96 | unless bottomOfStack' continue 97 | where continue = peek (intPtrToPtr . fromIntegral $ (rebp + 4)) >>= printStackTrace (depth+1) 98 | 99 | -- | Prints stackframe to printStr. Returns True if bottom of the stack (i.e. main) 100 | -- is reached. 101 | printFrame :: Int -> (String -> Bool) -> RuntimeStackInfo -> IO Bool 102 | printFrame d bottomCheck = print' . toString . rsiMethodname 103 | where print' sig | bottomCheck sig 104 | = printfStr (printf "reached bottom of stack [%d]\n" d) >> return True 105 | | otherwise 106 | = printfStr (printf "stacktrace @ malloc: %s [%d]\n" sig d) >> return False 107 | -------------------------------------------------------------------------------- /MateVMRuntime/TwoSpaceAllocator.hs: -------------------------------------------------------------------------------- 1 | module MateVMRuntime.TwoSpaceAllocator where 2 | 3 | import Foreign 4 | import Control.Monad.State 5 | import qualified Foreign.Marshal.Alloc as Alloc 6 | import Data.Set (Set) 7 | import qualified Data.Set as S 8 | import qualified Data.Map as M 9 | import Data.List 10 | 11 | import MateVMRuntime.MemoryManager 12 | import MateVMRuntime.RtsOptions 13 | import MateVMRuntime.GC hiding (size) 14 | import MateVMRuntime.Debug 15 | 16 | data TwoSpace = TwoSpace { fromBase :: IntPtr, 17 | toBase :: IntPtr, 18 | fromHeap :: IntPtr, 19 | toHeap :: IntPtr, 20 | fromExtreme :: IntPtr, 21 | toExtreme :: IntPtr, 22 | validRange :: (IntPtr,IntPtr), 23 | loh :: Set IntPtr 24 | } 25 | 26 | 27 | instance AllocationManager TwoSpace where 28 | initMemoryManager = initTwoSpace 29 | mallocBytesT _ = mallocBytes' 30 | performCollection = performCollection' 31 | 32 | collectLoh = collectLohTwoSpace 33 | 34 | heapSize = do space <- get 35 | return $ fromIntegral $ toHeap space - fromIntegral (toBase space) 36 | 37 | validRef _ = return True --liftM (validRef' ptr) get 38 | 39 | 40 | switchSpaces :: TwoSpace -> TwoSpace 41 | switchSpaces old = old { fromHeap = toHeap old, 42 | toHeap = fromHeap old, 43 | fromBase = toBase old, 44 | toBase = fromBase old, 45 | fromExtreme = toExtreme old, 46 | toExtreme = fromExtreme old } 47 | 48 | 49 | mallocBytes' :: Int -> StateT TwoSpace IO (Ptr b) 50 | mallocBytes' bytes = 51 | do state' <- get 52 | if bytes < loThreshhold || not useLoh 53 | then do 54 | let end = toHeap state' + fromIntegral bytes 55 | base = fromIntegral $ toBase state' 56 | extreme = fromIntegral $ toExtreme state' 57 | heap = fromIntegral $ toHeap state' 58 | used = heap - base 59 | capacity = extreme - base 60 | if end <= toExtreme state' 61 | then liftIO (logAllocation bytes used capacity) >> alloc state' end 62 | else 63 | failNoSpace used capacity 64 | else 65 | allocateLoh bytes 66 | where alloc :: TwoSpace -> IntPtr -> StateT TwoSpace IO (Ptr b) 67 | alloc state' end = do 68 | let ptr = toHeap state' 69 | put $ state' { toHeap = end } 70 | liftIO (printfGc $ "Allocated obj: " ++ show (intPtrToPtr ptr) ++ "\n") 71 | liftIO (return $ intPtrToPtr ptr) 72 | failNoSpace :: Integer -> Integer -> a 73 | failNoSpace usage fullSize = 74 | error $ printf "no space left in two space (mallocBytes'). Usage: %d/%d" usage fullSize 75 | 76 | logAllocation :: Int -> Integer -> Integer -> IO () 77 | --logAllocation _ _ _ = return () 78 | logAllocation fullSize usage capacity = printfGc $ printf "alloc size: %d (%d/%d)\n" fullSize usage capacity 79 | 80 | allocateLoh :: Int -> StateT TwoSpace IO (Ptr b) 81 | allocateLoh size = do 82 | current <- get 83 | let currentLoh = loh current 84 | ptr <- liftIO $ Alloc.mallocBytes size 85 | put $ current { loh = S.insert (ptrToIntPtr ptr) currentLoh } 86 | liftIO $ printfGc $ printf "LOH: allocated %d bytes in loh %s" size (show ptr) 87 | return ptr 88 | 89 | 90 | --evacuateList :: (RefObj a, AllocationManager b) => [a] -> b -> StateT b IO () 91 | --evacuateList objs = evacuate' objs 92 | 93 | validRef' :: IntPtr -> TwoSpace -> Bool 94 | validRef' ptr twoSpace = (ptr >= fst (validRange twoSpace)) && 95 | (ptr <= snd (validRange twoSpace)) 96 | 97 | collectLohTwoSpace :: (RefObj a) => [a] -> StateT TwoSpace IO () 98 | collectLohTwoSpace xs = do 99 | current <- get 100 | intptrs <- liftIO $ mapM getIntPtr xs 101 | let oldLoh = loh current 102 | let newSet = S.fromList intptrs 103 | let toRemove = oldLoh `S.difference` newSet 104 | liftIO $ printfGc $ printf "objs in loh: %d" (S.size oldLoh) 105 | liftIO $ printfGc $ printf "old loh: %s" (show $ showRefs $ S.toList oldLoh) 106 | liftIO $ printfGc $ printf "to remove: %s" (show $ showRefs $ S.toList toRemove) 107 | liftIO $ mapM (free . intPtrToPtr) (S.toList toRemove) 108 | put current { loh = newSet } 109 | 110 | 111 | 112 | initTwoSpace :: Int -> IO TwoSpace 113 | initTwoSpace size' = do printfStr $ printf "initializing TwoSpace memory manager with %d bytes.\n" size' 114 | fromSpace <- Alloc.mallocBytes (size' * 2) 115 | printfMem $ printf "memory area by gc: 0x%08x to 0x%08x\n" ((fromIntegral $ ptrToIntPtr fromSpace)::Word32) (size'*2 + fromIntegral (ptrToIntPtr fromSpace)) 116 | let toSpace = fromSpace `plusPtr` size' 117 | if fromSpace /= nullPtr && toSpace /= nullPtr 118 | then return $ buildToSpace fromSpace toSpace 119 | else error "Could not initialize TwoSpace memory manager (malloc returned null ptr)\n" 120 | where buildToSpace from to = let fromBase' = ptrToIntPtr from 121 | toBase' = ptrToIntPtr to 122 | fromExtreme' = ptrToIntPtr $ from `plusPtr` size' 123 | toExtreme' = ptrToIntPtr $ to `plusPtr` size' 124 | in TwoSpace { fromBase = fromBase', toBase = toBase', 125 | fromHeap = fromBase', toHeap = toBase', 126 | fromExtreme = fromExtreme', toExtreme = toExtreme', 127 | validRange = (fromBase',toExtreme'), 128 | loh = S.empty} 129 | 130 | 131 | performCollection' :: (RefObj a) => M.Map a RefUpdateAction -> StateT TwoSpace IO () 132 | performCollection' roots = do modify switchSpaces 133 | let rootList = map fst $ M.toList roots 134 | logGcT $ printf "rootSet: %s\n " (show rootList) 135 | performCollectionIO rootList 136 | liftIO $ patchGCRoots roots 137 | logGcT "all done \\o/" 138 | 139 | 140 | -- [todo hs] this is slow. merge phases to eliminate list with refs 141 | performCollectionIO :: (RefObj a, AllocationManager b) => [a] -> StateT b IO () 142 | performCollectionIO refs' = do 143 | logGcT "==>Phase 1. Marking..\n" 144 | objFilter <- markedOrInvalid 145 | allLifeRefs <- liftIO $ liftM (nub . concat) $ mapM (markTree'' objFilter mark refs') refs' 146 | logGcT "==>Done Phase 1.\n" 147 | toEvacuate <- liftIO $ filterM (getIntPtr >=> return . hasMTable) allLifeRefs 148 | if gcLogEnabled 149 | then liftIO $ mapM_ (getIntPtr >=> \x -> printfGc $ printf " 0x%08x" (fromIntegral x ::Int) ) toEvacuate 150 | else return () 151 | (largeObjs,lifeRefs) <- liftIO $ extractLargeObjects toEvacuate 152 | logGcT "\nPhase 2. Evacuating...\n" 153 | 154 | if gcLogEnabled 155 | then liftIO $ mapM_ (getIntPtr >=> \x -> printfGc $ printf " 0x%08x" (fromIntegral x ::Int) ) lifeRefs 156 | else return () 157 | evacuate' (const True) (\_ -> return mkGen0) lifeRefs 158 | logGcT "Phase 2. Done.\n" 159 | if useLoh 160 | then do 161 | logGcT "killing unsued large objs\n" 162 | collectLoh largeObjs 163 | logGcT "cleaned up loh\n" 164 | else return (); 165 | liftIO $ patchAllRefs (getIntPtr >=> \x -> return $ x /= 0) lifeRefs 166 | --lift $ patchAllRefs (getIntPtr >=> return . flip validRef' memoryManager) lifeRefs 167 | logGcT "patched2.\n" 168 | -------------------------------------------------------------------------------- /MateVMRuntime/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module MateVMRuntime.Types 3 | ( w8Toi32, w16Toi32, w32Toi32, i32Tow32 4 | , objectMtable, objectGC, objectField 5 | , arrayMagic, arrayGC, arrayLength, arrayBase 6 | , primitiveArrayMagic, referenceArrayMagic 7 | , ExceptionMap 8 | , RuntimeStackInfo(..) 9 | , StackDisp, GCPoint, GCPoints, GCSet, rootSet 10 | , TrapPatcher, TrapPatcherEax 11 | , ExceptionHandler 12 | , WriteBackRegs, printWbr 13 | , x86callersave, x86calleesave, x86regs, eip 14 | , TrapMap, MethodMap, ClassMap, FieldMap, FieldTypeMap 15 | , StringMap, VirtualMap, InterfaceMap 16 | , InterfaceMethodMap 17 | , TrapCause(..) 18 | , StaticFieldInfo(..) 19 | , MethodInfo(..) 20 | , ClassInfo(..) 21 | , MateObjType(..) 22 | , setTrapMap, getTrapMap 23 | , setMethodMap, getMethodMap 24 | , setClassMap, getClassMap 25 | , setStringMap, getStringMap 26 | , setVirtualMap, getVirtualMap 27 | , setInterfaceMap, getInterfaceMap 28 | , setInterfaceMethodMap, getInterfaceMethodMap 29 | ) where 30 | 31 | import Data.Int 32 | import Data.Word 33 | import qualified Data.Map as M 34 | import qualified Data.IntervalMap as IM 35 | import qualified Data.ByteString.Lazy as B 36 | 37 | import Data.IORef 38 | import System.IO.Unsafe 39 | 40 | import Harpy 41 | import Foreign.C.Types 42 | 43 | import JVM.ClassFile 44 | import MateVMRuntime.NativeSizes 45 | import MateVMRuntime.Debug 46 | 47 | -- type helper 48 | w8Toi32 :: Word8 -> Int32 49 | w8Toi32 w8 = fromIntegral i8 50 | where i8 = fromIntegral w8 :: Int8 51 | 52 | w16Toi32 :: Word16 -> Int32 53 | w16Toi32 w16 = fromIntegral i16 54 | where i16 = fromIntegral w16 :: Int16 55 | 56 | w32Toi32 :: Word32 -> Int32 57 | w32Toi32 = fromIntegral 58 | 59 | i32Tow32 :: Int32 -> Word32 60 | i32Tow32 = fromIntegral 61 | 62 | -- object offsets 63 | objectMtable, objectGC, objectField :: Num a => a 64 | objectMtable = 0x0 65 | objectGC = 0x4 66 | objectField = 0x8 67 | 68 | -- array offsets 69 | arrayMagic, arrayGC, arrayLength, arrayBase :: Num a => a 70 | arrayMagic = 0x0 71 | arrayGC = 0x4 72 | arrayLength = 0x8 73 | arrayBase = 0xc 74 | 75 | -- used to distinguish between primitive and reference type arrays (for gc) 76 | primitiveArrayMagic :: Word32 77 | primitiveArrayMagic = 0x1228babe 78 | referenceArrayMagic :: Word32 79 | referenceArrayMagic = 0x1227babe 80 | 81 | type ExceptionMap a = IM.IntervalMap a [(B.ByteString, a)] 82 | data RuntimeStackInfo = RuntimeStackInfo 83 | { rsiMethodname :: B.ByteString 84 | , rsiExceptionMap :: ExceptionMap NativeWord 85 | , rsiGCPoints :: GCPoints 86 | } deriving Show 87 | 88 | type StackDisp = NativeWord -- stack displacement 89 | -- TODO: replace list with Set? 90 | type GCPoint = [StackDisp] -- information for one GC Point (e.g. `NEW') 91 | 92 | -- a method can has several points in program where it calls the GC. 93 | -- however, the stack layout can be different for each point 94 | type GCPoints = M.Map NativeWord -- instruction pointer 95 | GCPoint 96 | 97 | -- at runtime, the GC can build a GCSet via stack walks 98 | type GCSet = [(Word32 {- ebp -}, GCPoint)] 99 | 100 | -- the rootSet contains all addresses of valids Java references (e.g. objects, 101 | -- arrays, ... ?) 102 | rootSet :: GCSet -> [Word32] 103 | rootSet = concatMap (\(base, points) -> map (+base) points) 104 | 105 | -- NativeWord = point of method call in generated code 106 | -- MethodInfo = relevant information about callee 107 | type TrapMap = M.Map NativeWord TrapCause 108 | 109 | eip :: Reg32 110 | eip = Reg32 8 111 | 112 | x86callersave :: [Reg32] 113 | x86callersave = [ecx, edx] 114 | 115 | x86calleesave :: [Reg32] 116 | x86calleesave = [ebx, esi, edi] 117 | 118 | x86regs :: [Reg32] 119 | x86regs = [eax, ecx, edx, ebx, 120 | esp, ebp, esi, edi, 121 | eip] 122 | 123 | type WriteBackRegs = M.Map Reg32 CPtrdiff 124 | 125 | printWbr :: WriteBackRegs -> String 126 | printWbr wbregs = 127 | printf "reg dump:\n" ++ 128 | (concatMap (\reg -> printf "%s: 0x%08x\n" (printReg reg) 129 | (fromIntegral (case M.lookup reg wbregs of Just x -> x; Nothing -> 0xffeeddcc) :: Word32)) 130 | x86regs) 131 | where 132 | printReg (Reg32 8) = "eip" 133 | printReg x = show x 134 | 135 | type TrapPatcher = WriteBackRegs -> CodeGen () () WriteBackRegs 136 | type TrapPatcherEax = TrapPatcher 137 | type ExceptionHandler = WriteBackRegs -> IO WriteBackRegs 138 | 139 | data TrapCause 140 | = StaticMethod TrapPatcher -- for static calls 141 | | VirtualCall Bool MethodInfo (IO NativeWord) -- for invoke{interface,virtual} 142 | | InstanceOf TrapPatcherEax 143 | | ThrowException TrapPatcherEax 144 | | DivByNullException 145 | | NewObject TrapPatcher 146 | | StaticField StaticFieldInfo 147 | | ObjectField TrapPatcher 148 | 149 | data StaticFieldInfo = StaticFieldInfo { 150 | sfiClassName :: B.ByteString, 151 | sfiFieldName :: B.ByteString } deriving Show 152 | 153 | 154 | 155 | -- NativeWord = entry of method 156 | type MethodMap = M.Map MethodInfo NativeWord 157 | 158 | data MethodInfo = MethodInfo { 159 | methName :: B.ByteString, 160 | methClassName :: B.ByteString, 161 | methSignature :: MethodSignature 162 | } deriving (Eq, Ord) 163 | 164 | instance Show MethodInfo where 165 | show (MethodInfo method c sig) = 166 | toString c ++ "." ++ toString method ++ "." ++ show sig 167 | 168 | 169 | 170 | -- store information of loaded classes 171 | type ClassMap = M.Map B.ByteString ClassInfo 172 | 173 | data ClassInfo = ClassInfo { 174 | ciName :: B.ByteString, 175 | ciFile :: Class Direct, 176 | ciStaticMap :: FieldMap, 177 | ciStaticFieldTypeMap :: FieldTypeMap, 178 | ciFieldMap :: FieldMap, 179 | ciFieldTypeMap :: FieldTypeMap, 180 | ciFieldLength :: NativeWord, 181 | ciMethodMap :: FieldMap, 182 | ciMethodBase :: NativeWord, 183 | ciMethodLength :: NativeWord, 184 | ciInitDone :: Bool } 185 | 186 | 187 | -- store field offsets in a map 188 | type FieldMap = M.Map B.ByteString Int32 189 | 190 | -- store field information per offset 191 | type FieldTypeMap = M.Map Int32 (Field Direct) 192 | 193 | 194 | -- java strings are allocated only once, therefore we 195 | -- use a hashmap to store the address for a String 196 | type StringMap = M.Map B.ByteString NativeWord 197 | 198 | 199 | -- map "methodtable addr" to "classname" 200 | -- we need that to identify the actual type 201 | -- on the invokevirtual insn 202 | type VirtualMap = M.Map NativeWord B.ByteString 203 | 204 | 205 | -- store each parsed Interface upon first loading 206 | type InterfaceMap = M.Map B.ByteString (Class Direct) 207 | 208 | -- store offset for each pair 209 | type InterfaceMethodMap = M.Map B.ByteString NativeWord 210 | 211 | data MateObjType = ReferenceType | PrimitiveType deriving (Show,Eq) 212 | 213 | {- 214 | toString :: B.ByteString -> String 215 | toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr 216 | -} 217 | 218 | 219 | data MateCtx = MateCtx { 220 | ctxMethodMap :: MethodMap, 221 | ctxTrapMap :: TrapMap, 222 | ctxClassMap :: ClassMap, 223 | ctxVirtualMap :: VirtualMap, 224 | ctxStringMap :: StringMap, 225 | ctxInterfaceMap :: InterfaceMap, 226 | ctxInterfaceMethodMap :: InterfaceMethodMap } 227 | 228 | emptyMateCtx :: MateCtx 229 | emptyMateCtx = MateCtx M.empty M.empty M.empty M.empty M.empty M.empty M.empty 230 | 231 | mateCtx :: IORef MateCtx 232 | {-# NOINLINE mateCtx #-} 233 | mateCtx = unsafePerformIO $ newIORef emptyMateCtx 234 | 235 | setMap :: (MateCtx -> MateCtx) -> IO () 236 | setMap recordupdate = recordupdate <$> readIORef mateCtx >>= writeIORef mateCtx 237 | 238 | setMethodMap :: MethodMap -> IO () 239 | setMethodMap m = setMap (\x -> x {ctxMethodMap = m}) 240 | 241 | getMethodMap :: IO MethodMap 242 | getMethodMap = ctxMethodMap <$> readIORef mateCtx 243 | 244 | setTrapMap :: TrapMap -> IO () 245 | setTrapMap m = setMap (\x -> x {ctxTrapMap = m}) 246 | 247 | getTrapMap :: IO TrapMap 248 | getTrapMap = ctxTrapMap <$> readIORef mateCtx 249 | 250 | setClassMap :: ClassMap -> IO () 251 | setClassMap m = setMap (\x -> x {ctxClassMap = m}) 252 | 253 | getClassMap :: IO ClassMap 254 | getClassMap = ctxClassMap <$> readIORef mateCtx 255 | 256 | setVirtualMap :: VirtualMap -> IO () 257 | setVirtualMap m = setMap (\x -> x {ctxVirtualMap = m}) 258 | 259 | getVirtualMap :: IO VirtualMap 260 | getVirtualMap = ctxVirtualMap <$> readIORef mateCtx 261 | 262 | setStringMap :: StringMap -> IO () 263 | setStringMap m = setMap (\x -> x {ctxStringMap = m}) 264 | 265 | getStringMap :: IO StringMap 266 | getStringMap = ctxStringMap <$> readIORef mateCtx 267 | 268 | setInterfaceMap :: InterfaceMap -> IO () 269 | setInterfaceMap m = setMap (\x -> x {ctxInterfaceMap = m}) 270 | 271 | getInterfaceMap :: IO InterfaceMap 272 | getInterfaceMap = ctxInterfaceMap <$> readIORef mateCtx 273 | 274 | setInterfaceMethodMap :: InterfaceMethodMap -> IO () 275 | setInterfaceMethodMap m = setMap (\x -> x {ctxInterfaceMethodMap = m}) 276 | 277 | getInterfaceMethodMap :: IO InterfaceMethodMap 278 | getInterfaceMethodMap = ctxInterfaceMethodMap <$> readIORef mateCtx 279 | -------------------------------------------------------------------------------- /MateVMRuntime/Utilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module MateVMRuntime.Utilities where 3 | 4 | import Data.Word 5 | import qualified Data.Map as M 6 | import qualified Data.ByteString.Lazy as B 7 | import Data.List 8 | 9 | import JVM.ClassFile 10 | 11 | import Data.IORef 12 | import System.IO.Unsafe 13 | 14 | import MateVMRuntime.Types 15 | import MateVMRuntime.NativeSizes 16 | 17 | import System.CPUTime 18 | import Text.Printf 19 | import MateVMRuntime.Debug 20 | 21 | buildMethodID :: Class Direct -> Word16 -> MethodInfo 22 | buildMethodID cls idx = MethodInfo (ntName nt) rc (ntSignature nt) 23 | where 24 | (rc, nt) = case constsPool cls M.! idx of 25 | (CMethod rc' nt') -> (rc', nt') 26 | (CIfaceMethod rc' nt') -> (rc', nt') 27 | _ -> error "buildMethodID: something wrong. abort." 28 | 29 | buildFieldOffset :: Class Direct -> Word16 -> (B.ByteString, B.ByteString) 30 | buildFieldOffset cls idx = (rc, ntName fnt) 31 | where (CField rc fnt) = constsPool cls M.! idx 32 | 33 | buildClassID :: Class Direct -> Word16 -> B.ByteString 34 | buildClassID cls idx = cl 35 | where (CClass cl) = constsPool cls M.! idx 36 | 37 | 38 | methodNameTypeByIdx :: Class Direct -> Word16 -> NameType (Method Direct) 39 | methodNameTypeByIdx cls idx = case constsPool cls M.! idx of 40 | (CMethod _ nt') -> nt' 41 | (CIfaceMethod _ nt') -> nt' 42 | _ -> error "methodGetArgsCount: something wrong. abort." 43 | 44 | methodGetArgsCount :: NameType (Method Direct) -> NativeWord 45 | methodGetArgsCount nt = genericLength args 46 | where (MethodSignature args _) = ntSignature nt 47 | 48 | lookupMethodWithSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct) 49 | lookupMethodWithSig name sig cls = 50 | find (\x -> methodName x == name && methodSignature x == sig) $ classMethods cls 51 | 52 | checkNothing :: String -> Maybe a -> a 53 | checkNothing m Nothing = error m 54 | checkNothing _ (Just v) = v 55 | 56 | compileTime :: IORef Integer 57 | {-# NOINLINE compileTime #-} 58 | compileTime = unsafePerformIO $ newIORef 0 59 | 60 | -- measure time, from http://www.haskell.org/haskellwiki/Timing_computations 61 | time :: String -> IO t -> IO t 62 | time desc a = do 63 | start <- getCPUTime 64 | v <- a 65 | end <- getCPUTime 66 | let diff = end - start 67 | if (isPrefixOf "compile" desc) 68 | then do 69 | ct <- readIORef compileTime 70 | writeIORef compileTime $ ct + diff 71 | else do 72 | printfTime $ printf "%s: %0.6f\n" desc (((fromIntegral diff) / (10^12)) :: Double) 73 | return v 74 | 75 | printCompileTime :: IO () 76 | printCompileTime = do 77 | ct <- readIORef compileTime 78 | printfTime $ printf "compiletime: %0.6f\n" ((fromIntegral ct) / (10^12) :: Double) 79 | -------------------------------------------------------------------------------- /Misc/Logger.hs: -------------------------------------------------------------------------------- 1 | module Misc.Logger where 2 | import Debug.Trace 3 | 4 | -- Determines whether or not we print log messages 5 | debugMode :: Bool 6 | debugMode = False 7 | 8 | -- Logs if `debug` is True 9 | debug :: String -> () 10 | debug str = if debugMode then trace ("DEBUG: " ++ str) () else () 11 | 12 | -- Wrappers for when inside IO monad. This method is strict and evaluated immediately. 13 | debugM :: Monad m => String -> m () 14 | debugM str = return $! debug str 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # LLVM-JVM 2 | 3 | **Code for Functional Bytecode Interpreter (Proof-of-Concept) has been moved here: https://github.com/LouisJenkinsCS/Functional-JVM-Bytecode-Interpreter** 4 | 5 | LLVM-JVM is an attempt at creating a Java Virtual Machine with Just-In-Time compilation 6 | that uses LLVM as the backend, similar to [Azul System's](https://www.azul.com/called-new-jit-compiler-falcon/). 7 | This project, however, is an educational one and likely will never be production-ready. 8 | This project has been funded by Bloomsburg University's Professional Experience Grant (PEG). 9 | 10 | ## Note 11 | 12 | 13 | **Warning:** The code is a complete and utter mess! You've been warned! 14 | 15 | LLVM-JVM uses a ripped and modified version of [MateVM](https://github.com/MateVM/MateVM)'s runtime, while 16 | supplying its own frontend to LLVM. As such, everything contained in the 'MateVMRuntime' 17 | folder is code that belongs to the original authors, and I do not take credit for anything 18 | other than the modest changes I make, if any. 19 | 20 | ### Why not just fork the MateVM project? 21 | 22 | The MateVM project has been inactive for ~5 years, and considering that I would need to 23 | strip a lot of it away, such as Hoopl and Harpy, I would just take the best parts of 24 | them and give proper attribution. This not only saves me considerable time, which 25 | is something I have very little of, but also allows me to have access to the issue-tracker 26 | as well as other things. 27 | 28 | ## Progress 29 | 30 | Note: the criteria for progress is bars minimum, such as basic integer arithmetic and if-else statements. If it is checked it does not mean support for all of it, just that the ground work is done and can easily be extended on. 31 | 32 | - [X] Basic Arithmetic 33 | - [X] Integer 34 | - [ ] Float 35 | - [ ] Double 36 | - [ ] Long 37 | - [X] Basic Control Flow 38 | - [X] Loops 39 | - [X] Conditionals 40 | - [X] LLVM optimization passes 41 | - [X] Global Variables 42 | - [X] Static Fields 43 | - [ ] Instance Fields 44 | - [ ] Dynamic ClassLoading 45 | - [ ] JIT at Runtime 46 | - [ ] Garbage Collection 47 | - [ ] Boehms 48 | 49 | ## Building 50 | 51 | **Requirements:** 52 | 1. LLVM w/ llvm-config 53 | 2. Haskell 54 | 3. Java7+ (for GUI) 55 | 56 | 57 | To build, run 'cabal install' and 'ghc Main.hs -o Main.exe', then 'java -jar GUI/llvm-jvm-frontend.jar' 58 | if you desire the GUI. 59 | -------------------------------------------------------------------------------- /Report.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Report.pdf -------------------------------------------------------------------------------- /Test.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Rebuild 'Main' in case it has been changed... 4 | ghc Main.hs -o Main.exe 5 | if [ $? -eq 0 ]; then 6 | echo Main.exe Rebuilt 7 | else 8 | echo Main.exe Failed 9 | exit 10 | fi 11 | 12 | # All files should be in the 'Tests' directory 13 | cd Unit 14 | 15 | # Search all directories 16 | for d in */; do 17 | cd $d 18 | echo "cd $d" 19 | 20 | # We only search for files with the 'java' extension 21 | # Note that currently we can only run Java 7 '.class' 22 | # files, so we must cross-compile it... 23 | for f in *.java; do 24 | filename=$(basename "${f%.*}") 25 | 26 | # Skip 27 | if [ -f "$filename.skip" ]; then 28 | echo "Skipping $filename" 29 | continue 30 | fi 31 | 32 | bootstrap=$(java -verbose 2>/dev/null | sed -ne '1 s/\[Opened \(.*\)\]/\1/p') 33 | echo "bootstrap: $bootstrap, file: $f" 34 | javac -target 1.7 -source 1.7 -bootclasspath $bootstrap $f 35 | ../../Main.exe -cp ../../rt:./ "$filename" 1> tmp.out 2> tmp.err 36 | 37 | # Check if program completed successfully... 38 | if [ $? -eq 0 ]; then 39 | 40 | # Check output differences 41 | diff tmp.out "$filename.good" > "$filename.diff" 42 | diffLen="$(wc -c $filename.diff | awk '{print $1}')" 43 | 44 | # Output differences if incorrect... 45 | if [ $diffLen -eq 0 ]; then 46 | echo "[$filename]: SUCCESS" 47 | else 48 | echo "[$filename]: OUTPUT-DIFF" 49 | cat "$filename.diff" 50 | fi 51 | 52 | rm "$filename.diff" 53 | 54 | else 55 | echo "[$filename]: RUNTIME ERROR" 56 | cat tmp.err 57 | fi 58 | 59 | # Cleanup temporaries 60 | rm "$filename.class" 61 | rm tmp.out 62 | rm tmp.err 63 | 64 | done 65 | 66 | cd ../ 67 | done 68 | 69 | cd ../ 70 | -------------------------------------------------------------------------------- /Unit/Arithmetic/DoubleArithmetic.good: -------------------------------------------------------------------------------- 1 | x: 1.2345 2 | y: 6.7891 3 | z: 11.12131415 4 | x + y + z = 19.144914149999998 5 | x - y - z = -16.67591415 6 | x * y * z = 93.2093348043219 7 | x / y / z = 0.016350189100687973 8 | -------------------------------------------------------------------------------- /Unit/Arithmetic/DoubleArithmetic.java: -------------------------------------------------------------------------------- 1 | class DoubleArithmetic { 2 | public static void main(String[] args) { 3 | double x = 1.2345; 4 | double y = 6.78910; 5 | double z = 11.12131415; 6 | 7 | System.out.println("x: " + x); 8 | System.out.println("y: " + y); 9 | System.out.println("z: " + z); 10 | System.out.println("x + y + z = " + (x + y + z)); 11 | System.out.println("x - y - z = " + (x - y - z)); 12 | System.out.println("x * y * z = " + (x * y * z)); 13 | System.out.println("x / y / z = " + (x / y / z)); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /Unit/Arithmetic/DoubleArithmetic.skip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Arithmetic/DoubleArithmetic.skip -------------------------------------------------------------------------------- /Unit/Arithmetic/FloatArithmetic.good: -------------------------------------------------------------------------------- 1 | x: 1.2345 2 | y: 6.7891 3 | z: 11.121314 4 | x + y + z = 19.144915 5 | x - y - z = -16.675915 6 | x * y * z = 93.20934 7 | x / y / z = 0.01635019 8 | -------------------------------------------------------------------------------- /Unit/Arithmetic/FloatArithmetic.java: -------------------------------------------------------------------------------- 1 | class FloatArithmetic { 2 | public static void main(String[] args) { 3 | float x = 1.2345f; 4 | float y = 6.78910f; 5 | float z = 11.12131415f; 6 | 7 | System.out.println("x: " + x); 8 | System.out.println("y: " + y); 9 | System.out.println("z: " + z); 10 | System.out.println("x + y + z = " + (x + y + z)); 11 | System.out.println("x - y - z = " + (x - y - z)); 12 | System.out.println("x * y * z = " + (x * y * z)); 13 | System.out.println("x / y / z = " + (x / y / z)); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /Unit/Arithmetic/IntegerArithmetic.good: -------------------------------------------------------------------------------- 1 | x: 1 2 | y: 2 3 | z: 3 4 | x + y + z = 6 5 | x - y - z = -4 6 | x * y * z = 6 7 | x / y / z = 0 8 | -------------------------------------------------------------------------------- /Unit/Arithmetic/IntegerArithmetic.java: -------------------------------------------------------------------------------- 1 | class IntegerArithmetic { 2 | public static void main(String[] args) { 3 | int x = 1; 4 | int y = 2; 5 | int z = 3; 6 | 7 | System.out.println("x: " + x); 8 | System.out.println("y: " + y); 9 | System.out.println("z: " + z); 10 | System.out.println("x + y + z = " + (x + y + z)); 11 | System.out.println("x - y - z = " + (x - y - z)); 12 | System.out.println("x * y * z = " + (x * y * z)); 13 | System.out.println("x / y / z = " + (x / y / z)); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /Unit/Arithmetic/LongArithmetic.good: -------------------------------------------------------------------------------- 1 | x: 1000000000000 2 | y: 2000000000000 3 | z: 3000000000000 4 | x + y + z = 6000000000000 5 | x - y - z = -4000000000000 6 | x * y * z = 3730592787825950720 7 | x / y / z = 0 8 | -------------------------------------------------------------------------------- /Unit/Arithmetic/LongArithmetic.java: -------------------------------------------------------------------------------- 1 | class LongArithmetic { 2 | public static void main(String[] args) { 3 | long x = 1000000000000L; 4 | long y = 2000000000000L; 5 | long z = 3000000000000L; 6 | 7 | System.out.println("x: " + x); 8 | System.out.println("y: " + y); 9 | System.out.println("z: " + z); 10 | System.out.println("x + y + z = " + (x + y + z)); 11 | System.out.println("x - y - z = " + (x - y - z)); 12 | System.out.println("x * y * z = " + (x * y * z)); 13 | System.out.println("x / y / z = " + (x / y / z)); 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /Unit/Arithmetic/LongArithmetic.skip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Arithmetic/LongArithmetic.skip -------------------------------------------------------------------------------- /Unit/Basic/Addition.java: -------------------------------------------------------------------------------- 1 | class Addition { 2 | 3 | public static int result; 4 | 5 | public static int RunMe() { 6 | int x = 0x1000; 7 | int y = 0x2000; 8 | int z = 0x3000; 9 | int w = x + y + z; 10 | int a[] = new int[10]; 11 | 12 | if (w > x) { 13 | result = w; 14 | } else if (y > w) { 15 | result = y; 16 | } else if (z > w) { 17 | result = z; 18 | } else { 19 | result = x; 20 | } 21 | 22 | a[0] = result; 23 | 24 | return result; 25 | } 26 | 27 | public static void main(String[] args) { 28 | 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /Unit/Basic/bitcode: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Basic/bitcode -------------------------------------------------------------------------------- /Unit/Basic/bitcode.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Basic/bitcode.bc -------------------------------------------------------------------------------- /Unit/Basic/cfg.main.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'main' function" { 2 | label="CFG for 'main' function"; 3 | 4 | Node0xa9a1c0 [shape=record,label="{BB8:\l %0 = add i32 8192, 4096\l %1 = add i32 12288, %0\l %2 = icmp sle i32 %1, 4096\l br i1 %2, label %BB9, label %BB0\l|{T|F}}"]; 5 | Node0xa9a1c0:s0 -> Node0xa9a260; 6 | Node0xa9a1c0:s1 -> Node0xa9a210; 7 | Node0xa9a210 [shape=record,label="{BB0: \l store i32 %1, i32* @result\l br label %BB2\l}"]; 8 | Node0xa9a210 -> Node0xa9a3f0; 9 | Node0xa9a260 [shape=record,label="{BB9: \l %3 = icmp sle i32 8192, %1\l br i1 %3, label %BB10, label %BB3\l|{T|F}}"]; 10 | Node0xa9a260:s0 -> Node0xa9a300; 11 | Node0xa9a260:s1 -> Node0xa9a2b0; 12 | Node0xa9a2b0 [shape=record,label="{BB3: \l store i32 8192, i32* @result\l br label %BB2\l}"]; 13 | Node0xa9a2b0 -> Node0xa9a3f0; 14 | Node0xa9a300 [shape=record,label="{BB10: \l %4 = icmp sle i32 12288, %1\l br i1 %4, label %BB6, label %BB5\l|{T|F}}"]; 15 | Node0xa9a300:s0 -> Node0xa9a3a0; 16 | Node0xa9a300:s1 -> Node0xa9a350; 17 | Node0xa9a350 [shape=record,label="{BB5: \l store i32 12288, i32* @result\l br label %BB2\l}"]; 18 | Node0xa9a350 -> Node0xa9a3f0; 19 | Node0xa9a3a0 [shape=record,label="{BB6: \l store i32 4096, i32* @result\l br label %BB2\l}"]; 20 | Node0xa9a3a0 -> Node0xa9a3f0; 21 | Node0xa9a3f0 [shape=record,label="{BB2: \l %5 = load i32, i32* @result\l ret i32 %5\l}"]; 22 | } 23 | -------------------------------------------------------------------------------- /Unit/Basic/opt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Basic/opt -------------------------------------------------------------------------------- /Unit/Basic/optimizedIR.bc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Basic/optimizedIR.bc -------------------------------------------------------------------------------- /Unit/Basic/optimizedIR.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'Dummy' 2 | source_filename = "" 3 | 4 | @result = private global i32 0 5 | 6 | define i32 @main() { 7 | BB8: 8 | %0 = add i32 8192, 4096 9 | %1 = add i32 12288, %0 10 | %2 = icmp sle i32 %1, 4096 11 | br i1 %2, label %BB9, label %BB0 12 | 13 | BB0: ; preds = %BB8 14 | store i32 %1, i32* @result 15 | br label %BB2 16 | 17 | BB9: ; preds = %BB8 18 | %3 = icmp sle i32 8192, %1 19 | br i1 %3, label %BB10, label %BB3 20 | 21 | BB3: ; preds = %BB9 22 | store i32 8192, i32* @result 23 | br label %BB2 24 | 25 | BB10: ; preds = %BB9 26 | %4 = icmp sle i32 12288, %1 27 | br i1 %4, label %BB6, label %BB5 28 | 29 | BB5: ; preds = %BB10 30 | store i32 12288, i32* @result 31 | br label %BB2 32 | 33 | BB6: ; preds = %BB10 34 | store i32 4096, i32* @result 35 | br label %BB2 36 | 37 | BB2: ; preds = %BB6, %BB5, %BB3, %BB0 38 | %5 = load i32, i32* @result 39 | ret i32 %5 40 | } 41 | -------------------------------------------------------------------------------- /Unit/Basic/out.dot: -------------------------------------------------------------------------------- 1 | Printing analysis 'Print CFG of function to 'dot' file' for function 'main': 2 | -------------------------------------------------------------------------------- /Unit/Basic/out.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/Unit/Basic/out.png -------------------------------------------------------------------------------- /Unit/Basic/unoptimizedIR.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'Dummy' 2 | source_filename = "" 3 | 4 | @result = private global i32 0 5 | 6 | define i32 @main() { 7 | entry: 8 | %L0 = alloca i32 9 | %L1 = alloca i32 10 | %L2 = alloca i32 11 | %L3 = alloca i32 12 | store i32 4096, i32* %L0 13 | store i32 8192, i32* %L1 14 | store i32 12288, i32* %L2 15 | %0 = load i32, i32* %L0 16 | %1 = load i32, i32* %L1 17 | %2 = add i32 %1, %0 18 | %3 = load i32, i32* %L2 19 | %4 = add i32 %3, %2 20 | store i32 %4, i32* %L3 21 | %5 = load i32, i32* %L3 22 | %6 = load i32, i32* %L0 23 | br label %BB8 24 | 25 | BB8: ; preds = %entry 26 | %7 = icmp sle i32 %5, %6 27 | br i1 %7, label %BB1, label %BB0 28 | 29 | BB0: ; preds = %BB8 30 | %8 = load i32, i32* %L3 31 | store i32 %8, i32* @result 32 | br label %BB2 33 | 34 | BB1: ; preds = %BB8 35 | %9 = load i32, i32* %L1 36 | %10 = load i32, i32* %L3 37 | br label %BB9 38 | 39 | BB9: ; preds = %BB1 40 | %11 = icmp sle i32 %9, %10 41 | br i1 %11, label %BB4, label %BB3 42 | 43 | BB3: ; preds = %BB9 44 | %12 = load i32, i32* %L1 45 | store i32 %12, i32* @result 46 | br label %BB2 47 | 48 | BB4: ; preds = %BB9 49 | %13 = load i32, i32* %L2 50 | %14 = load i32, i32* %L3 51 | br label %BB10 52 | 53 | BB10: ; preds = %BB4 54 | %15 = icmp sle i32 %13, %14 55 | br i1 %15, label %BB6, label %BB5 56 | 57 | BB5: ; preds = %BB10 58 | %16 = load i32, i32* %L2 59 | store i32 %16, i32* @result 60 | br label %BB2 61 | 62 | BB6: ; preds = %BB10 63 | %17 = load i32, i32* %L0 64 | store i32 %17, i32* @result 65 | br label %BB2 66 | 67 | BB2: ; preds = %BB6, %BB5, %BB3, %BB0 68 | %18 = load i32, i32* @result 69 | ret i32 %18 70 | 71 | BB7: ; No predecessors! 72 | ret i32 0 73 | } 74 | -------------------------------------------------------------------------------- /llvm-jvm.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/llvm-jvm.pptx -------------------------------------------------------------------------------- /rt/java/io/PrintStream.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/io/PrintStream.class -------------------------------------------------------------------------------- /rt/java/io/PrintStream.java: -------------------------------------------------------------------------------- 1 | package java.io; 2 | 3 | import jmate.io.*; 4 | 5 | public class PrintStream { 6 | public void println(String a) { 7 | new jmate.io.PrintStream().println(a); 8 | } 9 | 10 | public PrintStream printf(String format, Object... args) { 11 | /* TODO ... */ 12 | new jmate.io.PrintStream().printf(format, args); 13 | return this; 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /rt/java/lang/ArithmeticException.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/ArithmeticException.class -------------------------------------------------------------------------------- /rt/java/lang/ArithmeticException.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class ArithmeticException extends RuntimeException { 4 | public ArithmeticException(String name) { 5 | super(name); 6 | } 7 | public String toString() { 8 | return "java.lang.ArithmeticException: / by zero"; 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /rt/java/lang/Character.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/Character.class -------------------------------------------------------------------------------- /rt/java/lang/Character.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class Character { 4 | char value; 5 | 6 | public Character(char a) { 7 | this.value = a; 8 | } 9 | 10 | public static Character valueOf(char a) { 11 | return new Character(a); 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /rt/java/lang/Exception.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/Exception.class -------------------------------------------------------------------------------- /rt/java/lang/Exception.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class Exception extends Throwable { 4 | public Exception() { 5 | super(); 6 | } 7 | 8 | public Exception(String name) { 9 | super(name); 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /rt/java/lang/IllegalArgumentException.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/IllegalArgumentException.class -------------------------------------------------------------------------------- /rt/java/lang/IllegalArgumentException.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class IllegalArgumentException extends RuntimeException { } 4 | -------------------------------------------------------------------------------- /rt/java/lang/Integer.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/Integer.class -------------------------------------------------------------------------------- /rt/java/lang/Integer.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class Integer { 4 | int value; 5 | 6 | public Integer(int a) { 7 | this.value = a; 8 | } 9 | 10 | public int intValue() { 11 | return this.value; 12 | } 13 | 14 | public static Integer valueOf(int a) { 15 | return new Integer(a); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /rt/java/lang/NullPointerException.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/NullPointerException.class -------------------------------------------------------------------------------- /rt/java/lang/NullPointerException.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class NullPointerException extends RuntimeException { 4 | public String toString() { 5 | return "java.lang.NullPointerException"; 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /rt/java/lang/Object.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/Object.class -------------------------------------------------------------------------------- /rt/java/lang/RuntimeException.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/RuntimeException.class -------------------------------------------------------------------------------- /rt/java/lang/RuntimeException.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class RuntimeException extends Exception { 4 | public RuntimeException() { 5 | super(); 6 | } 7 | 8 | public RuntimeException(String name) { 9 | super(name); 10 | } 11 | 12 | public String toString() { 13 | return "java.lang.RuntimeException"; 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /rt/java/lang/String.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/String.class -------------------------------------------------------------------------------- /rt/java/lang/String.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class String { 4 | public char[] value; 5 | public int count; 6 | public int cachedHashCode; 7 | public int offset; 8 | } 9 | -------------------------------------------------------------------------------- /rt/java/lang/System.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/System.class -------------------------------------------------------------------------------- /rt/java/lang/System.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class System { 4 | public static java.io.PrintStream out = new java.io.PrintStream(); 5 | } 6 | 7 | -------------------------------------------------------------------------------- /rt/java/lang/Throwable.class: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LouisJenkinsCS/LLVM-JVM/15a45194a70e499133cd340f647d2438540ff3f7/rt/java/lang/Throwable.class -------------------------------------------------------------------------------- /rt/java/lang/Throwable.java: -------------------------------------------------------------------------------- 1 | package java.lang; 2 | 3 | public class Throwable { 4 | public String msg; 5 | 6 | public Throwable () { 7 | this.msg = "I'm a Throwable"; 8 | } 9 | 10 | public Throwable(String msg) { 11 | this.msg = msg; 12 | } 13 | 14 | public String getMessage() { 15 | return this.msg; 16 | } 17 | 18 | public String toString() { 19 | return "java.lang.Throwable"; 20 | } 21 | } 22 | --------------------------------------------------------------------------------