├── .gitignore ├── LICENSE ├── README.md ├── codec-jvm.cabal ├── example └── Main.hs ├── src └── Codec │ ├── JVM.hs │ └── JVM │ ├── ASM.hs │ ├── ASM │ ├── Code.hs │ └── Code │ │ ├── CtrlFlow.hs │ │ ├── Instr.hs │ │ └── Types.hs │ ├── Attr.hs │ ├── Class.hs │ ├── Const.hs │ ├── ConstPool.hs │ ├── Encoding.hs │ ├── Field.hs │ ├── Internal.hs │ ├── Method.hs │ ├── Opcode.hs │ ├── Parse.hs │ └── Types.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | *.class 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | codec-jvm 2 | ===== 3 | 4 | [![Join the chat at https://gitter.im/codec-jvm/Lobby](https://badges.gitter.im/codec-jvm/Lobby.svg)](https://gitter.im/codec-jvm/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 5 | [![Build Status](https://circleci.com/gh/rahulmutt/codec-jvm.svg?style=shield&circle-token=1f7b4c7b00bc633430689b78b042c7d7a7991504)](https://circleci.com/gh/rahulmutt/codec-jvm) 6 | 7 | A JVM bytecode assembler written in Haskell. 8 | -------------------------------------------------------------------------------- /codec-jvm.cabal: -------------------------------------------------------------------------------- 1 | name: codec-jvm 2 | version: 0.1 3 | license: Apache-2.0 4 | license-file: LICENSE 5 | author: Alois Cochard 6 | maintainer: alois.cochard@gmail.com 7 | copyright: Copyright (c) 2015 Alois Cochard 8 | (c) 2016-2017 Rahul Muttineni 9 | category: Development 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | library 14 | default-language: Haskell2010 15 | hs-source-dirs: src 16 | ghc-options: -Wall -fno-warn-unused-do-bind 17 | exposed-modules: 18 | Codec.JVM 19 | Codec.JVM.ASM 20 | Codec.JVM.ASM.Code 21 | Codec.JVM.ASM.Code.CtrlFlow 22 | Codec.JVM.ASM.Code.Instr 23 | Codec.JVM.ASM.Code.Types 24 | Codec.JVM.Attr 25 | Codec.JVM.Class 26 | Codec.JVM.Parse 27 | Codec.JVM.Const 28 | Codec.JVM.ConstPool 29 | Codec.JVM.Encoding 30 | Codec.JVM.Field 31 | Codec.JVM.Internal 32 | Codec.JVM.Method 33 | Codec.JVM.Opcode 34 | Codec.JVM.Types 35 | build-depends: 36 | base >= 4.6.0.1 && < 5 37 | , binary >= 0.7 && < 0.9 38 | , bytestring >= 0.10 && < 0.11 39 | , containers >= 0.5 && < 0.6 40 | , text >= 1.2 && < 1.3 41 | , stringsearch 42 | , mtl 43 | , array 44 | , transformers 45 | default-extensions: NamedFieldPuns 46 | 47 | 48 | executable example 49 | hs-source-dirs: example 50 | main-is: Main.hs 51 | default-language: Haskell2010 52 | build-depends: base >= 4.7 && < 5 53 | , bytestring 54 | , text 55 | , codec-jvm 56 | , containers 57 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, CPP #-} 2 | module Main where 3 | 4 | import System.Environment 5 | import Codec.JVM 6 | import Codec.JVM.Parse 7 | import Codec.JVM.ASM.Code.Instr 8 | import Codec.JVM.ConstPool 9 | import Data.Monoid((<>)) 10 | 11 | import Data.Text (Text) 12 | import qualified Data.ByteString as BS 13 | {- 14 | #ifdef ETA_VERSION 15 | import GHC.IO (trampolineIO) 16 | #else 17 | trampolineIO = id 18 | #endif 19 | 20 | main :: IO () 21 | main = do 22 | [file] <- getArgs 23 | res <- parse file 24 | print res 25 | -} 26 | 27 | main :: IO () 28 | main = BS.writeFile "Test.class" $ classFileBS classFile 29 | 30 | mainClass :: Text 31 | mainClass = "Test" 32 | 33 | classFile :: ClassFile 34 | classFile = mkClassFileWithAttrs java7 [Public, Super] mainClass Nothing [] [] [srcFile] 35 | [ 36 | mkMethodDef mainClass [Public, Static] "main" [jarray jstring] void $ 37 | startLabel loop 38 | <> markStackMap 39 | <> emitLineNumber (ln 5) 40 | <> iconst jint 1 41 | <> iconst jint 1 42 | <> iadd 43 | <> ifeq (goto loop) mempty 44 | <> vreturn 45 | ] (const False) 46 | where srcFile = mkSourceFileAttr "Main.hs" 47 | loop = mkLabel 1 48 | ln = mkLineNumber 49 | 50 | dumpStackMap :: Code -> IO () 51 | dumpStackMap (Code consts instr) = do 52 | putStrLn "Control Flow:" 53 | print cf 54 | where cp = mkConstPool consts 55 | (_, cf, smt) = runInstrBCS instr cp 56 | -------------------------------------------------------------------------------- /src/Codec/JVM.hs: -------------------------------------------------------------------------------- 1 | module Codec.JVM (module X) where 2 | 3 | import Codec.JVM.ASM as X 4 | import Codec.JVM.Class as X 5 | import Codec.JVM.Types as X 6 | import Codec.JVM.ASM.Code as X 7 | import Codec.JVM.ASM.Code.Types as X hiding (BranchType(..)) 8 | -------------------------------------------------------------------------------- /src/Codec/JVM/ASM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | Usage: 4 | -- 5 | -- You can assemble a java class: 6 | -- 7 | -- @ 8 | -- {-# LANGUAGE OverloadedStrings #-} 9 | -- import Data.Binary.Put (runPut) 10 | -- import Data.Foldable (fold) 11 | -- import qualified Data.ByteString.Lazy as BS 12 | -- 13 | -- import Codec.JVM.ASM (mkClassFile, mkMethodDef) 14 | -- import Codec.JVM.ASM.Code 15 | -- import Codec.JVM.Class (ClassFile, putClassFile) 16 | -- import Codec.JVM.Method (AccessFlag(..)) 17 | -- import Codec.JVM.Types 18 | -- 19 | -- mainClass :: ClassFile 20 | -- mainClass = mkClassFile java8 [] "HelloWorld" Nothing 21 | -- [ mkMethodDef [Public, Static] "main" [arr.obj $ "java/lang/String"] void $ fold 22 | -- [ getstatic systemOut 23 | -- , bipush jint 42 24 | -- , invokevirtual printlnI 25 | -- , vreturn ] 26 | -- ] 27 | -- where 28 | -- systemOut = mkFieldRef "java/lang/System" "out" (obj "java/io/PrintStream") 29 | -- printlnI = mkMethodRef "java/io/PrintStream" "println" [prim JInt] void 30 | -- 31 | -- main :: IO () 32 | -- main = BS.writeFile "HelloWorld.class" $ runPut . putClassFile $ mainClass 33 | -- @ 34 | -- 35 | module Codec.JVM.ASM where 36 | 37 | import Data.Foldable (fold) 38 | import Data.Monoid ((<>)) 39 | import Data.Maybe (fromMaybe) 40 | import Data.Text (Text) 41 | 42 | import qualified Data.Set as Set 43 | import qualified Data.Map.Strict as Map 44 | 45 | import Codec.JVM.ASM.Code (Code, vreturn, invokespecial, dup, gload) 46 | import Codec.JVM.Attr (attrName, innerClassInfo, unpackAttr, Attr(AInnerClasses,ASourceFile)) 47 | import Codec.JVM.Class (ClassFile(..)) 48 | import Codec.JVM.Const (Const(..)) 49 | import Codec.JVM.ConstPool (unpackClassName) 50 | import Codec.JVM.Method (MethodInfo(..), unpackMethodInfo) 51 | import Codec.JVM.Field (FieldInfo(FieldInfo), unpackFieldInfo) 52 | import Codec.JVM.Types 53 | 54 | import qualified Codec.JVM.ASM.Code as Code 55 | 56 | mkClassFile :: Version 57 | -> [AccessFlag] 58 | -> Text -- class name 59 | -> Maybe Text -- superclass, java/lang/Object is nothing 60 | -> [Text] -- Interfaces 61 | -> [FieldDef] 62 | -> [MethodDef] 63 | -> ClassFile 64 | mkClassFile v afs tc' sc' is' fds mds = mkClassFileWithAttrs v afs tc' sc' is' fds [] mds (const False) 65 | 66 | mkClassFileWithAttrs :: Version 67 | -> [AccessFlag] 68 | -> Text -- class name 69 | -> Maybe Text -- superclass, java/lang/Object is nothing 70 | -> [Text] -- Interfaces 71 | -> [FieldDef] 72 | -> [Attr] 73 | -> [MethodDef] 74 | -> (Text -> Bool) 75 | -> ClassFile 76 | mkClassFileWithAttrs v afs tc' sc' is' fds attrs' mds f = 77 | ClassFile cs v (Set.fromList afs) tc sc is fis mis attrs 78 | where 79 | is = map IClassName is' 80 | tc = IClassName tc' 81 | sc = IClassName <$> sc' 82 | cs' = ccs ++ mdcs ++ mics ++ fdcs ++ fics where 83 | ccs = concat $ [unpackClassName tc, unpackClassName $ fromMaybe jlObject sc] 84 | ++ map unpackClassName is 85 | mdcs = mds >>= unpackMethodDef 86 | mics = mis >>= unpackMethodInfo 87 | fdcs = fds >>= unpackFieldDef 88 | fics = fis >>= unpackFieldInfo 89 | 90 | (cs'', innerAttrs) = innerClassInfo f cs' 91 | attrs'' = attrs' ++ innerAttrs 92 | acs = concatMap unpackAttr attrs'' 93 | attrs = Map.fromList . map (\attr -> (attrName attr, attr)) $ attrs'' 94 | cs = cs'' ++ cs' ++ acs 95 | mis = f <$> mds where 96 | f (MethodDef afs' n' (MethodDesc d) code ats) = 97 | MethodInfo (Set.fromList afs') n' (Desc d) code ats 98 | 99 | fis = f <$> fds where 100 | f (FieldDef afs' n' (FieldDesc d)) = 101 | FieldInfo (Set.fromList afs') n' (Desc d) [] 102 | 103 | data MethodDef = MethodDef { 104 | mdAccessFlags :: [AccessFlag], 105 | mdMethodName :: UName, 106 | mdDescriptor :: MethodDesc, 107 | mdCode :: Code, 108 | mdAttributes :: [Attr] } 109 | deriving Show 110 | 111 | mkMethodDef :: Text -> [AccessFlag] -> Text -> [FieldType] -> ReturnType -> Code -> MethodDef 112 | mkMethodDef cls afs n fts rt cs = mkMethodDef' afs n (mkMethodDesc fts rt) code 113 | where code = Code.initCtrlFlow (Static `elem` afs) ((obj cls) : fts) <> cs 114 | 115 | mkMethodDef' :: [AccessFlag] -> Text -> MethodDesc -> Code -> MethodDef 116 | mkMethodDef' afs n md c = MethodDef afs (UName n) md c [] 117 | 118 | -- TODO: Validate attributes to avoid collisions 119 | addAttrsToMethodDef :: [Attr] -> MethodDef -> MethodDef 120 | addAttrsToMethodDef attrs methodDef = methodDef { mdAttributes = mdAttributes methodDef ++ attrs } 121 | 122 | unpackMethodDef :: MethodDef -> [Const] 123 | unpackMethodDef (MethodDef _ (UName n') (MethodDesc d) code attrs) = 124 | [CUTF8 n', CUTF8 d] ++ Code.consts code ++ concatMap unpackAttr attrs 125 | 126 | data FieldDef = FieldDef [AccessFlag] UName FieldDesc 127 | deriving Show 128 | 129 | mkFieldDef :: [AccessFlag] -> Text -> FieldType -> FieldDef 130 | mkFieldDef afs n ft = mkFieldDef' afs n (mkFieldDesc ft) 131 | 132 | mkFieldDef' :: [AccessFlag] -> Text -> FieldDesc -> FieldDef 133 | mkFieldDef' afs n fd = FieldDef afs (UName n) fd 134 | 135 | unpackFieldDef :: FieldDef -> [Const] 136 | unpackFieldDef (FieldDef _ (UName n') (FieldDesc d)) = [CUTF8 n', CUTF8 d] 137 | 138 | mkDefaultConstructor :: Text -> Text -> MethodDef 139 | mkDefaultConstructor thisClass superClass = 140 | mkMethodDef thisClass [Public] "" [] void $ fold 141 | [ gload thisFt 0, 142 | invokespecial $ mkMethodRef superClass "" [] void, 143 | vreturn ] 144 | where thisFt = obj thisClass 145 | 146 | -- This leaves this on the operand stack for the code to consume 147 | mkConstructorDef :: Text -> Text -> [FieldType] -> Code -> MethodDef 148 | mkConstructorDef thisClass superClass args code = 149 | mkMethodDef thisClass [Public] "" args void $ 150 | gload thisFt 0 151 | <> dup thisFt 152 | <> invokespecial (mkMethodRef superClass "" [] void) 153 | <> code 154 | <> vreturn 155 | where thisFt = obj thisClass 156 | 157 | addInnerClasses :: (Text -> Bool) -> [ClassFile] -> ClassFile -> ClassFile 158 | addInnerClasses ignore innerClasses 159 | outerClass@ClassFile { attributes = outerAttributes 160 | , constants = outerConstants } 161 | = case maybeAttr of 162 | (newInnerAttr:_) -> 163 | outerClass 164 | { constants = (unpackAttr newInnerAttr) ++ consts ++ outerConstants 165 | , attributes = 166 | Map.insertWith mergeInnerClasses 167 | (attrName newInnerAttr) newInnerAttr outerAttributes } 168 | _ -> outerClass 169 | where mergeInnerClasses 170 | (AInnerClasses newInnerClassMap) 171 | (AInnerClasses oldInnerClassMap) 172 | = AInnerClasses $ oldInnerClassMap <> newInnerClassMap 173 | mergeInnerClasses _ _ = error "Bad inner class attributes" 174 | (consts, maybeAttr) = innerClassInfo ignore classConsts 175 | classConsts = map (\ClassFile {..} -> CClass thisClass) innerClasses 176 | 177 | mkSourceFileAttr :: Text -> Attr 178 | mkSourceFileAttr = ASourceFile 179 | -------------------------------------------------------------------------------- /src/Codec/JVM/ASM/Code.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Codec.JVM.ASM.Code where 3 | 4 | import Control.Monad.Reader 5 | import Data.Text (Text) 6 | import Data.ByteString (ByteString) 7 | import Data.Foldable (fold) 8 | import Data.Monoid ((<>)) 9 | import Data.Word (Word8, Word16) 10 | import Data.Int (Int32, Int64) 11 | 12 | import qualified Data.ByteString as BS 13 | 14 | import Codec.JVM.ASM.Code.Instr (Instr(..)) 15 | import Codec.JVM.Const 16 | import Codec.JVM.Internal (packWord16be, packI16) 17 | import Codec.JVM.Opcode (Opcode) 18 | import Codec.JVM.Types 19 | 20 | import Codec.JVM.ASM.Code.Types 21 | import Codec.JVM.ASM.Code.CtrlFlow (VerifType(..), Stack) 22 | import qualified Codec.JVM.ASM.Code.CtrlFlow as CF 23 | import qualified Codec.JVM.ASM.Code.Instr as IT 24 | import qualified Codec.JVM.ConstPool as CP 25 | import qualified Codec.JVM.Opcode as OP 26 | 27 | import Data.IntMap.Strict (IntMap) 28 | import qualified Data.IntMap.Strict as IntMap 29 | 30 | import Data.Maybe (maybeToList, catMaybes, fromJust) 31 | 32 | data Code = Code 33 | { consts :: [Const] 34 | , instr :: Instr } 35 | deriving Show 36 | 37 | instance Monoid Code where 38 | mempty = Code mempty mempty 39 | mappend (Code cs0 i0) (Code cs1 i1) = Code (mappend cs0 cs1) (mappend i0 i1) 40 | 41 | #if MIN_VERSION_base(4,10,0) 42 | instance Semigroup Code where 43 | (<>) (Code cs0 i0) (Code cs1 i1) = Code ((<>) cs0 cs1) ((<>) i0 i1) 44 | #endif 45 | 46 | mkCode :: [Const] -> Instr -> Code 47 | mkCode = Code 48 | 49 | mkCode' :: Instr -> Code 50 | mkCode' = mkCode [] 51 | 52 | modifyStack :: (Stack -> Stack) -> Instr 53 | modifyStack = IT.modifyStack 54 | 55 | codeConst :: Opcode -> FieldType -> Const -> Code 56 | codeConst oc ft c = mkCode cs $ fold 57 | [ IT.op oc 58 | , IT.ix c 59 | , modifyStack $ CF.push ft ] 60 | where cs = CP.unpack c 61 | 62 | codeBytes :: ByteString -> Code 63 | codeBytes bs = mkCode [] $ IT.bytes bs 64 | 65 | op :: Opcode -> Code 66 | op = mkCode' . IT.op 67 | 68 | pushBytes :: Opcode -> FieldType -> ByteString -> Code 69 | pushBytes oc ft bs = mkCode' $ fold 70 | [ IT.op oc 71 | , IT.bytes bs 72 | , modifyStack $ CF.push ft ] 73 | 74 | -- 75 | -- Operations 76 | -- 77 | 78 | bipush :: FieldType -> Word8 -> Code 79 | bipush ft w = pushBytes OP.bipush ft $ BS.singleton w 80 | 81 | sipush :: FieldType -> Word16 -> Code 82 | sipush ft w = pushBytes OP.sipush ft $ packWord16be w 83 | 84 | dup :: FieldType -> Code 85 | dup ft = mkCode' 86 | $ IT.op dupOp 87 | <> modifyStack (CF.push ft) 88 | where fsz = fieldSize ft 89 | dupOp = if fsz == 1 then OP.dup else OP.dup2 90 | 91 | -- TODO: Support category 2 types 92 | gdup :: Code 93 | gdup = mkCode' $ IT.op OP.dup 94 | <> IT.withStack (\vts -> (head vts) : vts) 95 | 96 | pop :: FieldType -> Code 97 | pop ft = mkCode' 98 | $ IT.op popOp 99 | <> modifyStack (CF.pop ft) 100 | where fsz = fieldSize ft 101 | popOp = if fsz == 1 then OP.pop else OP.pop2 102 | 103 | invoke :: Bool -> Bool -> Opcode -> MethodRef -> Code 104 | invoke this interface oc mr@(MethodRef _ _ fts rt) = mkCode cs $ 105 | IT.op oc 106 | <> IT.ix c 107 | <> (if interface then IT.bytes $ BS.pack [fromIntegral $ sumArgSizes + 1, 0] else mempty) 108 | <> modifyStack (maybePushReturn . popArgs) 109 | where 110 | maybePushReturn = maybe id CF.push rt 111 | sumArgSizes = sum (fieldSize <$> fts) 112 | popArgs = CF.pop' 113 | $ sumArgSizes 114 | + (if this then 1 else 0) 115 | c = (if interface then CInterfaceMethodRef else CMethodRef) mr 116 | cs = CP.unpack c 117 | 118 | invokeinterface :: MethodRef -> Code 119 | invokeinterface = invoke True True OP.invokeinterface 120 | 121 | invokevirtual :: MethodRef -> Code 122 | invokevirtual = invoke True False OP.invokevirtual 123 | 124 | invokespecial :: MethodRef -> Code 125 | invokespecial = invoke True False OP.invokespecial 126 | 127 | invokestatic :: MethodRef -> Code 128 | invokestatic = invoke False False OP.invokestatic 129 | 130 | getfield :: FieldRef -> Code 131 | getfield fr@(FieldRef _ _ ft) = mkCode cs $ fold 132 | [ IT.op OP.getfield 133 | , IT.ix c 134 | , modifyStack 135 | $ CF.push ft 136 | . CF.pop' 1 ] -- NOTE: Assumes that an object ref takes 1 stack slot 137 | where c = CFieldRef fr 138 | cs = CP.unpack c 139 | 140 | putfield :: FieldRef -> Code 141 | putfield fr@(FieldRef _ _ ft) = mkCode cs $ fold 142 | [ IT.op OP.putfield 143 | , IT.ix c 144 | , modifyStack 145 | $ CF.pop' 1 -- NOTE: Assumes that an object ref takes 1 stack slot 146 | . CF.pop ft ] 147 | where c = CFieldRef fr 148 | cs = CP.unpack c 149 | 150 | getstatic :: FieldRef -> Code 151 | getstatic fr@(FieldRef _ _ ft) = mkCode cs $ fold 152 | [ IT.op OP.getstatic 153 | , IT.ix c 154 | , modifyStack 155 | $ CF.push ft ] 156 | where c = CFieldRef fr 157 | cs = CP.unpack c 158 | 159 | putstatic :: FieldRef -> Code 160 | putstatic fr@(FieldRef _ _ ft) = mkCode cs $ fold 161 | [ IT.op OP.putstatic 162 | , IT.ix c 163 | , modifyStack 164 | $ CF.pop ft ] 165 | where c = CFieldRef fr 166 | cs = CP.unpack c 167 | 168 | opStack :: (FieldType -> Stack -> Stack) -> FieldType -> Opcode -> Code 169 | opStack f ft oc = mkCode' $ IT.op oc <> modifyStack (f ft) 170 | 171 | unaryOp, binaryOp, shiftOp, cmpOp :: FieldType -> Opcode -> Code 172 | unaryOp = opStack (\ft -> CF.push ft . CF.pop ft) 173 | binaryOp = opStack (\ft -> CF.push ft . CF.pop ft . CF.pop ft) 174 | shiftOp = opStack (\ft -> CF.push ft . CF.pop ft . CF.pop jint) 175 | cmpOp = opStack (\ft -> CF.push jint . CF.pop ft . CF.pop ft) 176 | 177 | iadd, ladd, fadd, dadd :: Code 178 | iadd = binaryOp jint OP.iadd 179 | ladd = binaryOp jlong OP.ladd 180 | fadd = binaryOp jfloat OP.fadd 181 | dadd = binaryOp jdouble OP.dadd 182 | 183 | isub, lsub, fsub, dsub :: Code 184 | isub = binaryOp jint OP.isub 185 | lsub = binaryOp jlong OP.lsub 186 | fsub = binaryOp jfloat OP.fsub 187 | dsub = binaryOp jdouble OP.dsub 188 | 189 | imul, lmul, fmul, dmul :: Code 190 | imul = binaryOp jint OP.imul 191 | lmul = binaryOp jlong OP.lmul 192 | fmul = binaryOp jfloat OP.fmul 193 | dmul = binaryOp jdouble OP.dmul 194 | 195 | idiv, ldiv, fdiv, ddiv :: Code 196 | idiv = binaryOp jint OP.idiv 197 | ldiv = binaryOp jlong OP.ldiv 198 | fdiv = binaryOp jfloat OP.fdiv 199 | ddiv = binaryOp jdouble OP.ddiv 200 | 201 | irem, lrem, frem, drem :: Code 202 | irem = binaryOp jint OP.irem 203 | lrem = binaryOp jlong OP.lrem 204 | frem = binaryOp jfloat OP.frem 205 | drem = binaryOp jdouble OP.drem 206 | 207 | ineg, lneg, fneg, dneg :: Code 208 | ineg = unaryOp jint OP.ineg 209 | lneg = unaryOp jlong OP.lneg 210 | fneg = unaryOp jfloat OP.fneg 211 | dneg = unaryOp jdouble OP.dneg 212 | 213 | ishl, ishr, iushr, lshl, lshr, lushr :: Code 214 | ishl = shiftOp jint OP.ishl 215 | ishr = shiftOp jint OP.ishr 216 | iushr = shiftOp jint OP.iushr 217 | lshl = shiftOp jlong OP.lshl 218 | lshr = shiftOp jlong OP.lshr 219 | lushr = shiftOp jlong OP.lushr 220 | 221 | ior, lor, iand, land, ixor, lxor, inot, lnot :: Code 222 | ior = binaryOp jint OP.ior 223 | iand = binaryOp jint OP.iand 224 | ixor = binaryOp jint OP.ixor 225 | lor = binaryOp jlong OP.lor 226 | land = binaryOp jlong OP.land 227 | lxor = binaryOp jlong OP.lxor 228 | inot = iconst jint (-1) 229 | <> ixor 230 | lnot = lconst (-1) 231 | <> lxor 232 | 233 | fcmpl, fcmpg, dcmpl, dcmpg, lcmp :: Code 234 | fcmpl = cmpOp jfloat OP.fcmpl 235 | fcmpg = cmpOp jfloat OP.fcmpg 236 | dcmpg = cmpOp jdouble OP.dcmpg 237 | dcmpl = cmpOp jdouble OP.dcmpl 238 | lcmp = cmpOp jlong OP.lcmp 239 | 240 | gcmp :: FieldType -> Code -> Code -> Code 241 | gcmp (BaseType bt) arg1 arg2 = arg1 <> arg2 <> cmp 242 | where cmp = case bt of 243 | JLong -> lcmp 244 | _ -> error $ "gcmp: Unsupported primitive type: " ++ show bt 245 | gcmp _ _ _ = error "gcmp: Non-primitive types not supported." 246 | 247 | gbranch :: (FieldType -> Stack -> Stack) 248 | -> FieldType -> Opcode -> Code -> Code -> Code 249 | gbranch f ft oc ok ko = mkCode cs ins 250 | where cs = [ok, ko] >>= consts 251 | ins = IT.gbranch f ft oc (instr ok) (instr ko) 252 | 253 | unaryBranch, binaryBranch :: FieldType -> Opcode -> Code -> Code -> Code 254 | unaryBranch = gbranch CF.pop 255 | binaryBranch = gbranch (\ft -> CF.pop ft . CF.pop ft) 256 | 257 | intBranch1, intBranch2 :: Opcode -> Code -> Code -> Code 258 | intBranch1 = unaryBranch jint 259 | intBranch2 = binaryBranch jint 260 | 261 | floatInvBranch :: FieldType -> Opcode -> (Code -> Code -> Code) -> Code -> Code -> Code 262 | floatInvBranch ft baseCmpOp specCmpOp operand1 operand2 = 263 | mkCode' (IT.op baseCmpOp <> modifyStack ( CF.push jint . CF.pop ft . CF.pop ft )) 264 | <> specCmpOp operand2 operand1 265 | 266 | ifne, ifeq, ifle, iflt, ifge, ifgt, ifnull, ifnonnull 267 | :: Code -> Code -> Code 268 | ifne = intBranch1 OP.ifne 269 | ifeq = intBranch1 OP.ifeq 270 | ifle = intBranch1 OP.ifle 271 | iflt = intBranch1 OP.iflt 272 | ifgt = intBranch1 OP.ifgt 273 | ifge = intBranch1 OP.ifge 274 | ifnull = unaryBranch jobject OP.ifnull 275 | ifnonnull = unaryBranch jobject OP.ifnonnull 276 | 277 | if_icmpeq, if_icmpne, if_icmplt, if_icmpge, if_icmpgt, if_icmple, 278 | if_fcmpeq, if_fcmpne, if_fcmplt, if_fcmpge, if_fcmpgt, if_fcmple, 279 | if_dcmpeq, if_dcmpne, if_dcmplt, if_dcmpge, if_dcmpgt, if_dcmple, 280 | if_acmpeq, if_acmpne :: Code -> Code -> Code 281 | if_icmpeq = intBranch2 OP.if_icmpeq 282 | if_icmpne = intBranch2 OP.if_icmpne 283 | if_icmplt = intBranch2 OP.if_icmplt 284 | if_icmpge = intBranch2 OP.if_icmpge 285 | if_icmpgt = intBranch2 OP.if_icmpgt 286 | if_icmple = intBranch2 OP.if_icmple 287 | if_acmpeq = binaryBranch jobject OP.if_acmpeq 288 | if_acmpne = binaryBranch jobject OP.if_acmpne 289 | 290 | if_fcmpeq = floatInvBranch jfloat OP.fcmpl ifne 291 | if_fcmpne = floatInvBranch jfloat OP.fcmpl ifeq 292 | if_fcmplt = floatInvBranch jfloat OP.fcmpg ifge 293 | if_fcmpge = floatInvBranch jfloat OP.fcmpl iflt 294 | if_fcmpgt = floatInvBranch jfloat OP.fcmpl ifle 295 | if_fcmple = floatInvBranch jfloat OP.fcmpg ifgt 296 | 297 | if_dcmpeq = floatInvBranch jdouble OP.dcmpl ifne 298 | if_dcmpne = floatInvBranch jdouble OP.dcmpl ifeq 299 | if_dcmplt = floatInvBranch jdouble OP.dcmpg ifge 300 | if_dcmpge = floatInvBranch jdouble OP.dcmpl iflt 301 | if_dcmpgt = floatInvBranch jdouble OP.dcmpl ifle 302 | if_dcmple = floatInvBranch jdouble OP.dcmpg ifgt 303 | 304 | gthrow :: FieldType -> Code 305 | gthrow ft = mkCode' $ 306 | IT.op OP.athrow 307 | <> modifyStack ( CF.push ft 308 | . CF.pop ft ) 309 | 310 | -- Generic instruction which selects either 311 | -- the original opcode or the modified opcode 312 | -- based on size 313 | gwide :: (Integral a) => Opcode -> a -> Instr 314 | gwide opcode n = wideInstr 315 | where wideInstr 316 | | n <= 255 = IT.op opcode 317 | <> IT.bytes (BS.singleton $ fromIntegral n) 318 | | otherwise = IT.op OP.wide 319 | <> IT.op opcode 320 | <> IT.bytes (packI16 $ fromIntegral n) 321 | 322 | ginstanceof :: FieldType -> Code 323 | ginstanceof ft@(ObjectType (IClassName className )) = 324 | mkCode cs $ 325 | IT.op OP.instanceof 326 | <> IT.ix c 327 | <> modifyStack ( CF.push jint 328 | . CF.pop ft ) 329 | where c = CClass . IClassName $ className 330 | cs = CP.unpack c 331 | 332 | ginstanceof _ = error "we don't support non-object types with instanceof" 333 | 334 | -- Generic load instruction 335 | gload :: FieldType -> Int -> Code 336 | gload ft n = mkCode cs $ fold 337 | [ loadOp 338 | , IT.ctrlFlow 339 | $ CF.load n ft ] 340 | where loadOp = case CF.fieldTypeFlatVerifType ft of 341 | VInteger -> case n of 342 | 0 -> IT.op OP.iload_0 343 | 1 -> IT.op OP.iload_1 344 | 2 -> IT.op OP.iload_2 345 | 3 -> IT.op OP.iload_3 346 | _ -> gwide OP.iload n 347 | VLong -> case n of 348 | 0 -> IT.op OP.lload_0 349 | 1 -> IT.op OP.lload_1 350 | 2 -> IT.op OP.lload_2 351 | 3 -> IT.op OP.lload_3 352 | _ -> gwide OP.lload n 353 | VFloat -> case n of 354 | 0 -> IT.op OP.fload_0 355 | 1 -> IT.op OP.fload_1 356 | 2 -> IT.op OP.fload_2 357 | 3 -> IT.op OP.fload_3 358 | _ -> gwide OP.fload n 359 | VDouble -> case n of 360 | 0 -> IT.op OP.dload_0 361 | 1 -> IT.op OP.dload_1 362 | 2 -> IT.op OP.dload_2 363 | 3 -> IT.op OP.dload_3 364 | _ -> gwide OP.dload n 365 | VObject _ -> case n of 366 | 0 -> IT.op OP.aload_0 367 | 1 -> IT.op OP.aload_1 368 | 2 -> IT.op OP.aload_2 369 | 3 -> IT.op OP.aload_3 370 | _ -> gwide OP.aload n 371 | _ -> error "gload: Wrong type of load!" 372 | cs = maybeToList $ getObjConst ft 373 | 374 | -- Generic store instruction 375 | gstore :: (Integral a) => FieldType -> a -> Code 376 | gstore ft n' = mkCode cs $ fold 377 | [ storeOp 378 | , IT.ctrlFlow 379 | $ CF.store n ft ] 380 | where n = fromIntegral n' :: Int 381 | storeOp = case CF.fieldTypeFlatVerifType ft of 382 | VInteger -> case n of 383 | 0 -> IT.op OP.istore_0 384 | 1 -> IT.op OP.istore_1 385 | 2 -> IT.op OP.istore_2 386 | 3 -> IT.op OP.istore_3 387 | _ -> gwide OP.istore n' 388 | VLong -> case n of 389 | 0 -> IT.op OP.lstore_0 390 | 1 -> IT.op OP.lstore_1 391 | 2 -> IT.op OP.lstore_2 392 | 3 -> IT.op OP.lstore_3 393 | _ -> gwide OP.lstore n' 394 | VFloat -> case n of 395 | 0 -> IT.op OP.fstore_0 396 | 1 -> IT.op OP.fstore_1 397 | 2 -> IT.op OP.fstore_2 398 | 3 -> IT.op OP.fstore_3 399 | _ -> gwide OP.fstore n' 400 | VDouble -> case n of 401 | 0 -> IT.op OP.dstore_0 402 | 1 -> IT.op OP.dstore_1 403 | 2 -> IT.op OP.dstore_2 404 | 3 -> IT.op OP.dstore_3 405 | _ -> gwide OP.dstore n' 406 | VObject _ -> case n of 407 | 0 -> IT.op OP.astore_0 408 | 1 -> IT.op OP.astore_1 409 | 2 -> IT.op OP.astore_2 410 | 3 -> IT.op OP.astore_3 411 | _ -> gwide OP.astore n' 412 | _ -> error "gstore: Wrong type of load!" 413 | cs = maybeToList $ getObjConst ft 414 | 415 | initCtrlFlow :: Bool -> [FieldType] -> Code 416 | initCtrlFlow isStatic args@(_:args') 417 | = mkCode cs $ IT.initCtrl 418 | . CF.mapLocals 419 | . const 420 | . CF.localsFromList 421 | $ fts 422 | where fts = if isStatic then args' else args 423 | cs = catMaybes $ map isClass fts 424 | isClass ft 425 | | VObject iclassName <- CF.fieldTypeFlatVerifType ft 426 | = Just (CClass iclassName) 427 | | otherwise = Nothing 428 | initCtrlFlow _ _ = error "initCtrlFlow: Must have at least one argument." 429 | 430 | -- Void return 431 | vreturn :: Code 432 | vreturn = mkCode' $ IT.returnInstr OP.vreturn 433 | 434 | -- Generic, non-void return 435 | greturn :: FieldType -> Code 436 | greturn ft = mkCode' $ fold 437 | [ IT.returnInstr returnOp 438 | , modifyStack $ CF.pop ft ] 439 | where returnOp = case CF.fieldTypeFlatVerifType ft of 440 | VInteger -> OP.ireturn 441 | VLong -> OP.lreturn 442 | VFloat -> OP.freturn 443 | VDouble -> OP.dreturn 444 | VObject _ -> OP.areturn 445 | _ -> error "greturn: Wrong type of return!" 446 | 447 | new :: FieldType -> Code 448 | new (ObjectType (IClassName className)) = mkCode cs $ 449 | IT.withOffset $ \offset -> fold 450 | [ IT.op OP.new 451 | , IT.ix c 452 | , modifyStack (CF.vpush (VUninitialized $ fromIntegral offset))] 453 | where c = CClass . IClassName $ className 454 | cs = CP.unpack c 455 | 456 | new ft@(ArrayType (BaseType bt)) = mkCode' $ fold 457 | [ IT.op OP.newarray 458 | , IT.bytes (BS.singleton atype) 459 | , modifyStack (CF.push ft . CF.pop jint) ] 460 | where atype = case bt of 461 | JBool -> 4 :: Word8 462 | JChar -> 5 463 | JFloat -> 6 464 | JDouble -> 7 465 | JByte -> 8 466 | JShort -> 9 467 | JInt -> 10 468 | JLong -> 11 469 | 470 | new ft@(ArrayType ftInner) = mkCode cs $ fold 471 | [ IT.op OP.anewarray 472 | , IT.ix c 473 | , modifyStack $ CF.push ft . CF.pop jint ] 474 | where c = fromJust $ getObjConst ftInner 475 | cs = CP.unpack c 476 | new (BaseType bt) = error $ "new: Cannot instantiate a primitive type: " ++ show bt 477 | new ft = error $ "new: Type not supported" ++ show ft 478 | 479 | aconst_null :: FieldType -> Code 480 | aconst_null ft = mkCode cs $ IT.op OP.aconst_null <> modifyStack (CF.push ft) 481 | where cs = maybeToList $ getObjConst ft 482 | 483 | iconst :: FieldType -> Int32 -> Code 484 | iconst ft i 485 | | i >= -1 && i <= 5 = mkCode' . (<> modifyStack (CF.push ft)) $ 486 | case i of 487 | -1 -> IT.op OP.iconst_m1 488 | 0 -> IT.op OP.iconst_0 489 | 1 -> IT.op OP.iconst_1 490 | 2 -> IT.op OP.iconst_2 491 | 3 -> IT.op OP.iconst_3 492 | 4 -> IT.op OP.iconst_4 493 | 5 -> IT.op OP.iconst_5 494 | _ -> error "iconst: -1 <= i <= 5 DEFAULT" 495 | | i >= -128 && i <= 127 = bipush ft $ fromIntegral i 496 | | i >= -32768 && i <= 32767 = sipush ft $ fromIntegral i 497 | | otherwise = gldc ft $ cint i 498 | 499 | constCode :: FieldType -> Opcode -> Code 500 | constCode ft opc = mkCode' $ IT.op opc <> modifyStack (CF.push ft) 501 | 502 | lconst :: Int64 -> Code 503 | lconst l 504 | | l == 0 = code OP.lconst_0 505 | | l == 1 = code OP.lconst_1 506 | | otherwise = gldc ft $ clong l 507 | where ft = jlong 508 | code = constCode ft 509 | 510 | fconst :: Float -> Code 511 | fconst f 512 | | f == 0.0 = code OP.fconst_0 513 | | f == 1.0 = code OP.fconst_1 514 | | f == 2.0 = code OP.fconst_2 515 | | otherwise = gldc ft $ cfloat f 516 | where ft = jfloat 517 | code = constCode ft 518 | 519 | dconst :: Double -> Code 520 | dconst d 521 | | d == 0.0 = code OP.dconst_0 522 | | d == 1.0 = code OP.dconst_1 523 | | otherwise = gldc ft $ cdouble d 524 | where ft = jdouble 525 | code = constCode ft 526 | 527 | sconst :: Text -> Code 528 | sconst = gldc jstring . cstring 529 | 530 | gldc :: FieldType -> Const -> Code 531 | gldc ft c = mkCode cs $ loadCode 532 | <> modifyStack (CF.push ft) 533 | where cs = CP.unpack c ++ maybeToList (getObjConst ft) 534 | category2 = isConstCategory2 c 535 | loadCode 536 | | category2 = IT.op OP.ldc2_w 537 | <> IT.ix c 538 | | otherwise = Instr $ do 539 | cp <- ask 540 | let index = CP.ix (CP.unsafeIndex "gldc" c cp) 541 | if index <= 255 then 542 | do IT.op' OP.ldc 543 | IT.writeBytes (BS.singleton $ fromIntegral index) 544 | else 545 | do IT.op' OP.ldc_w 546 | IT.writeBytes (packI16 $ fromIntegral index) 547 | 548 | gconv :: FieldType -> FieldType -> Code 549 | gconv ft1 ft2 550 | | Just opCode <- convOpcode 551 | = mkCode (cs ft2) $ opCode <> mod 552 | | otherwise = mempty 553 | where mod = modifyStack (CF.push ft2 . CF.pop ft1) 554 | convOpcode = case (ft1, ft2) of 555 | (BaseType bt1, BaseType bt2) -> 556 | case (bt1, bt2) of 557 | (JBool, JInt) -> Nothing 558 | (JByte, JInt) -> Nothing 559 | (JShort, JInt) -> Nothing 560 | (JChar, JInt) -> Nothing 561 | (JInt, JByte) -> Just $ IT.op OP.i2b 562 | (JInt, JShort) -> Just $ IT.op OP.i2s 563 | (JInt, JChar) -> Just $ IT.op OP.i2c 564 | (JInt, JBool) -> Nothing 565 | (JInt, JInt) -> Nothing 566 | (JInt, JLong) -> Just $ IT.op OP.i2l 567 | (JInt, JFloat) -> Just $ IT.op OP.i2f 568 | (JInt, JDouble) -> Just $ IT.op OP.i2d 569 | (JLong, JInt) -> Just $ IT.op OP.l2i 570 | (JLong, JFloat) -> Just $ IT.op OP.l2f 571 | (JLong, JDouble) -> Just $ IT.op OP.l2d 572 | (JLong, JLong) -> Nothing 573 | (JFloat, JDouble) -> Just $ IT.op OP.f2d 574 | (JFloat, JInt) -> Just $ IT.op OP.f2i 575 | (JFloat, JLong) -> Just $ IT.op OP.f2l 576 | (JFloat, JFloat) -> Nothing 577 | (JDouble, JLong) -> Just $ IT.op OP.d2l 578 | (JDouble, JInt) -> Just $ IT.op OP.d2i 579 | (JDouble, JFloat) -> Just $ IT.op OP.d2f 580 | (JDouble, JDouble) -> Nothing 581 | other -> error $ "Implement the other JVM primitive conversions. " 582 | ++ show other 583 | (ObjectType iclass', ft@(ObjectType iclass)) 584 | | ft == jobject || iclass' == iclass -> Nothing 585 | | otherwise -> Just $ checkCast iclass 586 | (ObjectType _, ArrayType _) -> Just $ checkCast arrayIClass 587 | (ArrayType ft, ArrayType ft') 588 | | ft == ft' -> Nothing 589 | | otherwise -> Just $ checkCast arrayIClass 590 | (ArrayType _, ft@(ObjectType iclass)) 591 | | ft == jobject -> Nothing 592 | | otherwise -> Just $ checkCast iclass 593 | other -> error $ "Cannot convert between primitive type and object type. " 594 | ++ show other 595 | cs (ObjectType iclass) = [cclass iclass] 596 | cs (ArrayType _) = [cclass arrayIClass] 597 | cs _ = [] 598 | arrayIClass = IClassName $ mkFieldDesc' ft2 599 | checkCast iclass = IT.op OP.checkcast 600 | <> IT.ix (cclass iclass) 601 | 602 | 603 | -- Heuristic taken from https://ghc.haskell.org/trac/ghc/ticket/9159 604 | gswitch :: Code -> [(Int, Code)] -> Maybe Code -> Code 605 | gswitch _ [] (Just deflt) = deflt 606 | gswitch _ [(_, code)] Nothing = code 607 | gswitch expr [(v, code)] (Just deflt) = expr <> bop code deflt 608 | where bop 609 | | v == 0 = ifeq 610 | | otherwise = \a b -> iconst jint (fromIntegral v) <> if_icmpeq a b 611 | 612 | gswitch expr [(v1, code1), (v2, code2)] Nothing = expr <> bop code1 code2 613 | where bop 614 | | v1 == 0 = ifeq 615 | | v2 == 0 = ifne 616 | | otherwise = \a b -> iconst jint (fromIntegral minV) <> opV a b 617 | minV = min v1 v2 618 | opV = if minV == v1 then if_icmpeq else if_icmpne 619 | 620 | gswitch expr branches maybeDefault = expr <> 621 | if nlabels > 0 && 622 | tableSpaceCost + 3 * tableTimeCost <= 623 | lookupSpaceCost + 3 * lookupTimeCost then 624 | tableswitch branchMap maybeDefault 625 | else 626 | lookupswitch branchMap maybeDefault 627 | where branchMap = IntMap.fromList branches 628 | nlabels = IntMap.size branchMap 629 | lo = fst . IntMap.findMin $ branchMap 630 | hi = fst . IntMap.findMax $ branchMap 631 | tableSpaceCost = 4 + (hi - lo + 1) 632 | tableTimeCost = 3 633 | lookupSpaceCost = 3 + 2 * nlabels 634 | lookupTimeCost = nlabels 635 | 636 | tableswitch :: IntMap Code -> Maybe Code -> Code 637 | tableswitch branchMap maybeDefault = 638 | mkCode cs $ IT.tableswitch (fmap instr branchMap) (fmap instr maybeDefault) 639 | where cs = maybe [] consts maybeDefault 640 | ++ concatMap consts (IntMap.elems branchMap) 641 | 642 | lookupswitch :: IntMap Code -> Maybe Code -> Code 643 | lookupswitch branchMap maybeDefault = 644 | mkCode cs $ IT.lookupswitch (fmap instr branchMap) (fmap instr maybeDefault) 645 | where cs = maybe [] consts maybeDefault 646 | ++ concatMap consts (IntMap.elems branchMap) 647 | 648 | startLabel :: Label -> Code 649 | startLabel label = mkCode' (IT.putLabel label) 650 | 651 | goto :: Label -> Code 652 | goto = mkCode' . IT.gotoLabel NotSpecial 653 | 654 | cgoto :: Label -> Code 655 | cgoto = mkCode' . IT.condGoto NotSpecial 656 | 657 | gaload :: FieldType -> Code 658 | gaload ft = mkCode cs $ fold 659 | [ IT.op loadOp 660 | , modifyStack ( CF.push ft 661 | . CF.pop (jarray ft) 662 | . CF.pop jint) ] 663 | where loadOp = case ft of 664 | BaseType bt -> 665 | case bt of 666 | JBool -> OP.baload 667 | JChar -> OP.caload 668 | JFloat -> OP.faload 669 | JDouble -> OP.daload 670 | JByte -> OP.baload 671 | JShort -> OP.saload 672 | JInt -> OP.iaload 673 | JLong -> OP.laload 674 | _ -> OP.aaload 675 | cs = maybeToList $ getObjConst ft 676 | 677 | gastore :: FieldType -> Code 678 | gastore ft = mkCode' $ 679 | IT.op storeOp 680 | <> modifyStack ( CF.pop (jarray ft) 681 | . CF.pop jint 682 | . CF.pop ft) 683 | where storeOp = case ft of 684 | BaseType bt -> 685 | case bt of 686 | JBool -> OP.bastore 687 | JChar -> OP.castore 688 | JFloat -> OP.fastore 689 | JDouble -> OP.dastore 690 | JByte -> OP.bastore 691 | JShort -> OP.sastore 692 | JInt -> OP.iastore 693 | JLong -> OP.lastore 694 | _ -> OP.aastore 695 | 696 | defaultValue :: FieldType -> Code 697 | defaultValue ft@(ObjectType _) = aconst_null ft 698 | defaultValue ft@(ArrayType _) = aconst_null ft 699 | defaultValue (BaseType bt) = 700 | case bt of 701 | JBool -> iconst jbool 0 702 | JChar -> iconst jchar 0 703 | JFloat -> fconst 0.0 704 | JDouble -> dconst 0.0 705 | JByte -> iconst jbyte 0 706 | JShort -> iconst jshort 0 707 | JInt -> iconst jint 0 708 | JLong -> lconst 0 709 | 710 | swap :: FieldType -> FieldType -> Code 711 | swap ft1 ft2 = 712 | mkCode' $ 713 | IT.op OP.swap 714 | <> modifyStack ( CF.push ft1 715 | . CF.push ft2 716 | . CF.pop ft1 717 | . CF.pop ft2) 718 | dup_x1 :: FieldType -> FieldType -> Code 719 | dup_x1 ft1 ft2 = 720 | mkCode' $ 721 | IT.op OP.dup_x1 722 | <> modifyStack ( CF.push ft2 723 | . CF.push ft1 724 | . CF.push ft2 725 | . CF.pop ft1 726 | . CF.pop ft2) 727 | 728 | dup_x2 :: FieldType -> FieldType -> FieldType -> Code 729 | dup_x2 ft1 ft2 ft3 = 730 | mkCode' $ 731 | IT.op OP.dup_x2 732 | <> modifyStack ( CF.push ft3 733 | . CF.push ft2 734 | . CF.push ft1 735 | . CF.push ft3 736 | . CF.pop ft1 737 | . CF.pop ft2 738 | . CF.pop ft3 ) 739 | 740 | markStackMap :: Code 741 | markStackMap = mkCode' IT.markStackMapFrame 742 | 743 | arraylength :: Code 744 | arraylength = 745 | mkCode' $ 746 | IT.op OP.arraylength 747 | <> modifyStack ( CF.push jint . CF.pop jobject ) 748 | 749 | emitLineNumber :: LineNumber -> Code 750 | emitLineNumber = mkCode' . IT.recordLineNumber 751 | 752 | monitorenter :: FieldType -> Code 753 | monitorenter ft = 754 | mkCode' $ 755 | IT.op OP.monitorenter 756 | <> modifyStack (CF.pop ft) 757 | 758 | monitorexit :: FieldType -> Code 759 | monitorexit ft = 760 | mkCode' $ 761 | IT.op OP.monitorexit 762 | <> modifyStack (CF.pop ft) 763 | 764 | tryFinally :: Int -> Code -> Code -> Code 765 | tryFinally loc tryCode finallyCode = mkCode cs $ 766 | IT.tryFinally ( instr storeCode 767 | , instr loadCode 768 | , instr throwCode ) 769 | (instr tryCode) 770 | (instr finallyCode) 771 | where cs = concat $ map consts 772 | [tryCode, finallyCode, storeCode, loadCode, throwCode] 773 | storeCode = gstore IT.jthrowable loc 774 | loadCode = gload IT.jthrowable loc 775 | throwCode = gthrow IT.jthrowable 776 | 777 | synchronized :: Int -> Int -> FieldType -> Code -> Code -> Code 778 | synchronized exLoc monLoc monFt loadObjCode syncCode = mkCode cs $ 779 | IT.synchronized ( instr storeCode 780 | , instr loadCode 781 | , instr throwCode 782 | , instr monEnterCode 783 | , instr monExitCode 784 | ) 785 | (instr syncCode) 786 | where cs = concat $ map consts 787 | [storeCode, loadCode, throwCode, monEnterCode, monExitCode, syncCode] 788 | storeCode = gstore IT.jthrowable exLoc 789 | loadCode = gload IT.jthrowable exLoc 790 | throwCode = gthrow IT.jthrowable 791 | monEnterCode = loadObjCode 792 | <> dup monFt 793 | <> gstore monFt monLoc 794 | <> monitorenter monFt 795 | monExitCode = gload monFt monLoc <> monitorexit monFt 796 | -------------------------------------------------------------------------------- /src/Codec/JVM/ASM/Code/CtrlFlow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, OverloadedStrings #-} 2 | module Codec.JVM.ASM.Code.CtrlFlow where 3 | 4 | import Codec.JVM.Const 5 | import Codec.JVM.ConstPool 6 | import Codec.JVM.Types 7 | import Codec.JVM.Internal 8 | 9 | import Data.Word (Word16) 10 | import Data.List (foldl') 11 | import Data.IntMap.Strict (IntMap) 12 | import qualified Data.IntMap.Strict as IntMap 13 | import qualified Data.Text as T 14 | 15 | data CtrlFlow = CtrlFlow 16 | { stack :: !Stack 17 | , locals :: !Locals } 18 | deriving (Eq, Show) 19 | 20 | data Locals = Locals 21 | { localsMap :: !(IntMap VerifType) 22 | , localsSize :: !Int 23 | , localsMax :: !Int } 24 | deriving (Eq, Show) 25 | 26 | getThis :: Locals -> String 27 | getThis = (\x -> case x of 28 | VObject (IClassName i) -> T.unpack i 29 | _ -> "") 30 | . IntMap.findWithDefault (VObject (IClassName "")) 0 . localsMap 31 | 32 | localsFromList :: [FieldType] -> Locals 33 | localsFromList fts = Locals mp sz sz 34 | where vts = concatMap (reverse . fieldTypeToVerifType) fts 35 | kvs = zip [0..] vts 36 | mp = IntMap.fromList kvs 37 | sz = length vts 38 | 39 | -- Should only be used on non-empty 40 | computeNumLocals :: IntMap VerifType -> Int 41 | computeNumLocals = (+1) . fst . IntMap.findMax 42 | 43 | localVts :: Locals -> [VerifType] 44 | localVts (Locals mp _ _) = IntMap.elems mp 45 | 46 | -- TODO: Check if verif types are in the right order 47 | insert :: (Integral a) => a -> FieldType -> Locals -> Locals 48 | insert n' ft (Locals mp _ mx) = Locals mp' sz' mx' 49 | where n = fromIntegral n' 50 | vts = zip [n, n+1] (reverse . fieldTypeToVerifType $ ft) 51 | mp' = IntMap.union (IntMap.fromList vts) mp 52 | sz' = computeNumLocals mp' 53 | mx' = max mx sz' 54 | 55 | remove :: (Integral a) => a -> FieldType -> Locals -> Locals 56 | remove n' ft (Locals mp _ mx) = Locals mp' sz' mx 57 | where n = fromIntegral n' 58 | delta = fieldSize ft 59 | deletes = map IntMap.delete (take delta [n, n+1]) 60 | mp' = foldl' (flip ($)) mp deletes 61 | sz' = computeNumLocals mp' 62 | 63 | areLocalsSame :: Locals -> Locals -> Bool 64 | areLocalsSame locals1 locals2 = locals1 == locals2 65 | 66 | empty :: CtrlFlow 67 | empty = CtrlFlow (Stack mempty 0 0) (Locals mempty 0 0) 68 | 69 | equiv :: CtrlFlow -> CtrlFlow -> Bool 70 | equiv cf0 cf1 = (locals cf0 == locals cf1) 71 | && stackVal (stack cf0) == stackVal (stack cf1) 72 | 73 | mapStack :: (Stack -> Stack) -> CtrlFlow -> CtrlFlow 74 | mapStack f cf = cf { stack = f $ stack cf } 75 | 76 | mapLocals :: (Locals -> Locals) -> CtrlFlow -> CtrlFlow 77 | mapLocals f cf = cf { locals = f $ locals cf } 78 | 79 | maxStack :: CtrlFlow -> Int 80 | maxStack = stackMax . stack 81 | 82 | maxLocals :: CtrlFlow -> Int 83 | maxLocals = localsMax . locals 84 | 85 | normaliseLocals :: Locals -> Locals 86 | normaliseLocals (Locals mp sz mx) = Locals mp' sz mx 87 | where missingLocals = filter (`IntMap.notMember` mp) [0..(sz-1)] 88 | mp' = foldl' (\locals key -> IntMap.insert key VTop locals) mp missingLocals 89 | 90 | load :: (Integral a) => a -> FieldType -> CtrlFlow -> CtrlFlow 91 | load n ft cf@CtrlFlow {..} = 92 | cf { locals = insert n ft locals 93 | , stack = push ft stack } 94 | 95 | store :: (Integral a) => a -> FieldType -> CtrlFlow -> CtrlFlow 96 | store n ft cf@CtrlFlow {..} = 97 | cf { locals = insert n ft locals 98 | , stack = pop ft stack } 99 | 100 | data Stack = Stack 101 | { stackVal :: ![VerifType] 102 | , stackMax :: !Int 103 | , stackSize :: !Int } 104 | deriving (Eq, Show) 105 | 106 | push :: FieldType -> Stack -> Stack 107 | push ft (Stack xs m sz) = Stack (vts ++ xs) m' sz' 108 | where vts = fieldTypeToVerifType ft 109 | dsz = length vts 110 | sz' = dsz + sz 111 | m' = max m sz' 112 | 113 | vpush :: VerifType -> Stack -> Stack 114 | vpush vt (Stack xs m sz) = Stack (vt:xs) m' sz' 115 | where sz' = 1 + sz 116 | m' = max m sz' 117 | 118 | pop :: FieldType -> Stack -> Stack 119 | pop ft = pop' $ fieldSize ft 120 | 121 | pop' :: Int -> Stack -> Stack 122 | pop' s (Stack xs m sz) = Stack (drop s xs) m (sz - s) 123 | 124 | data VerifType 125 | = VTop 126 | | VInteger 127 | | VFloat 128 | | VDouble 129 | | VLong 130 | | VNull 131 | | VUninitializedThis 132 | | VObject IClassName 133 | | VUninitialized Word16 134 | deriving (Eq, Show) 135 | 136 | fieldTypeFlatVerifType :: FieldType -> VerifType 137 | fieldTypeFlatVerifType ft = case ft of 138 | BaseType JBool -> VInteger 139 | BaseType JByte -> VInteger 140 | BaseType JChar -> VInteger 141 | BaseType JShort -> VInteger 142 | BaseType JInt -> VInteger 143 | BaseType JLong -> VLong 144 | BaseType JFloat -> VFloat 145 | BaseType JDouble -> VDouble 146 | ObjectType cn -> VObject cn 147 | ArrayType _ -> VObject . IClassName $ mkFieldDesc' ft 148 | 149 | fieldTypeToVerifType :: FieldType -> [VerifType] 150 | fieldTypeToVerifType ft = case ft of 151 | BaseType JBool -> [VInteger] 152 | BaseType JByte -> [VInteger] 153 | BaseType JChar -> [VInteger] 154 | BaseType JShort -> [VInteger] 155 | BaseType JInt -> [VInteger] 156 | BaseType JLong -> [VTop, VLong] 157 | BaseType JFloat -> [VFloat] 158 | BaseType JDouble -> [VTop, VDouble] 159 | ObjectType cn -> [VObject cn] 160 | ArrayType _ -> [VObject . IClassName $ mkFieldDesc' ft] 161 | 162 | putVerifType :: String -> ConstPool -> VerifType -> Put 163 | putVerifType debug cp vt = 164 | case vt of 165 | VTop -> putWord8 0 166 | VInteger -> putWord8 1 167 | VFloat -> putWord8 2 168 | VDouble -> putWord8 3 169 | VLong -> putWord8 4 170 | VNull -> putWord8 5 171 | VUninitializedThis -> putWord8 6 172 | VObject icn -> do 173 | putWord8 7 174 | putIx ("putVerifType[VObject][" ++ debug ++ "]") cp $ CClass icn 175 | VUninitialized offset -> do 176 | putWord8 8 177 | putWord16be offset 178 | 179 | compressCtrlFlow :: CtrlFlow -> ([VerifType], [VerifType]) 180 | compressCtrlFlow CtrlFlow {..} = ( compress . localVts $ locals 181 | , compress . reverse . stackVal $ stack) 182 | 183 | compress :: [VerifType] -> [VerifType] 184 | compress [] = [] 185 | compress (VLong:_:xs) = VLong : compress xs 186 | compress (VDouble:_:xs) = VDouble : compress xs 187 | compress (x:xs) = x : compress xs 188 | 189 | merge :: CtrlFlow -> [CtrlFlow] -> CtrlFlow 190 | merge cf cfs = CtrlFlow stack' locals' 191 | where (smx', lmx') = foldl' (\(smx, lmx) cf' -> 192 | ( max smx (maxStack cf') 193 | , max lmx (maxLocals cf'))) 194 | ( maxStack cf 195 | , maxLocals cf ) 196 | cfs 197 | mergedStack = case cfs of 198 | (s:_) -> stack s 199 | _ -> stack cf 200 | stack' = mergedStack { stackMax = smx' } 201 | locals' = (locals cf) { localsMax = lmx' } 202 | -------------------------------------------------------------------------------- /src/Codec/JVM/ASM/Code/Instr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP, UnboxedTuples, RecordWildCards, MultiParamTypeClasses, FlexibleContexts, NamedFieldPuns, MagicHash, OverloadedStrings #-} 2 | module Codec.JVM.ASM.Code.Instr where 3 | 4 | import Control.Monad.IO.Class 5 | import Control.Monad.State 6 | import Control.Monad.Reader 7 | import Data.ByteString (ByteString) 8 | import Data.Monoid ((<>)) 9 | import Data.Text (Text) 10 | import Data.Maybe(fromMaybe) 11 | import Data.List(sortBy) 12 | import Data.Int(Int32) 13 | import Data.Ord(comparing) 14 | import GHC.Base 15 | 16 | import qualified Data.ByteString as BS 17 | import qualified Data.IntMap.Strict as IntMap 18 | 19 | import Codec.JVM.ASM.Code.CtrlFlow (CtrlFlow, Stack, VerifType(..), Stack(..)) 20 | import Codec.JVM.ASM.Code.Types 21 | import Codec.JVM.Const (Const(..)) 22 | import Codec.JVM.Internal (packI16, packI32) 23 | import Codec.JVM.Opcode (Opcode, opcode) 24 | import Codec.JVM.ConstPool (ConstPool) 25 | import Codec.JVM.Types 26 | import qualified Codec.JVM.Types as T 27 | 28 | import qualified Codec.JVM.ASM.Code.CtrlFlow as CF 29 | import qualified Codec.JVM.ConstPool as CP 30 | import qualified Codec.JVM.Opcode as OP 31 | 32 | data InstrState = 33 | InstrState { isByteCode :: !ByteString 34 | , isStackMapTable :: StackMapTable 35 | , isOffset :: !Offset 36 | , isCtrlFlow :: CtrlFlow 37 | , isLabelTable :: LabelTable 38 | , isLastBranch :: LastBranch 39 | , isRunAgain :: Bool 40 | , isNextLabel :: Int 41 | , isLineNumberTable :: LineNumberTable 42 | , isExceptionTable :: ExceptionTable } 43 | 44 | newtype InstrM a = InstrM { runInstrM :: ConstPool -> InstrState -> (# a, InstrState #) } 45 | 46 | newtype Instr = Instr { unInstr :: InstrM () } 47 | 48 | instance Functor InstrM where 49 | fmap = liftM 50 | 51 | instance Applicative InstrM where 52 | pure = return 53 | (<*>) = ap 54 | 55 | instance Monad InstrM where 56 | return x = InstrM $ \_ s -> (# x, s #) 57 | (InstrM m) >>= f = 58 | InstrM $ \e s -> 59 | case m e s of 60 | (# x, s' #) -> 61 | case runInstrM (f x) e s' of 62 | (# x', s'' #) -> (# x', s'' #) 63 | 64 | instance MonadIO InstrM where 65 | liftIO (IO io) = InstrM $ \_ s -> 66 | case io realWorld# of 67 | (# _, a #) -> (# a, s #) 68 | 69 | instance MonadState InstrState InstrM where 70 | get = InstrM $ \_ s -> (# s, s #) 71 | put s' = InstrM $ \_ _ -> (# (), s' #) 72 | 73 | instance MonadReader ConstPool InstrM where 74 | ask = InstrM $ \e s -> (# e, s #) 75 | local f (InstrM m) = InstrM $ \e s -> m (f e) s 76 | 77 | instance Monoid Instr where 78 | mempty = Instr $ return () 79 | mappend (Instr rws0) (Instr rws1) = Instr $ do 80 | rws0 81 | rws1 82 | 83 | #if MIN_VERSION_base(4,10,0) 84 | instance Semigroup Instr where 85 | (<>) (Instr rws0) (Instr rws1) = Instr $ do 86 | rws0 87 | rws1 88 | #endif 89 | 90 | instance Show Instr where 91 | show _ = "Instructions" 92 | 93 | withOffset :: (Int -> Instr) -> Instr 94 | withOffset f = Instr $ do 95 | InstrState { isOffset = Offset offset } <- get 96 | unInstr $ f offset 97 | 98 | emptyInstrState :: InstrState 99 | emptyInstrState = 100 | InstrState { isByteCode = mempty 101 | , isStackMapTable = mempty 102 | , isOffset = 0 103 | , isCtrlFlow = CF.empty 104 | , isLabelTable = mempty 105 | , isLastBranch = NoBranch 106 | , isRunAgain = False 107 | , isNextLabel = 1 108 | , isLineNumberTable = mempty 109 | , isExceptionTable = mempty } 110 | 111 | getBCS :: InstrState -> (ByteString, CtrlFlow, StackMapTable) 112 | getBCS InstrState{..} = (isByteCode, isCtrlFlow, isStackMapTable) 113 | 114 | getBCSL :: InstrState -> (ByteString, CtrlFlow, StackMapTable, LineNumberTable) 115 | getBCSL InstrState{..} = (isByteCode, isCtrlFlow, isStackMapTable, isLineNumberTable) 116 | 117 | getBCSLE :: InstrState -> (ByteString, CtrlFlow, StackMapTable, LineNumberTable, 118 | [ExceptionTableEntry]) 119 | getBCSLE InstrState{..} = 120 | (isByteCode, isCtrlFlow, isStackMapTable, isLineNumberTable, 121 | toETEs isExceptionTable isLabelTable) 122 | 123 | runInstr :: Instr -> ConstPool -> InstrState 124 | runInstr instr cp = multiPass 0 emptyInstrState { isRunAgain = True } 125 | where multiPass :: Int -> InstrState -> InstrState 126 | multiPass n s@InstrState { isRunAgain, isLabelTable = lt } 127 | | isRunAgain = 128 | case runInstr' instr cp $ emptyInstrState { isLabelTable = lt } of 129 | s' -> multiPass (n + 1) s' 130 | | otherwise = s 131 | 132 | runInstrBCS :: Instr -> ConstPool -> (ByteString, CtrlFlow, StackMapTable) 133 | runInstrBCS instr cp = getBCS $ runInstr instr cp 134 | 135 | runInstrBCSL :: Instr -> ConstPool -> (ByteString, CtrlFlow, StackMapTable, LineNumberTable) 136 | runInstrBCSL instr cp = getBCSL $ runInstr instr cp 137 | 138 | runInstrBCSLE :: Instr -> ConstPool -> (ByteString, CtrlFlow, StackMapTable, LineNumberTable, [ExceptionTableEntry]) 139 | runInstrBCSLE instr cp = getBCSLE $ runInstr instr cp 140 | 141 | runInstr' :: Instr -> ConstPool -> InstrState -> InstrState 142 | runInstr' (Instr m) e s = case runInstrM m e s of (# _, s' #) -> s' 143 | 144 | runInstrBCS' :: Instr -> ConstPool -> InstrState -> (ByteString, CtrlFlow, StackMapTable) 145 | runInstrBCS' instr e s = getBCS $ runInstr' instr e s 146 | 147 | runInstrBCSL' :: Instr -> ConstPool -> InstrState -> 148 | (ByteString, CtrlFlow, StackMapTable, LineNumberTable) 149 | runInstrBCSL' instr e s = getBCSL $ runInstr' instr e s 150 | 151 | recordBranch :: BranchType -> InstrM () 152 | recordBranch bt = do 153 | off <- getOffset 154 | modify' $ \s -> s { isLastBranch = HasBranch bt (Offset off) } 155 | 156 | saveLastBranch :: InstrM LastBranch 157 | saveLastBranch = do 158 | InstrState { isLastBranch = lb } <- get 159 | modify' $ \s -> s { isLastBranch = NoBranch } 160 | return lb 161 | 162 | resetLastBranch :: LastBranch -> InstrM () 163 | resetLastBranch lb = modify' $ \s -> s { isLastBranch = lb } 164 | 165 | recordLineNumber' :: LineNumber -> InstrM () 166 | recordLineNumber' ln = do 167 | off <- getOffset 168 | modify' $ \s@InstrState { isLineNumberTable = lnt } -> 169 | s { isLineNumberTable = insertLNT (Offset off) ln lnt } 170 | 171 | recordLineNumber :: LineNumber -> Instr 172 | recordLineNumber = Instr . recordLineNumber' 173 | 174 | gotoInstr :: Special -> InstrM () 175 | gotoInstr = gotoInstrSpec OP.goto 176 | 177 | gotoWInstr :: Special -> InstrM () 178 | gotoWInstr = gotoInstrSpec OP.goto_w 179 | 180 | gotoInstrSpec :: Opcode -> Special -> InstrM () 181 | gotoInstrSpec opc special = do 182 | when (special == NotSpecial) $ 183 | recordBranch (if opc == OP.goto_w then GotoW else Goto) 184 | op' opc 185 | 186 | gotoInstrGen :: Special -> Int -> InstrM () 187 | gotoInstrGen special offset 188 | | offset >= 0 && offset <= 3 = return () 189 | | outsideGotoRange offset = do 190 | gotoWInstr special 191 | writeBytes . packI32 $ offset 192 | | otherwise = do 193 | gotoInstr special 194 | writeBytes . packI16 $ offset 195 | 196 | returnInstr :: Opcode -> Instr 197 | returnInstr opc = Instr $ do 198 | recordBranch Return 199 | op' opc 200 | 201 | modifyStack' :: (Stack -> Stack) -> InstrM () 202 | modifyStack' f = ctrlFlow' $ CF.mapStack f 203 | 204 | modifyStack :: (Stack -> Stack) -> Instr 205 | modifyStack = Instr . modifyStack' 206 | 207 | -- TODO: 208 | -- Account for Instr & Instr being empty 209 | -- Account for jumpoffset being > 2^15 - 1 210 | gbranch :: (FieldType -> Stack -> Stack) 211 | -> FieldType -> Opcode -> Instr -> Instr -> Instr 212 | gbranch f ft oc ok ko = Instr $ do 213 | [defaultLabel, okLabel] <- mkSystemLabels 2 214 | jumpOffset <- offsetToLabel okLabel 215 | lb <- saveLastBranch 216 | unInstr ifop 217 | InstrState { isCtrlFlow = cf 218 | , isLabelTable = lt } <- get 219 | writeBytes . packI16 $ jumpOffset 220 | (koCF, koLT, mkoLB) <- withCFState cf lt $ unInstr $ 221 | ko <> condGoto Special defaultLabel 222 | (okCF, okLT, mokLB) <- withCFState cf lt $ unInstr $ 223 | putLabel okLabel <> ok 224 | putCtrlFlow' $ CF.merge cf [okCF, koCF] 225 | mergeLabels [koLT, okLT] 226 | unInstr $ putLabel defaultLabel 227 | resetLastBranch $ fromMaybe lb (selectLatestLB mkoLB mokLB) 228 | where ifop = op oc <> modifyStack (f ft) 229 | 230 | bytes :: ByteString -> Instr 231 | bytes = Instr . writeBytes 232 | 233 | ix :: Const -> Instr 234 | ix c = Instr $ do 235 | cp <- ask 236 | writeBytes . packI16 $ CP.ix $ CP.unsafeIndex "ix" c cp 237 | 238 | op :: Opcode -> Instr 239 | op = Instr . op' 240 | 241 | op' :: Opcode -> InstrM () 242 | op' = writeBytes . BS.singleton . opcode 243 | 244 | ctrlFlow' :: (CtrlFlow -> CtrlFlow) -> InstrM () 245 | ctrlFlow' f = modify' $ \s@InstrState { isCtrlFlow = cf } -> s { isCtrlFlow = f cf } 246 | 247 | ctrlFlow :: (CtrlFlow -> CtrlFlow) -> Instr 248 | ctrlFlow = Instr . ctrlFlow' 249 | 250 | withStack :: ([VerifType] -> [VerifType]) -> Instr 251 | withStack f = modifyStack (\s -> let stack' = f (stackVal s) 252 | stackSize' = length stack' 253 | in s { stackVal = stack' 254 | , stackMax = max (stackMax s) stackSize' 255 | , stackSize = stackSize' }) 256 | 257 | initCtrl :: (CtrlFlow -> CtrlFlow) -> Instr 258 | initCtrl f = Instr $ do 259 | unInstr $ ctrlFlow f 260 | modify' $ \s@InstrState { isCtrlFlow = cf 261 | , isStackMapTable = smt } -> 262 | s { isStackMapTable = insertSMT (-1) cf smt } 263 | -- NOTE: The (-1) is done as a special case for when a stack map frame has to 264 | -- be generated for offset 0. 265 | 266 | putCtrlFlow :: CtrlFlow -> Instr 267 | putCtrlFlow = Instr . putCtrlFlow' 268 | 269 | putCtrlFlow' :: CtrlFlow -> InstrM () 270 | putCtrlFlow' = ctrlFlow' . const 271 | 272 | withCFState :: CtrlFlow -> LabelTable -> InstrM () -> InstrM (CtrlFlow, LabelTable, Maybe LastBranch) 273 | withCFState cf lt instr = do 274 | InstrState { isCtrlFlow = cf', isLabelTable = lt' } <- get 275 | modify' $ \s -> s { isCtrlFlow = cf, isLabelTable = lt } 276 | instr 277 | s' <- get 278 | modify' $ \s -> s { isCtrlFlow = cf', isLabelTable = lt' } 279 | let mLastBranch 280 | | ifLastBranch (isOffset s') lb = Just lb 281 | | otherwise = Nothing 282 | where lb = isLastBranch s' 283 | return (isCtrlFlow s', isLabelTable s', mLastBranch) 284 | 285 | incOffset :: Int -> Instr 286 | incOffset = Instr . incOffset' 287 | 288 | incOffset' :: Int -> InstrM () 289 | incOffset' i = 290 | modify' $ \s@InstrState { isOffset = Offset off } -> 291 | s { isOffset = Offset $ off + i} 292 | 293 | write :: ByteString -> StackMapTable -> InstrM () 294 | write bs smfs = do 295 | incOffset' $ BS.length bs 296 | modify' $ \s@InstrState { isByteCode = bs' 297 | , isStackMapTable = smfs' } -> 298 | s { isByteCode = bs' <> bs 299 | , isStackMapTable = smfs' <> smfs } 300 | 301 | writeBytes :: ByteString -> InstrM () 302 | writeBytes bs = write bs mempty 303 | 304 | markStackMapFrame :: Instr 305 | markStackMapFrame = Instr writeStackMapFrame 306 | 307 | writeStackMapFrame :: InstrM () 308 | writeStackMapFrame = do 309 | modify' $ \s@InstrState { isOffset = Offset offset 310 | , isCtrlFlow = cf 311 | , isStackMapTable = smt } -> 312 | s { isStackMapTable = insertSMT offset cf smt } 313 | 314 | getOffset :: InstrM Int 315 | getOffset = do 316 | Offset offset <- gets isOffset 317 | return offset 318 | 319 | addExceptionHandler :: Label -> Label -> Label -> Maybe FieldType -> InstrM () 320 | addExceptionHandler start end handler mft = do 321 | let f (Just (ObjectType (IClassName text))) = Just text 322 | f _ = Nothing 323 | modify' $ \s@InstrState { isExceptionTable = et } -> 324 | s { isExceptionTable = insertIntoET start end handler (f mft) et } 325 | 326 | type BranchMap = IntMap.IntMap Instr 327 | 328 | toInt32AscList :: IntMap.IntMap a -> [(Int, a)] 329 | toInt32AscList = sortBy (comparing ((fromIntegral :: Int -> Int32) . fst)) . IntMap.toAscList 330 | 331 | tableswitch :: BranchMap -> Maybe Instr -> Instr 332 | tableswitch = switches OP.tableswitch header 333 | where header ~(defaultLabel:_:labels) branchMap relOffsetToLabel = do 334 | debug $ liftIO $ print ("tableswitch", branchMap, low, high) 335 | writeI32 low 336 | writeI32 high 337 | go labels [low..high] 338 | where go ls@(l:ls') (x:xs) 339 | | IntMap.member x branchMap = do 340 | relOffsetToLabel l >>= writeI32 341 | go ls' xs 342 | | otherwise = do 343 | relOffsetToLabel defaultLabel >>= writeI32 344 | go ls xs 345 | go _ _ = return () 346 | low = fst . IntMap.findMin $ branchMap 347 | high = fst . IntMap.findMax $ branchMap 348 | 349 | lookupswitch :: BranchMap -> Maybe Instr -> Instr 350 | lookupswitch = switches OP.lookupswitch header 351 | where header ~(_:_:labels) branchMap relOffsetToLabel = do 352 | writeI32 (IntMap.size branchMap) 353 | let keys = map fst $ toInt32AscList branchMap 354 | forM_ (zip keys labels) $ \(int, l) -> do 355 | writeI32 int 356 | relOffsetToLabel l >>= writeI32 357 | 358 | switches :: Opcode -> ([Label] -> BranchMap -> (Label -> InstrM Int) -> InstrM ()) 359 | -> BranchMap -> Maybe Instr -> Instr 360 | switches opc f branchMap deflt = Instr $ do 361 | baseOffset <- getOffset 362 | lb <- saveLastBranch 363 | unInstr $ op opc 364 | modifyStack' $ CF.pop jint 365 | InstrState { isOffset = offset 366 | , isCtrlFlow = cf 367 | , isLabelTable = lt } <- get 368 | -- Align to 4-byte boundary 369 | let padding = (4 - (offset `mod` 4)) `mod` 4 370 | numBranches = IntMap.size branchMap 371 | branchList = map snd $ toInt32AscList branchMap 372 | writeBytes . BS.pack . replicate (fromIntegral padding) $ 0 373 | ls@(defaultLabel:breakLabel:labels) <- mkSystemLabels (1 + 1 + numBranches) 374 | let relOffsetToLabel = offsetToLabel' (Offset baseOffset) 375 | relOffsetToLabel defaultLabel >>= writeI32 376 | f ls branchMap relOffsetToLabel 377 | let branches = (defaultLabel, fromMaybe mempty deflt) 378 | : zip labels branchList 379 | cfsAndLtsAndLbs <- forM branches $ \(l, i) -> 380 | withCFState cf lt $ unInstr $ 381 | putLabel l <> i <> condGoto Special breakLabel 382 | let (cfs, lts, mlbs) = unzip3 cfsAndLtsAndLbs 383 | putCtrlFlow' $ CF.merge cf cfs 384 | mergeLabels lts 385 | unInstr $ putLabel breakLabel 386 | resetLastBranch $ fromMaybe lb (selectLatestLBs mlbs) 387 | 388 | lookupLabel :: Label -> InstrM Offset 389 | lookupLabel l = do 390 | InstrState { isLabelTable = lt } <- get 391 | return $ lookupLT l lt 392 | 393 | mergeLabels :: [LabelTable] -> InstrM () 394 | mergeLabels tables = do 395 | debug $ do 396 | InstrState { isLabelTable = table } <- get 397 | liftIO $ print ("mergeLabels", map (`differenceLT` table) tables) 398 | modify' $ \s@InstrState { isLabelTable = table 399 | , isRunAgain = ra } -> 400 | let diffTables = map (`differenceLT` table) tables 401 | updates = any (\m -> sizeLT m > 0) diffTables 402 | in s { isLabelTable = unionsLT (table : diffTables) 403 | , isRunAgain = updateRunAgain ra updates } 404 | 405 | gotoLabel :: Special -> Label -> Instr 406 | gotoLabel special label = Instr $ offsetToLabel label >>= gotoInstrGen special 407 | 408 | condGoto :: Special -> Label -> Instr 409 | condGoto special l = Instr $ do 410 | InstrState { isLastBranch, isOffset } <- get 411 | unless (ifLastBranch isOffset isLastBranch) $ 412 | unInstr (gotoLabel special l) 413 | 414 | putLabel' :: Label -> Instr 415 | putLabel' l = Instr $ do 416 | debug $ do 417 | offset <- getOffset 418 | liftIO $ print ("putLabel'", l, offset) 419 | modify' $ \s@InstrState { isLabelTable = lt 420 | , isRunAgain = ra 421 | , isOffset = off } -> 422 | s { isLabelTable = insertLT l off lt 423 | , isRunAgain = updateRunAgain ra (isDifferentLT l off lt) } 424 | 425 | putLabel :: Label -> Instr 426 | putLabel l = Instr $ do 427 | unInstr (putLabel' l) 428 | writeStackMapFrame 429 | 430 | offsetToLabel :: Label -> InstrM Int 431 | offsetToLabel label = do 432 | offset <- getOffset 433 | offsetToLabel' (Offset offset) label 434 | 435 | offsetToLabel' :: Offset -> Label -> InstrM Int 436 | offsetToLabel' (Offset offset) label = do 437 | Offset labelOffset <- lookupLabel label 438 | debug $ 439 | liftIO $ print ("offsetToLabel'", label, labelOffset, 440 | offset, labelOffset - offset) 441 | return $ labelOffset - offset 442 | 443 | ifLastBranch :: Offset -> LastBranch -> Bool 444 | ifLastBranch _ NoBranch = False 445 | ifLastBranch offset (HasBranch bt off) = off == (offset - branchSize bt) 446 | 447 | selectLatestLB :: Maybe LastBranch -> Maybe LastBranch -> Maybe LastBranch 448 | selectLatestLB (Just _) b@(Just _) = b 449 | selectLatestLB _ _ = Nothing 450 | 451 | selectLatestLBs :: [Maybe LastBranch] -> Maybe LastBranch 452 | selectLatestLBs = foldl1 selectLatestLB 453 | 454 | outsideGotoRange :: Int -> Bool 455 | outsideGotoRange offset = offset > 32767 || offset < -32768 456 | 457 | mkSystemLabels :: Int -> InstrM [Label] 458 | mkSystemLabels n = do 459 | s@InstrState { isNextLabel }<- get 460 | put s { isNextLabel = isNextLabel + n } 461 | return $ map (\x -> Label (- (isNextLabel + x))) [0..(n - 1)] 462 | 463 | writeI16, writeI32 :: Int -> InstrM () 464 | writeI32 = writeBytes . packI32 465 | writeI16 = writeBytes . packI16 466 | 467 | -- For debugging purposes 468 | whenClass :: String -> InstrM () -> InstrM () 469 | whenClass cls m = do 470 | InstrState { isCtrlFlow } <- get 471 | when (CF.getThis (CF.locals isCtrlFlow) == cls) m 472 | 473 | debug :: InstrM () -> InstrM () 474 | debug = const (return ()) 475 | 476 | updateRunAgain :: Bool -> Bool -> Bool 477 | updateRunAgain = (||) 478 | 479 | toETEs :: ExceptionTable -> LabelTable -> [ExceptionTableEntry] 480 | toETEs et lt = 481 | map (\(start, end, handler, const) -> 482 | ExceptionTableEntry { eteStartPc = unOffset $ lookupLT start lt 483 | , eteEndPc = unOffset $ lookupLT end lt 484 | , eteHandlerPc = unOffset $ lookupLT handler lt 485 | , eteCatchType = fmap (CClass . IClassName) const }) 486 | $ toListET et 487 | 488 | data ExceptionTableEntry 489 | = ExceptionTableEntry { eteStartPc :: Int 490 | , eteEndPc :: Int 491 | , eteHandlerPc :: Int 492 | , eteCatchType :: Maybe Const -- Must be CClass 493 | } 494 | 495 | tryFinally :: (Instr, Instr, Instr) -> Instr -> Instr -> Instr 496 | tryFinally (storeCode, loadCode, throwCode) tryCode finallyCode = Instr $ do 497 | [startLabel, endLabel, finallyLabel, defaultLabel] <- mkSystemLabels 4 498 | lb <- saveLastBranch 499 | InstrState { isCtrlFlow = cf 500 | , isLabelTable = lt } <- get 501 | (tryCF, tryLT, mtryLB) <- withCFState cf lt $ unInstr $ 502 | putLabel' startLabel 503 | <> tryCode 504 | <> putLabel' endLabel 505 | <> finallyCode 506 | <> condGoto Special defaultLabel 507 | (finallyCF, finallyLT, mfinallyLB) <- withCFState cf lt $ unInstr $ 508 | ctrlFlow (CF.mapStack (CF.push jthrowable)) 509 | <> putLabel finallyLabel 510 | <> storeCode 511 | <> finallyCode 512 | <> loadCode 513 | <> throwCode 514 | addExceptionHandler startLabel endLabel finallyLabel Nothing 515 | putCtrlFlow' $ CF.merge cf [tryCF, finallyCF] 516 | mergeLabels [tryLT, finallyLT] 517 | unInstr $ putLabel defaultLabel 518 | resetLastBranch $ fromMaybe lb (selectLatestLB mtryLB mfinallyLB) 519 | 520 | synchronized :: (Instr, Instr, Instr, Instr, Instr) -> Instr -> Instr 521 | synchronized (storeCode, loadCode, throwCode, monEnter, monExit) syncCode = Instr $ do 522 | let tryCode = syncCode 523 | finallyCode = monExit 524 | [startLabel, endLabel, finallyLabel, finallyEndLabel, defaultLabel] 525 | <- mkSystemLabels 5 526 | lb <- saveLastBranch 527 | unInstr $ monEnter 528 | InstrState { isCtrlFlow = cf 529 | , isLabelTable = lt } <- get 530 | (tryCF, tryLT, mtryLB) <- withCFState cf lt $ unInstr $ 531 | putLabel' startLabel 532 | <> tryCode 533 | <> finallyCode 534 | <> putLabel' endLabel 535 | <> condGoto Special defaultLabel 536 | (finallyCF, finallyLT, mfinallyLB) <- withCFState cf lt $ unInstr $ 537 | ctrlFlow (CF.mapStack (CF.push jthrowable)) 538 | <> putLabel finallyLabel 539 | <> storeCode 540 | <> finallyCode 541 | <> putLabel' finallyEndLabel 542 | <> loadCode 543 | <> throwCode 544 | addExceptionHandler startLabel endLabel finallyLabel Nothing 545 | addExceptionHandler finallyLabel finallyEndLabel finallyLabel Nothing 546 | putCtrlFlow' $ CF.merge cf [tryCF, finallyCF] 547 | mergeLabels [tryLT, finallyLT] 548 | unInstr $ putLabel defaultLabel 549 | resetLastBranch $ fromMaybe lb (selectLatestLB mtryLB mfinallyLB) 550 | 551 | throwable :: Text 552 | throwable = "java/lang/Throwable" 553 | 554 | jthrowable :: FieldType 555 | jthrowable = T.obj throwable 556 | -------------------------------------------------------------------------------- /src/Codec/JVM/ASM/Code/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} 2 | module Codec.JVM.ASM.Code.Types where 3 | 4 | import Codec.JVM.ASM.Code.CtrlFlow (CtrlFlow) 5 | 6 | import Data.Text (Text) 7 | import Data.IntMap.Strict (IntMap) 8 | import qualified Data.IntMap.Strict as IntMap 9 | 10 | newtype Label = Label Int 11 | deriving Show 12 | 13 | mkLabel :: Int -> Label 14 | mkLabel = Label 15 | 16 | newtype Offset = Offset { unOffset :: Int } -- absolute 17 | deriving (Eq, Num, Show, Ord, Enum, Integral, Real) 18 | 19 | newtype StackMapTable = StackMapTable (IntMap CtrlFlow) 20 | deriving Show 21 | 22 | -- Right-biased union 23 | union' :: IntMap a -> IntMap a -> IntMap a 24 | union' = IntMap.unionWith (flip const) 25 | 26 | -- TODO: Implement a strict fold for mconcat 27 | instance Monoid StackMapTable where 28 | mempty = StackMapTable mempty 29 | mappend (StackMapTable x) (StackMapTable y) 30 | = StackMapTable $ union' x y 31 | 32 | #if MIN_VERSION_base(4,10,0) 33 | instance Semigroup StackMapTable where 34 | (<>) (StackMapTable x) (StackMapTable y) 35 | = StackMapTable $ union' x y 36 | #endif 37 | 38 | insertSMT :: Int -> CtrlFlow -> StackMapTable -> StackMapTable 39 | insertSMT k v (StackMapTable sm) = StackMapTable $ IntMap.insert k v sm 40 | 41 | newtype LineNumber = LineNumber Int 42 | deriving (Show, Eq) 43 | 44 | mkLineNumber :: Int -> LineNumber 45 | mkLineNumber = LineNumber 46 | 47 | newtype LineNumberTable = LineNumberTable (IntMap LineNumber) 48 | deriving (Show, Eq) 49 | 50 | instance Monoid LineNumberTable where 51 | mempty = LineNumberTable mempty 52 | mappend (LineNumberTable x) (LineNumberTable y) 53 | = LineNumberTable $ union' x y 54 | 55 | #if MIN_VERSION_base(4,10,0) 56 | instance Semigroup LineNumberTable where 57 | (<>) (LineNumberTable x) (LineNumberTable y) 58 | = LineNumberTable $ union' x y 59 | #endif 60 | 61 | toListLNT :: LineNumberTable -> [(Offset,LineNumber)] 62 | toListLNT (LineNumberTable m) = map (\(off,ln) -> (Offset off,ln)) $ IntMap.assocs m 63 | 64 | insertLNT :: Offset -> LineNumber -> LineNumberTable -> LineNumberTable 65 | insertLNT (Offset off) ln (LineNumberTable lnt) = 66 | LineNumberTable $ IntMap.insert off ln lnt 67 | 68 | newtype LabelTable = LabelTable { unLabelTable :: IntMap Offset } 69 | deriving Show 70 | 71 | instance Monoid LabelTable where 72 | mempty = LabelTable mempty 73 | mappend (LabelTable x) (LabelTable y) 74 | = LabelTable $ union' x y 75 | 76 | #if MIN_VERSION_base(4,10,0) 77 | instance Semigroup LabelTable where 78 | (<>) (LabelTable x) (LabelTable y) 79 | = LabelTable $ union' x y 80 | #endif 81 | 82 | toLT :: [(Label, Offset)] -> LabelTable 83 | toLT labels = LabelTable $ IntMap.fromList labels' 84 | where labels' = map (\(Label l, o) -> (l, o)) labels 85 | 86 | unionsLT :: [LabelTable] -> LabelTable 87 | unionsLT = LabelTable 88 | . foldlStrict union' mempty 89 | . map unLabelTable 90 | 91 | insertLT :: Label -> Offset -> LabelTable -> LabelTable 92 | insertLT (Label l) off (LabelTable lt) = LabelTable $ IntMap.insert l off lt 93 | 94 | lookupLT :: Label -> LabelTable -> Offset 95 | lookupLT (Label l) (LabelTable lt) = IntMap.findWithDefault (Offset 0) l lt 96 | 97 | isDifferentLT :: Label -> Offset -> LabelTable -> Bool 98 | isDifferentLT (Label l) off (LabelTable lt) 99 | | Just off' <- IntMap.lookup l lt 100 | , off == off' 101 | = False 102 | | otherwise = True 103 | 104 | differenceLT :: LabelTable -> LabelTable -> LabelTable 105 | differenceLT (LabelTable lt1) (LabelTable lt2) = LabelTable $ 106 | IntMap.differenceWith (\a b -> if a /= b then Just a else Nothing) lt1 lt2 107 | 108 | sizeLT :: LabelTable -> Int 109 | sizeLT (LabelTable lt) = IntMap.size lt 110 | 111 | -- Taken from containers package 112 | foldlStrict :: (a -> b -> a) -> a -> [b] -> a 113 | foldlStrict f = go 114 | where 115 | go z [] = z 116 | go z (x:xs) = let z' = f z x in z' `seq` go z' xs 117 | {-# INLINE foldlStrict #-} 118 | 119 | newtype ExceptionTable = ExceptionTable [(Label, Label, Label, Maybe Text)] 120 | 121 | instance Monoid ExceptionTable where 122 | mempty = ExceptionTable mempty 123 | mappend (ExceptionTable x) (ExceptionTable y) 124 | = ExceptionTable $ x ++ y 125 | #if MIN_VERSION_base(4,10,0) 126 | instance Semigroup ExceptionTable where 127 | (<>) (ExceptionTable x) (ExceptionTable y) 128 | = ExceptionTable $ x ++ y 129 | #endif 130 | 131 | insertIntoET :: Label -> Label -> Label -> Maybe Text -> ExceptionTable -> ExceptionTable 132 | insertIntoET start end handler const (ExceptionTable etes) = 133 | ExceptionTable $ (start, end, handler, const) : etes 134 | 135 | toListET :: ExceptionTable -> [(Label, Label, Label, Maybe Text)] 136 | toListET (ExceptionTable etes) = reverse etes 137 | 138 | -- Special means that you don't record the usage of the goto. 139 | -- NotSpecial means you do (typical use case). 140 | data Special = Special | NotSpecial 141 | deriving Eq 142 | 143 | data LastBranch = NoBranch | HasBranch BranchType Offset 144 | deriving Show 145 | 146 | data BranchType = Return | Goto | GotoW 147 | deriving (Eq, Show) 148 | 149 | branchSize :: BranchType -> Offset 150 | branchSize Return = 1 151 | branchSize Goto = 3 152 | branchSize GotoW = 5 153 | -------------------------------------------------------------------------------- /src/Codec/JVM/Attr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards, CPP #-} 2 | module Codec.JVM.Attr where 3 | 4 | import Data.Maybe (mapMaybe, fromMaybe) 5 | import Data.Monoid ((<>)) 6 | import Data.Map.Strict (Map) 7 | import Data.ByteString (ByteString) 8 | import Data.Foldable (traverse_) 9 | import Data.Text (Text) 10 | import Data.List (foldl', nub) 11 | import Data.Word (Word8) 12 | import Data.Int 13 | import Data.Word 14 | import Data.Char 15 | 16 | import qualified Data.Map.Strict as Map 17 | import qualified Data.Set as S 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Lazy as LBS 20 | import qualified Data.IntMap.Strict as IntMap 21 | import qualified Data.Text as T 22 | 23 | import Codec.JVM.ASM.Code.CtrlFlow 24 | import qualified Codec.JVM.ASM.Code.CtrlFlow as CF 25 | import Codec.JVM.ASM.Code (Code(..)) 26 | import Codec.JVM.ASM.Code.Instr (runInstrBCSLE, ExceptionTableEntry(..)) 27 | import Codec.JVM.ASM.Code.Types (Offset(..), StackMapTable(..), 28 | LineNumber(..), LineNumberTable(..), 29 | toListLNT) 30 | import Codec.JVM.Const 31 | import Codec.JVM.ConstPool (ConstPool, putIx, unpack) 32 | import Codec.JVM.Internal 33 | import Codec.JVM.Types (PrimType(..), IClassName(..), 34 | AccessFlag(..), mkFieldDesc', putAccessFlags, prim) 35 | 36 | type ParameterName = Text 37 | 38 | type MParameter = (ParameterName, S.Set AccessFlag) 39 | 40 | type ClassName = Text 41 | 42 | type InterfaceName = Text 43 | 44 | type SuperClassName = Text 45 | 46 | data Attr 47 | = ACode 48 | { maxStack :: Int 49 | , maxLocals :: Int 50 | , code :: ByteString 51 | , exceptionTable :: [ExceptionTableEntry] 52 | , codeAttrs :: [Attr] } 53 | | AStackMapTable [(Offset, StackMapFrame)] 54 | | AInnerClasses InnerClassMap 55 | | ASignature (Signature TypeVariable) 56 | | AConstantValue Text 57 | | AMethodParam [MParameter] 58 | | ALineNumberTable LineNumberTable 59 | | ASourceFile Text 60 | | ANormalAnnotations Visibility [NormalAnnotation] 61 | | AParameterAnnotations Visibility ParameterAnnotations 62 | 63 | ------------------------Signatures------------------------------------ 64 | 65 | type TypeVariable = Text 66 | 67 | data Signature a = ClassSig (ClassSignature a) 68 | | MethodSig (MethodSignature a) 69 | | FieldSig (FieldSignature a) 70 | deriving Show 71 | 72 | -- | JavaTypeSignature 73 | data Parameter a 74 | = ReferenceParameter (ReferenceParameter a) -- ^ ReferenceTypeSignature 75 | | PrimitiveParameter PrimType -- ^ BaseType 76 | deriving Show 77 | 78 | type ObjectType = IClassName 79 | 80 | -- | ReferenceTypeSignature 81 | data ReferenceParameter a 82 | = -- | ClassTypeSignature 83 | GenericReferenceParameter 84 | ObjectType -- PackageSpecifier & SimpleClassTypeSignature 85 | [TypeParameter a] -- TypeArguments 86 | [ReferenceParameter a] -- ClassTypeSignatureSuffix 87 | -- | TypeVariableSignature 88 | | VariableReferenceParameter a 89 | -- | ArrayTypeSignature 90 | | ArrayReferenceParameter (Parameter a) 91 | deriving Show 92 | 93 | -- | TypeArgument, TypeParameter 94 | data TypeParameter a 95 | = WildcardTypeParameter (Bound a) -- 96 | | SimpleTypeParameter (ReferenceParameter a) 97 | deriving Show 98 | 99 | data Bound a 100 | = NotBounded 101 | | ExtendsBound (ReferenceParameter a) 102 | | SuperBound (ReferenceParameter a) 103 | deriving Show 104 | 105 | -- TypeParameters 106 | type TypeVariableDeclarations a = [TypeVariableDeclaration a] 107 | 108 | data TypeVariableDeclaration a = TypeVariableDeclaration a [Bound a] 109 | deriving Show 110 | 111 | -- | ** ClassSignature ** 112 | data ClassSignature a 113 | = ClassSignature 114 | (TypeVariableDeclarations a) -- TypeParameters 115 | [ClassParameter a] -- SuperclassSignature & SuperinterfaceSignature 116 | deriving Show 117 | 118 | type ClassParameter a = ReferenceParameter a 119 | 120 | -- | ** MethodSignature ** 121 | data MethodSignature a = 122 | MethodSignature 123 | (TypeVariableDeclarations a) -- TypeParameters 124 | [MethodParameter a] -- JavaTypeSignature 125 | (MethodReturn a) -- Result 126 | (ThrowsExceptions a) -- ThrowsSignature 127 | deriving Show 128 | 129 | -- | JavaTypeSignature 130 | type MethodParameter a = Parameter a 131 | 132 | -- | Result 133 | type MethodReturn a = Maybe (Parameter a) 134 | 135 | -- | ThrowsSignature 136 | type ThrowsExceptions a = [ReferenceParameter a] 137 | 138 | -- | ** FieldSignature ** 139 | data FieldSignature a = FieldSignature (FieldParameter a) 140 | deriving Show 141 | 142 | type FieldParameter a = ReferenceParameter a 143 | 144 | mconcatMap :: (Monoid m) => (a -> m) -> [a] -> m 145 | mconcatMap f xs = mconcat (map f xs) 146 | 147 | generateSignature :: Signature TypeVariable -> Text 148 | generateSignature sig = case sig of 149 | ClassSig (ClassSignature typeVarDecls classParams) -> 150 | generateTypeParameters typeVarDecls 151 | <> generateClassParameters classParams 152 | MethodSig (MethodSignature typeVarDecls methodParams methodReturn throwExceptions) -> 153 | generateTypeParameters typeVarDecls 154 | <> "(" <> mconcatMap generateParameter methodParams <> ")" 155 | <> maybe "V" generateParameter methodReturn 156 | <> generateThrowsSignature throwExceptions 157 | FieldSig (FieldSignature fieldRefParam) -> 158 | generateReferenceParameter fieldRefParam 159 | 160 | generateThrowsSignature :: ThrowsExceptions TypeVariable -> Text 161 | generateThrowsSignature = mconcat . map (T.cons '^' . generateReferenceParameter) 162 | 163 | generateClassParameters :: [ReferenceParameter TypeVariable] -> Text 164 | generateClassParameters = mconcat . map generateReferenceParameter 165 | 166 | generateTypeParameters :: TypeVariableDeclarations TypeVariable -> Text 167 | generateTypeParameters typeParams 168 | | length typeParams == 0 = "" 169 | | otherwise = "<" <> mconcatMap generateTypeParameter typeParams <> ">" 170 | 171 | generateTypeParameter :: TypeVariableDeclaration TypeVariable -> Text 172 | generateTypeParameter (TypeVariableDeclaration identifier bounds) 173 | = identifier <> mconcatMap generateTypeParameterBound bounds 174 | 175 | generateTypeParameterBound :: Bound TypeVariable -> Text 176 | generateTypeParameterBound bounded = ":" <> 177 | case bounded of 178 | NotBounded -> "" 179 | ExtendsBound refParam -> generateReferenceParameter refParam 180 | SuperBound refParam -> generateReferenceParameter refParam 181 | 182 | generateReferenceParameter :: ReferenceParameter TypeVariable -> Text 183 | generateReferenceParameter (GenericReferenceParameter (IClassName className) typeArgs refParams) = 184 | "L" <> className <> generateTypeArguments typeArgs 185 | <> mconcatMap (T.cons '.' . generateSimpleClass) refParams <> ";" 186 | where generateSimpleClass (GenericReferenceParameter (IClassName simpleClassName) tyArgs []) = 187 | simpleClassName <> generateTypeArguments tyArgs 188 | generateSimpleClass _ = error "generateReferenceParameter: Not generic." 189 | generateReferenceParameter (ArrayReferenceParameter param) = 190 | "[" <> generateParameter param 191 | generateReferenceParameter (VariableReferenceParameter identifier) = 192 | "T" <> identifier <> ";" 193 | 194 | generateParameter :: Parameter TypeVariable -> Text 195 | generateParameter (ReferenceParameter refParam) = 196 | generateReferenceParameter refParam 197 | generateParameter (PrimitiveParameter primType) = 198 | mkFieldDesc' (prim primType) 199 | 200 | generateTypeArguments :: [TypeParameter TypeVariable] -> Text 201 | generateTypeArguments typeParams 202 | | length typeParams == 0 = "" 203 | | otherwise = "<" <> mconcatMap generateTypeArgument typeParams <> ">" 204 | 205 | generateTypeArgument :: TypeParameter TypeVariable -> Text 206 | generateTypeArgument (WildcardTypeParameter bound) = 207 | case bound of 208 | NotBounded -> "*" 209 | ExtendsBound refParam -> "+" <> generateReferenceParameter refParam 210 | SuperBound refParam -> "-" <> generateReferenceParameter refParam 211 | generateTypeArgument (SimpleTypeParameter refParam) = 212 | generateReferenceParameter refParam 213 | 214 | --------------------------------------------------------------------------- 215 | 216 | newtype InnerClassMap = InnerClassMap (Map Text InnerClass) 217 | deriving (Eq, Show) 218 | 219 | innerClassElems :: InnerClassMap -> [InnerClass] 220 | innerClassElems (InnerClassMap m) = Map.elems m 221 | 222 | -- Left-biased monoid. Not commutative 223 | instance Monoid InnerClassMap where 224 | mempty = InnerClassMap mempty 225 | mappend (InnerClassMap x) (InnerClassMap y) = 226 | InnerClassMap $ x `Map.union` y 227 | 228 | #if MIN_VERSION_base(4,10,0) 229 | instance Semigroup InnerClassMap where 230 | (<>) (InnerClassMap x) (InnerClassMap y) = 231 | InnerClassMap $ x `Map.union` y 232 | #endif 233 | 234 | instance Show Attr where 235 | show (AInnerClasses icm) = "AInnerClasses = " ++ show icm 236 | show attr = "A" ++ (T.unpack $ attrName attr) 237 | 238 | attrName :: Attr -> Text 239 | attrName (ACode {}) = "Code" 240 | attrName (AStackMapTable {}) = "StackMapTable" 241 | attrName (AInnerClasses {}) = "InnerClasses" 242 | attrName (ASignature {}) = "Signature" 243 | attrName (AConstantValue {}) = "ConstantValue" 244 | attrName (AMethodParam {}) = "MethodParameters" 245 | attrName (ALineNumberTable {}) = "LineNumberTable" 246 | attrName (ASourceFile {}) = "SourceFile" 247 | attrName (ANormalAnnotations vis _) 248 | = "Runtime" <> T.pack (show vis) <> "Annotations" 249 | attrName (AParameterAnnotations vis _) 250 | = "Runtime" <> T.pack (show vis) <> "ParameterAnnotations" 251 | 252 | unpackAttr :: Attr -> [Const] 253 | unpackAttr attr = CUTF8 (attrName attr) : restAttributes 254 | where restAttributes = 255 | case attr of 256 | ACode { codeAttrs = xs } -> concatMap unpackAttr xs 257 | ASignature sig -> [CUTF8 $ generateSignature sig] 258 | ASourceFile f -> [CUTF8 $ f] 259 | ANormalAnnotations _ annots -> concatMap unpackAnnotation annots 260 | AParameterAnnotations _ (ParameterAnnotations _ annotss) -> 261 | concatMap (concatMap unpackAnnotation) annotss 262 | _ -> [] 263 | 264 | putAttr :: String -> Maybe Int -> ConstPool -> Attr -> Put 265 | putAttr debug mCodeSize cp attr = do 266 | putIx (debugMsg "name") cp $ CUTF8 $ attrName attr 267 | let xs = runPut $ putAttrBody (debugMsg "body") mCodeSize cp attr 268 | putI32 . fromIntegral $ LBS.length xs 269 | putByteString $ LBS.toStrict xs 270 | where debugMsg tag = "putAttr[" ++ tag ++ "][" ++ debug ++ "]" 271 | 272 | putAttrBody :: String -> Maybe Int -> ConstPool -> Attr -> Put 273 | putAttrBody debug mCodeSize cp attr = 274 | case attr of 275 | ACode ms ls xs exceptionTable attrs -> do 276 | putI16 ms 277 | putI16 ls 278 | putI32 . fromIntegral $ BS.length xs 279 | putByteString xs 280 | putI16 (length exceptionTable) 281 | mapM_ (\ExceptionTableEntry {..} -> do 282 | putI16 eteStartPc 283 | putI16 eteEndPc 284 | putI16 eteHandlerPc 285 | let debugMsg = "putExceptionTable[" ++ debug ++ "]" 286 | maybe (putI16 0) (putIx debugMsg cp) eteCatchType) 287 | exceptionTable 288 | putI16 $ length attrs 289 | mapM_ (putAttr ("putAttrBody[Code][" ++ debug ++ "]") (Just (BS.length xs)) cp) attrs 290 | AStackMapTable xs -> do 291 | let (numFrames, putFrames) = 292 | putStackMapFrames ("putAttrBody[StackMapTable][" ++ debug ++ "]") 293 | mCodeSize cp xs 294 | putI16 numFrames 295 | putFrames 296 | AInnerClasses innerClassMap -> do 297 | let ics = innerClassElems innerClassMap 298 | putI16 $ length ics 299 | mapM_ (putInnerClass cp) ics 300 | ASignature signature -> 301 | putIx ("putAttrBody[Signature][" ++ debug ++ "]") cp 302 | $ CUTF8 $ generateSignature signature 303 | AConstantValue _ -> error "putAttrBody: ConstantValue attribute not implemented!" 304 | AMethodParam _ -> error "putAttrBody: MethodParameter attribute not implemented!" 305 | ALineNumberTable lnt -> do 306 | let lns = toListLNT lnt 307 | putI16 $ length lns 308 | mapM_ (\(Offset pc, LineNumber ln) -> putI16 pc >> putI16 ln) lns 309 | ASourceFile fileName -> 310 | putIx ("putAttrBody[SourceFile][" ++ debug ++ "]") cp 311 | $ CUTF8 $ fileName 312 | ANormalAnnotations _ annots -> do 313 | putAnnotations debug cp annots 314 | 315 | AParameterAnnotations _ (ParameterAnnotations numParams annotss) -> do 316 | putWord8 numParams 317 | mapM_ (putAnnotations debug cp) annotss 318 | 319 | -- | http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.4 320 | -- 321 | -- Offsets are absolute (the delta conversion happen during serialization) 322 | 323 | data StackMapFrame 324 | = SameFrame -- Covers normal & extended 325 | | SameLocals1StackItem !VerifType -- Covers normal & extended 326 | | ChopFrame !Int 327 | | AppendFrame !Word8 ![VerifType] 328 | | FullFrame ![VerifType] ![VerifType] 329 | deriving (Eq, Show) 330 | 331 | putStackMapFrames :: String -> Maybe Int -> ConstPool -> [(Offset, StackMapFrame)] -> (Int, Put) 332 | putStackMapFrames debug mCodeSize cp xs = (numFrames, putFrames) 333 | where (_nextOffset, numFrames, putFrames) = foldl' f (-1, 0, return ()) xs 334 | f (offset, !n, put) (Offset frameOffset, frame) 335 | | frameOffset >= fromMaybe maxBound mCodeSize = (offset, n, put) 336 | | otherwise = (frameOffset, n + 1, put *> putFrame frame) 337 | where delta = frameOffset - (if offset == -1 then 0 else offset + 1) 338 | putVerifTy tag = putVerifType 339 | ("StackMapFrame[" ++ tag ++ "][" ++ show frameOffset ++ "][" 340 | ++ debug ++ "]") cp 341 | putFrame SameFrame = 342 | if delta <= 63 343 | then putWord8 $ fromIntegral delta 344 | else do 345 | putWord8 251 346 | putWord16be $ fromIntegral delta 347 | putFrame (SameLocals1StackItem vt) = do 348 | if delta <= 63 349 | then putWord8 $ fromIntegral (delta + 64) 350 | else do 351 | putWord8 247 352 | putWord16be $ fromIntegral delta 353 | putVerifTy "SameLocals1StackItem" vt 354 | putFrame (ChopFrame k) = do 355 | -- ASSERT (1 <= k <= 3) 356 | putWord8 . fromIntegral $ 251 - k 357 | putWord16be $ fromIntegral delta 358 | putFrame (AppendFrame k vts) = do 359 | -- ASSERT (1 <= k <= 3) 360 | putWord8 $ 251 + k 361 | putI16 $ fromIntegral delta 362 | traverse_ (putVerifTy "AppendFrame") vts 363 | putFrame (FullFrame locals stack) = do 364 | putWord8 255 365 | putI16 $ fromIntegral delta 366 | putI16 $ length locals 367 | traverse_ 368 | (putVerifTy ("FullFrame[locals[" ++ show locals ++ "]]")) locals 369 | putI16 $ length stack 370 | traverse_ (putVerifTy ("FullFrame[stack[" ++ show stack ++ "]]")) stack 371 | 372 | toAttrs :: ConstPool -> Code -> [Attr] 373 | toAttrs cp code = [ACode maxStack' maxLocals' xs etes attrs'] 374 | where (xs, cf, smt, lnt, etes) = runInstrBCSLE (instr code) cp 375 | maxLocals' = CF.maxLocals cf 376 | maxStack' = CF.maxStack cf 377 | attrs = if null frames then [] else [AStackMapTable frames] 378 | frames = toStackMapFrames smt 379 | attrs' = attrs ++ if lnt == mempty then [] 380 | else [ALineNumberTable lnt] 381 | 382 | toStackMapFrames :: StackMapTable -> [(Offset, StackMapFrame)] 383 | toStackMapFrames (StackMapTable smt) 384 | = reverse . fst $ foldl' f ([], c) cfs 385 | where ((_,c):cfs) = IntMap.toAscList smt 386 | f (!xs, !cf') (!off, !cf) = ((Offset off, smf):xs, cf) 387 | where smf = generateStackMapFrame cf' cf 388 | 389 | generateStackMapFrame :: CtrlFlow -> CtrlFlow -> StackMapFrame 390 | generateStackMapFrame cf1 cf2 391 | | sameLocals && sz < 2 392 | = case sz of 393 | 0 -> SameFrame 394 | 1 -> SameLocals1StackItem stackTop 395 | _ -> fullFrame 396 | | otherwise 397 | = if sz == 0 then 398 | if lszdiff <= 3 && lszdiff > 0 then 399 | AppendFrame (fromIntegral lszdiff) $ drop lsz1 clocals2 400 | else if lszdiff >= -3 && lszdiff < 0 then 401 | ChopFrame (-lszdiff) 402 | else fullFrame 403 | else fullFrame 404 | where cf1' = mapLocals normaliseLocals cf1 405 | cf2' = mapLocals normaliseLocals cf2 406 | (clocals2, cstack2) = compressCtrlFlow cf2' 407 | (clocals1, _) = compressCtrlFlow cf1' 408 | fullFrame = FullFrame clocals2 cstack2 409 | stackTop = last cstack2 410 | sameLocals = areLocalsSame (locals cf1) (locals cf2) 411 | lsz1 = length clocals1 412 | lsz2 = length clocals2 413 | lszdiff = lsz2 - lsz1 414 | sz = length cstack2 415 | 416 | data InnerClass = 417 | InnerClass { icInnerClass :: IClassName 418 | , icOuterClass :: IClassName 419 | , icInnerName :: Text 420 | , icAccessFlags :: [AccessFlag] } 421 | deriving (Eq, Show) 422 | 423 | putInnerClass :: ConstPool -> InnerClass -> Put 424 | putInnerClass cp InnerClass {..} = do 425 | putIx "putInnerClass[innerClass]" cp $ CClass icInnerClass 426 | putIx "putInnerClass[outerClass]" cp $ CClass icOuterClass 427 | putIx "putInnerClass[innerName]" cp $ CUTF8 icInnerName 428 | putAccessFlags $ S.fromList icAccessFlags 429 | 430 | innerClassInfo :: (Text -> Bool) -> [Const] -> ([Const], [Attr]) 431 | innerClassInfo ignore consts = (nub. concat $ innerConsts, innerClassAttr) 432 | where 433 | innerClassAttr = if null innerClasses 434 | then [] 435 | else [ AInnerClasses 436 | . InnerClassMap 437 | . Map.fromList 438 | . map (\ic@InnerClass {..} -> 439 | (icInnerName, ic)) 440 | $ innerClasses] 441 | -- TODO: Support generation of private inner classes, not a big priority 442 | (innerConsts, innerClasses) = unzip $ 443 | mapMaybe (\(CClass icn@(IClassName cn)) -> 444 | if ignore cn 445 | then Nothing 446 | else 447 | case T.break (=='$') cn of 448 | (outerClass,innerName') 449 | | not (T.null innerName') 450 | , let innerName = T.tail innerName' 451 | , not (T.null innerName) 452 | , T.last innerName /= ';' -> 453 | let innerClass = 454 | InnerClass { icInnerClass = icn 455 | , icOuterClass = IClassName outerClass 456 | , icInnerName = innerName 457 | , icAccessFlags = [Public, Static] } 458 | in Just (unpackInnerClass innerClass, innerClass) 459 | _ -> Nothing) 460 | classConsts 461 | classConsts = filter (\c -> constTag c == 7) consts 462 | 463 | unpackInnerClass :: InnerClass -> [Const] 464 | unpackInnerClass InnerClass {..} = 465 | (CUTF8 icInnerName) : 466 | ((unpack $ CClass icOuterClass) ++ (unpack $ CClass icInnerClass)) 467 | 468 | data Visibility = Invisible | Visible 469 | deriving Show 470 | 471 | data NormalAnnotation = NormalAnnotation Text [ElementValue] 472 | 473 | data ParameterAnnotations = ParameterAnnotations Word8 [[NormalAnnotation]] 474 | 475 | data ElementValue = 476 | BooleanValue Bool 477 | | ByteValue Int8 478 | | ShortValue Int16 479 | | CharValue Word16 480 | | IntValue Int32 481 | | FloatValue Float 482 | | LongValue Int64 483 | | DoubleValue Double 484 | | StringValue Text 485 | | EnumValue Text Text 486 | | ClassValue Text 487 | | AnnotationValue NormalAnnotation 488 | | ArrayValue [ElementValue] 489 | 490 | elementTag :: ElementValue -> Char 491 | elementTag val = case val of 492 | BooleanValue {} -> 'Z' 493 | ByteValue {} -> 'B' 494 | ShortValue {} -> 'S' 495 | CharValue {} -> 'C' 496 | IntValue {} -> 'I' 497 | FloatValue {} -> 'F' 498 | LongValue {} -> 'J' 499 | DoubleValue {} -> 'D' 500 | StringValue {} -> 's' 501 | EnumValue {} -> 'e' 502 | ClassValue {} -> 'c' 503 | AnnotationValue {} -> '@' 504 | ArrayValue {} -> '[' 505 | 506 | unpackAnnotation :: NormalAnnotation -> [Const] 507 | unpackAnnotation (NormalAnnotation ty vals) = 508 | CUTF8 ("L" <> ty <> ";") : concatMap unpackElementValue vals 509 | 510 | unpackElementValue :: ElementValue -> [Const] 511 | unpackElementValue val = 512 | case val of 513 | BooleanValue b -> intVal $ fromEnum b 514 | ByteValue b -> intVal b 515 | ShortValue s -> intVal s 516 | CharValue c -> intVal c 517 | IntValue i -> intVal i 518 | FloatValue f -> singVal $ CFloat f 519 | LongValue l -> singVal $ CLong l 520 | DoubleValue d -> singVal $ CDouble d 521 | StringValue s -> singVal $ CString s 522 | EnumValue ty name -> [CUTF8 ("L" <> ty <> ";"), CUTF8 name] 523 | ClassValue name -> [CUTF8 name] 524 | AnnotationValue annot -> unpackAnnotation annot 525 | ArrayValue values -> concatMap unpackElementValue values 526 | where intVal :: (Integral a) => a -> [Const] 527 | intVal = singVal . CInteger . fromIntegral 528 | 529 | singVal = (:[]) . CValue 530 | 531 | putAnnotations :: String -> ConstPool -> [NormalAnnotation] -> Put 532 | putAnnotations debug cp annots = do 533 | putI16 $ length annots 534 | mapM_ putAnnotation annots 535 | where putAnnotation annot@(NormalAnnotation ty vals) = do 536 | putIx ("putAnnotations[" ++ debug ++ "]") cp $ 537 | head $ unpackAnnotation annot 538 | putI16 $ length vals 539 | mapM_ putElementValue vals 540 | 541 | putElementValue val = do 542 | putWord8 $ fromIntegral $ ord $ elementTag val 543 | let putConst = mapM_ (putIx "putElementValue" cp) $ unpackElementValue val 544 | case val of 545 | BooleanValue {} -> putConst 546 | ByteValue {} -> putConst 547 | ShortValue {} -> putConst 548 | CharValue {} -> putConst 549 | IntValue {} -> putConst 550 | FloatValue {} -> putConst 551 | LongValue {} -> putConst 552 | DoubleValue {} -> putConst 553 | StringValue {} -> putConst 554 | EnumValue {} -> putConst 555 | ClassValue {} -> putConst 556 | AnnotationValue annot -> putAnnotation annot 557 | ArrayValue values -> do 558 | putI16 $ length values 559 | mapM_ putElementValue values 560 | -------------------------------------------------------------------------------- /src/Codec/JVM/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Codec.JVM.Class where 3 | 4 | import Data.Binary.Get 5 | import Data.Map.Strict (Map) 6 | import Data.ByteString (ByteString) 7 | import Data.ByteString.Lazy (toStrict) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Text (Text) 10 | import Data.Set (Set) 11 | import Data.Word (Word32) 12 | 13 | import qualified Data.List as L 14 | import qualified Data.Text as T 15 | import qualified Data.ByteString.Lazy as BL 16 | import Control.Monad (when) 17 | 18 | import Codec.JVM.Attr (Attr, putAttr) 19 | import Codec.JVM.Const 20 | import Codec.JVM.ConstPool 21 | import Codec.JVM.Field (FieldInfo, putFieldInfo) 22 | import Codec.JVM.Internal 23 | import Codec.JVM.Method (MethodInfo, putMethodInfo) 24 | import Codec.JVM.Types 25 | import qualified Codec.JVM.ConstPool as CP 26 | 27 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.1 28 | data ClassFile = ClassFile 29 | { constants :: [Const] 30 | , version :: Version 31 | , accessFlags :: Set AccessFlag 32 | , thisClass :: IClassName 33 | , superClass :: Maybe IClassName 34 | , interfaces :: [IClassName] 35 | , fields :: [FieldInfo] 36 | , methods :: [MethodInfo] 37 | , attributes :: Map Text Attr } 38 | deriving Show 39 | 40 | mAGIC :: Word32 41 | mAGIC = 0xCAFEBABE 42 | 43 | putClassFile :: ClassFile -> Put 44 | putClassFile ClassFile {..} = do 45 | putWord32be mAGIC 46 | putI16 . versionMin $ version 47 | putI16 . versionMaj $ version 48 | putI16 . (+) 1 . CP.size $ cp 49 | putConstPool cp 50 | putAccessFlags accessFlags 51 | putIx (classDebug "thisClass") cp . cclass $ thisClass 52 | putIx (classDebug "superClass") cp . cclass . fromMaybe jlObject $ superClass 53 | putI16 . L.length $ interfaces 54 | mapM_ (putIx (classDebug "interface") cp . cclass) interfaces 55 | putFields 56 | putMethods 57 | putI16 . L.length $ attributes 58 | mapM_ (putAttr (classDebug "attributes") Nothing cp) attributes 59 | return () 60 | where clsName = T.unpack $ unIClassName thisClass 61 | exceedsLim = exceeds 65535 clsName 62 | cp = exceedsLim 63 | "putClassFile: ConstPool size exceeds 65,535 constants" ((+) 1 . CP.size) 64 | $ CP.mkConstPool constants 65 | classDebug tag = "Class[" ++ tag ++ "][" ++ show thisClass ++ "]" 66 | putMethods = do 67 | let methodsLength = exceedsLim 68 | "putClassFile: number of methods exceeds 65,535 constants" id 69 | $ L.length methods 70 | putI16 methodsLength 71 | mapM_ (putMethodInfo (classDebug "method") cp) methods 72 | putFields = do 73 | let fieldsLength = exceedsLim 74 | "putClassFile: number of fields exceeds 65,535 constants" id 75 | $ L.length fields 76 | putI16 fieldsLength 77 | mapM_ (putFieldInfo (classDebug "field") cp) fields 78 | 79 | exceeds :: Int -> String -> String -> (a -> Int) -> a -> a 80 | exceeds lim cls err f i 81 | | let i' = f i 82 | , i' > lim = error $ "Error when generating class '" ++ cls ++ "': " ++ err ++ ": " ++ show i' 83 | | otherwise = i 84 | 85 | getClassName :: Get Text 86 | getClassName = do 87 | magic <- getWord32be 88 | when (magic /= mAGIC) $ 89 | fail $ "Invalid .class file MAGIC value: " ++ show magic 90 | _ <- getWord16be -- minorVersion 91 | _ <- getWord16be -- majorVersion 92 | poolSize <- getWord16be 93 | pool <- getConstPool $ fromIntegral $ poolSize - 1 94 | _ <- getAccessFlags ATClass -- afs 95 | classIdx <- getWord16be 96 | let CClass (IClassName iclsName) = getConstAt classIdx pool 97 | return iclsName 98 | 99 | classFileBS :: ClassFile -> ByteString 100 | classFileBS = toStrict . runPut . putClassFile 101 | 102 | classFileCls :: BL.ByteString -> String 103 | classFileCls bs = T.unpack $ runGet getClassName bs 104 | 105 | classFileName :: ClassFile -> String 106 | classFileName ClassFile { thisClass = IClassName class_ } = T.unpack class_ 107 | 108 | superClassName :: ClassFile -> String 109 | superClassName ClassFile { superClass } = 110 | maybe "java/lang/Object" (T.unpack . unIClassName) superClass 111 | -------------------------------------------------------------------------------- /src/Codec/JVM/Const.hs: -------------------------------------------------------------------------------- 1 | module Codec.JVM.Const 2 | (Const(..), 3 | ConstVal(..), 4 | constTag, 5 | constValType, 6 | cclass, 7 | cstring, 8 | cint, 9 | clong, 10 | cfloat, 11 | cdouble, 12 | getObjConst, 13 | isConstCategory2 14 | ) 15 | where 16 | 17 | import Data.Text (Text) 18 | import Data.Word (Word8) 19 | import Data.Int (Int32,Int64) 20 | 21 | import Codec.JVM.Types (IClassName(..), FieldRef, FieldType(..), MethodRef, PrimType(..), NameAndDesc, jlString, mkFieldDesc') 22 | 23 | constTag :: Const -> Word8 24 | constTag (CUTF8 _) = 1 25 | constTag (CValue (CInteger _)) = 3 26 | constTag (CValue (CFloat _)) = 4 27 | constTag (CValue (CLong _)) = 5 28 | constTag (CValue (CDouble _)) = 6 29 | constTag (CClass _) = 7 30 | constTag (CValue (CString _)) = 8 31 | constTag (CFieldRef _) = 9 32 | constTag (CMethodRef _) = 10 33 | constTag (CInterfaceMethodRef _)= 11 34 | constTag (CNameAndType _) = 12 35 | 36 | -- | https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.4 37 | data Const 38 | = CUTF8 Text 39 | | CValue ConstVal 40 | | CClass IClassName 41 | | CFieldRef FieldRef 42 | | CMethodRef MethodRef 43 | | CInterfaceMethodRef MethodRef 44 | | CNameAndType NameAndDesc 45 | deriving (Eq, Ord, Show) 46 | 47 | -- | https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.2-300-C.1 48 | data ConstVal 49 | = CString Text 50 | | CInteger Int32 51 | | CLong Int64 52 | | CFloat Float 53 | | CDouble Double 54 | deriving (Eq, Ord, Show) 55 | 56 | -- instance Show ConstVal where 57 | -- show (CInteger x) = show x -- concat ["Int ", show x] 58 | -- show (CString x) = show x -- concat ["String ", show x] 59 | -- show (CLong x) show x 60 | -- show (CFloat x) = show x 61 | 62 | constValType :: ConstVal -> FieldType 63 | constValType (CString _) = ObjectType jlString 64 | constValType (CInteger _) = BaseType JInt 65 | constValType (CLong _) = BaseType JLong 66 | constValType (CFloat _) = BaseType JFloat 67 | constValType (CDouble _) = BaseType JDouble 68 | 69 | cclass :: IClassName -> Const 70 | cclass = CClass 71 | 72 | cstring :: Text -> Const 73 | cstring = CValue . CString 74 | 75 | clong :: Int64 -> Const 76 | clong = CValue . CLong 77 | 78 | cint :: Int32 -> Const 79 | cint = CValue . CInteger 80 | 81 | cfloat :: Float -> Const 82 | cfloat = CValue . CFloat 83 | 84 | cdouble :: Double -> Const 85 | cdouble = CValue . CDouble 86 | 87 | getObjConst :: FieldType -> Maybe Const 88 | getObjConst (ObjectType iclass) = Just $ cclass iclass 89 | getObjConst ft@(ArrayType _) 90 | = Just $ cclass (IClassName $ mkFieldDesc' ft) 91 | getObjConst _ = Nothing 92 | 93 | isConstCategory2 :: Const -> Bool 94 | isConstCategory2 (CValue x) 95 | | CLong _ <- x 96 | = True 97 | | CDouble _ <- x 98 | = True 99 | isConstCategory2 _ = False 100 | 101 | -------------------------------------------------------------------------------- /src/Codec/JVM/ConstPool.hs: -------------------------------------------------------------------------------- 1 | module Codec.JVM.ConstPool where 2 | 3 | import Control.Arrow (second) 4 | import Control.Monad (join) 5 | import Data.IntMap.Lazy ((!)) 6 | import qualified Data.IntMap.Lazy as LazyMap 7 | import qualified Data.ByteString.Lazy as BL 8 | import Data.Map.Strict (Map) 9 | import Data.Function (fix) 10 | import Data.Text.Encoding (decodeUtf8) 11 | 12 | import qualified Data.List as L 13 | import qualified Data.Map.Strict as M 14 | import qualified Data.Text as T 15 | 16 | import Codec.JVM.Const 17 | import Codec.JVM.Encoding 18 | import Codec.JVM.Internal 19 | import Codec.JVM.Types 20 | 21 | newtype CIx = CIx Int 22 | 23 | newtype ConstPool = ConstPool (Map Const Int) 24 | deriving Show 25 | 26 | type IxConstPool = LazyMap.IntMap Const 27 | 28 | mkConstPool :: [Const] -> ConstPool 29 | mkConstPool defs = ConstPool . snd $ L.foldl' f (0, M.empty) defs' 30 | where defs' = filter (\c -> case c of 31 | CClass (IClassName cn) 32 | | not (T.null cn) && T.last cn == ';' && T.head cn == 'L' -> False 33 | _ -> True) 34 | defs 35 | f acc c = L.foldl' f' acc $ unpack c 36 | where f' (i, xs) y = if M.member y xs 37 | then (i, xs) 38 | else (i + constPoolSpace y, M.insert y i xs) 39 | 40 | constPoolSpace :: Const -> Int 41 | constPoolSpace (CValue (CLong _)) = 2 42 | constPoolSpace (CValue (CDouble _)) = 2 43 | constPoolSpace _ = 1 44 | 45 | run :: ConstPool -> [Const] 46 | run (ConstPool xs) = fmap fst $ L.sortOn snd $ M.toList xs 47 | 48 | -- TODO: This is incorrect if the last entry is a Double or Long 49 | size :: ConstPool -> Int 50 | size (ConstPool xs) = (M.foldl' max 0 xs) + 1 51 | 52 | index :: Const -> ConstPool -> Maybe CIx 53 | index def (ConstPool xs) = CIx . (+) 1 <$> M.lookup def xs 54 | 55 | ix :: CIx -> Int 56 | ix (CIx x) = x 57 | 58 | unsafeIndex :: String -> Const -> ConstPool -> CIx 59 | unsafeIndex debug def cp 60 | = maybe (error $ join ["Constant '", show def, "' not found.\n", 61 | "Trace: [", debug, "]\n", 62 | show cp]) id 63 | $ index def cp 64 | 65 | unpack :: Const -> [Const] 66 | unpack (CClass cn) = unpackClassName cn 67 | unpack c@(CValue (CString str)) = [c, CUTF8 str] 68 | unpack (CFieldRef ref) = unpackFieldRef ref 69 | unpack (CMethodRef ref) = unpackMethodRef ref 70 | unpack (CInterfaceMethodRef ref) = unpackInterfaceMethodRef ref 71 | unpack (CNameAndType nd) = unpackNameAndType nd 72 | unpack c = [c] 73 | 74 | unpackFieldType :: FieldType -> [Const] 75 | unpackFieldType (ObjectType iclass) = unpackClassName iclass 76 | unpackFieldType ft@(ArrayType _) = unpackClassName . IClassName $ mkFieldDesc' ft 77 | unpackFieldType _ = [] 78 | 79 | unpackClassName :: IClassName -> [Const] 80 | unpackClassName cn@(IClassName str) = [CClass cn, CUTF8 str] 81 | 82 | unpackFieldDesc :: UName -> FieldDesc -> [Const] 83 | unpackFieldDesc n (FieldDesc t) = unpackNameAndType (NameAndDesc n $ Desc t) 84 | 85 | unpackFieldRef :: FieldRef -> [Const] 86 | unpackFieldRef ref@(FieldRef cn n ft) = 87 | CFieldRef ref:unpackClassName cn ++ unpackFieldDesc n (mkFieldDesc ft) ++ unpackFieldType ft 88 | 89 | unpackMethodRef :: MethodRef -> [Const] 90 | unpackMethodRef ref@(MethodRef cn n fts rt) = 91 | CMethodRef ref:unpackClassName cn ++ unpackNameAndType (NameAndDesc n $ Desc (mkMethodDesc' fts rt)) ++ concatMap unpackFieldType fts ++ maybe [] unpackFieldType rt 92 | 93 | unpackInterfaceMethodRef :: MethodRef -> [Const] 94 | unpackInterfaceMethodRef ref@(MethodRef cn n fts rt) = 95 | CInterfaceMethodRef ref:unpackClassName cn ++ unpackNameAndType (NameAndDesc n $ Desc (mkMethodDesc' fts rt)) ++ concatMap unpackFieldType fts ++ maybe [] unpackFieldType rt 96 | 97 | unpackNameAndType :: NameAndDesc -> [Const] 98 | unpackNameAndType nd@(NameAndDesc (UName str0) (Desc str1)) = [CNameAndType nd, CUTF8 str0, CUTF8 str1] 99 | 100 | putIx :: String -> ConstPool -> Const -> Put 101 | putIx debug cp c = putWord16be . fromIntegral . ix 102 | $ unsafeIndex ("putIx[" ++ debug ++ "]") c cp 103 | 104 | putConstPool :: ConstPool -> Put 105 | putConstPool cp = mapM_ putConst $ run cp where 106 | putConst c = do 107 | putWord8 . constTag $ c 108 | case c of 109 | (CUTF8 str) -> do 110 | -- TODO: This should be encoded to modified UTF-8 111 | -- Works for code points below 0xFFFFFF 112 | let encoded = encodeModifiedUtf8 str 113 | putI16 $ fromIntegral $ BL.length encoded 114 | putLazyByteString encoded 115 | (CValue (CInteger i)) -> 116 | putWord32be $ fromIntegral i -- TODO: Change to putInt32be 117 | (CValue (CString s)) -> 118 | putIx' $ CUTF8 s 119 | (CValue (CLong l)) -> 120 | putWord64be $ fromIntegral l -- TODO: Change to putInt64be 121 | (CValue (CFloat f)) -> 122 | putFloatbe f 123 | (CValue (CDouble d)) -> 124 | putDoublebe d 125 | (CClass (IClassName str)) -> 126 | putIx' $ CUTF8 str 127 | (CFieldRef (FieldRef cn n ft)) -> 128 | putRef cn n $ mkFieldDesc' ft 129 | (CMethodRef (MethodRef cn n fts rt)) -> 130 | putRef cn n $ mkMethodDesc' fts rt 131 | (CInterfaceMethodRef (MethodRef cn n fts rt)) -> 132 | putRef cn n $ mkMethodDesc' fts rt 133 | (CNameAndType (NameAndDesc (UName n) (Desc d))) -> do 134 | putIx' $ CUTF8 n 135 | putIx' $ CUTF8 d 136 | where 137 | putRef cn n d = do 138 | putIx' $ CClass cn 139 | putIx' . CNameAndType $ NameAndDesc n (Desc d) 140 | putIx' = putIx "putConstPool" cp 141 | 142 | getConstPool :: Int -> Get IxConstPool 143 | getConstPool n = do 144 | poolPairs <- decodeConsts 1 145 | -- Knot-tying for single-pass build of the constant pool 146 | return $ fix (\cp -> LazyMap.fromList $ map (second ($ cp)) poolPairs) 147 | where decodeConsts i 148 | | i > n = return [] 149 | | otherwise = do (f, di) <- getConst 150 | cs <- decodeConsts (i + di) 151 | return $ (i, f) : cs 152 | 153 | getConstAt :: (Integral a) => a -> IxConstPool -> Const 154 | getConstAt i cp = (!) cp $ fromIntegral i 155 | 156 | putConstAt :: (Integral a) => IxConstPool -> a -> Const -> IxConstPool 157 | putConstAt pool i c = LazyMap.insert (fromIntegral i) c pool 158 | 159 | getConst :: Get (IxConstPool -> Const, Int) 160 | getConst = do 161 | tag <- getWord8 162 | case tag of 163 | 1 -> do 164 | len <- getWord16be 165 | let len' = fromIntegral len 166 | bytes <- getByteString len' 167 | {- TODO: This fails for Unicode codepoints beyond U+FFFF 168 | because Modified-UTF8 doesn't support 4-byte 169 | representations and instead uses two-times-three-byte 170 | format. -} 171 | return (const $ CUTF8 $ decodeUtf8 bytes, 1) 172 | 3 -> do 173 | word <- getWord32be 174 | return (const $ CValue (CInteger (fromIntegral word)), 1) 175 | 4 -> do 176 | word <- getWord32be 177 | return (const $ CValue (CFloat (wordToFloat word)), 1) 178 | 5 -> do 179 | word <- getWord64be 180 | return (const $ CValue (CLong (fromIntegral word)), 2) 181 | 6 -> do 182 | word <- getWord64be 183 | return (const $ CValue (CDouble (wordToDouble word)), 2) 184 | 7 -> do 185 | textIx <- getWord16be 186 | return ( \cp -> let CUTF8 t = getConstAt textIx cp 187 | in CClass (IClassName t) 188 | , 1) 189 | 8 -> do 190 | textIx <- getWord16be 191 | return ( \cp -> let CUTF8 t = getConstAt textIx cp 192 | in CValue (CString t) 193 | , 1) 194 | 9 -> do 195 | classIx <- getWord16be 196 | nameAndTypeIx <- getWord16be 197 | return ( \cp -> let iclassName = case getConstAt classIx cp of 198 | CClass i -> i 199 | c -> error $ "Type 9 (FieldRef): " ++ show (classIx, nameAndTypeIx, c) 200 | CNameAndType (NameAndDesc uname (Desc desc)) = getConstAt nameAndTypeIx cp 201 | Just ft = decodeFieldDesc desc 202 | in CFieldRef $ FieldRef iclassName uname ft 203 | , 1) 204 | 10 -> do 205 | classIx <- getWord16be 206 | nameAndTypeIx <- getWord16be 207 | return ( \cp -> let CClass iclassName = getConstAt classIx cp 208 | CNameAndType (NameAndDesc uname (Desc desc)) = getConstAt nameAndTypeIx cp 209 | Just (fts, rft) = decodeMethodDesc desc 210 | in CMethodRef $ MethodRef iclassName uname fts rft 211 | , 1) 212 | 11 -> do 213 | classIx <- getWord16be 214 | nameAndTypeIx <- getWord16be 215 | return ( \cp -> let CClass iclassName = getConstAt classIx cp 216 | CNameAndType (NameAndDesc uname (Desc desc)) = getConstAt nameAndTypeIx cp 217 | Just (fts, rft) = decodeMethodDesc desc 218 | in CInterfaceMethodRef $ MethodRef iclassName uname fts rft 219 | , 1) 220 | 12 -> do 221 | nameIx <- getWord16be 222 | descriptorIx <- getWord16be 223 | return ( \cp -> let CUTF8 name' = getConstAt nameIx cp 224 | CUTF8 desc' = getConstAt descriptorIx cp 225 | in CNameAndType (NameAndDesc (UName name') (Desc desc')) 226 | , 1) 227 | -- TODO: Stubs. Support invokedynamic later. 228 | 15 -> do 229 | _ <- getWord8 230 | _ <- getWord16be 231 | return (const $ CUTF8 $ T.pack "MethodHandle", 1) 232 | 16 -> do 233 | _ <- getWord16be 234 | return (const $ CUTF8 $ T.pack "MethodType", 1) 235 | 18 -> do 236 | _ <- getWord16be 237 | _ <- getWord16be 238 | return (const $ CUTF8 $ T.pack "InvokeDynamic", 1) 239 | val -> error $ "getConst: " ++ show val 240 | -------------------------------------------------------------------------------- /src/Codec/JVM/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Codec.JVM.Encoding (encodeModifiedUtf8) where 3 | 4 | import Data.ByteString.Lazy as B 5 | import Data.ByteString.Search 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | import Data.Text.Encoding 9 | import Data.Char 10 | import Data.Monoid 11 | import Data.Bits 12 | 13 | {- TODO: This could probably be optimized. 14 | It was written assuming most strings will contain streams of BMP characters or 15 | supplementary characters. -} 16 | encodeModifiedUtf8 :: Text -> ByteString 17 | encodeModifiedUtf8 t = goUtf8 t 18 | where goUtf8 t 19 | | T.null t = mempty 20 | | otherwise = fromStrict (encodeUtf8 utf8) <> goOther other 21 | where (utf8, other) = T.break (\c -> ord c >= 0x10000 || c == '\NUL') t 22 | goOther t 23 | | T.null t = mempty 24 | | otherwise = enc other <> goUtf8 utf8 25 | where (p, enc) 26 | | c == '\NUL' = (\c -> c /= '\NUL', 27 | \t -> B.take (fromIntegral (2 * T.length t)) 28 | $ B.cycle zeroEncoding) 29 | | otherwise = (\c -> ord c < 0x10000, encodeSurrogates) 30 | (other, utf8) = T.break p t 31 | c = T.head t 32 | 33 | encodeSurrogates :: Text -> ByteString 34 | encodeSurrogates t = B.pack $ T.foldr (\c t -> calcSurrogates c <> t) [] t 35 | where calcSurrogates c = [0xED, bits1, bits2, 0xED, bits3, bits4] 36 | where sub = ord c - 0x10000 37 | bits1 = fromIntegral $ 0xA0 .|. (sub `shiftR` 16) 38 | bits2 = fromIntegral $ 0x80 .|. ((sub `shiftR` 10) .&. 0x3F) 39 | bits3 = fromIntegral $ 0xB0 .|. ((sub `shiftR` 6) .&. 0x0F) 40 | bits4 = fromIntegral $ 0x80 .|. (sub .&. 0x3F) 41 | 42 | zeroEncoding :: ByteString 43 | zeroEncoding = "\192\128" 44 | -------------------------------------------------------------------------------- /src/Codec/JVM/Field.hs: -------------------------------------------------------------------------------- 1 | module Codec.JVM.Field where 2 | 3 | import Data.Binary.Put (Put) 4 | import Data.Set (Set) 5 | 6 | import qualified Data.List as L 7 | 8 | import Codec.JVM.Attr (Attr, putAttr, unpackAttr) 9 | import Codec.JVM.Const (Const(CUTF8)) 10 | import Codec.JVM.ConstPool (ConstPool, putIx) 11 | import Codec.JVM.Internal (putI16) 12 | import Codec.JVM.Types 13 | 14 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.5 15 | data FieldInfo = FieldInfo 16 | { accessFlags :: Set AccessFlag 17 | , name :: UName 18 | , descriptor :: Desc 19 | , attributes :: [Attr] } 20 | deriving Show 21 | 22 | unpackFieldInfo :: FieldInfo -> [Const] 23 | unpackFieldInfo fi = unpackAttr =<< attributes fi 24 | 25 | putFieldInfo :: String -> ConstPool -> FieldInfo -> Put 26 | putFieldInfo debug cp fi = do 27 | putAccessFlags $ accessFlags fi 28 | case name fi of UName n -> putIx (putFieldMsg "name") cp $ CUTF8 n 29 | case descriptor fi of Desc d -> putIx (putFieldMsg "descriptor") cp $ CUTF8 d 30 | putI16 . L.length $ attributes fi 31 | mapM_ (putAttr (putFieldMsg "attributes") Nothing cp) $ attributes fi 32 | where putFieldMsg tag = "Field[" ++ tag ++ "][" ++ show (name fi) 33 | ++ "][" ++ debug ++ "]" 34 | -------------------------------------------------------------------------------- /src/Codec/JVM/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Codec.JVM.Internal 4 | ( module Data.Binary.Put, 5 | module Data.Binary.Get, 6 | module Codec.JVM.Internal ) 7 | where 8 | 9 | import Data.Binary.Get 10 | import Data.Binary.Put 11 | import Data.Bits (shiftR) 12 | import Data.ByteString (ByteString) 13 | import Data.Word (Word8, Word16, Word32, Word64) 14 | 15 | import Data.Array.ST (newArray, readArray, MArray, STUArray) 16 | import Data.Array.Unsafe (castSTUArray) 17 | import GHC.ST (runST, ST) 18 | 19 | import qualified Data.ByteString as BS 20 | 21 | packWord16be :: Word16 -> ByteString 22 | packWord16be w = BS.pack 23 | [ fromIntegral (shiftR w 8) :: Word8 24 | , fromIntegral w :: Word8 ] 25 | 26 | packWord32be :: Word32 -> ByteString 27 | packWord32be w = BS.pack 28 | [ fromIntegral (shiftR w 24) :: Word8 29 | , fromIntegral (shiftR w 16) :: Word8 30 | , fromIntegral (shiftR w 8) :: Word8 31 | , fromIntegral w :: Word8 ] 32 | 33 | packI16 :: Int -> ByteString 34 | packI16 = packWord16be . fromIntegral 35 | 36 | packI32 :: Int -> ByteString 37 | packI32 = packWord32be . fromIntegral 38 | 39 | putI16 :: Int -> Put 40 | putI16 = putWord16be . fromIntegral 41 | 42 | putI32 :: Int -> Put 43 | putI32 = putWord32be . fromIntegral 44 | 45 | -- TODO: Everything below is extracted from 46 | -- binary-8.4.0: Data.Binary.Put, Data.Binary.FloatCast. 47 | -- Due to stack supporting and older version in the current 48 | -- lts-6.6, we are unable to use that package. The functions 49 | -- below should be removed once Stackage LTS catches up. 50 | ------------------------------------------------------------------------ 51 | -- Floats/Doubles 52 | 53 | #if !MIN_VERSION_binary(0,8,4) 54 | 55 | -- | Write a 'Float' in big endian IEEE-754 format. 56 | putFloatbe :: Float -> Put 57 | putFloatbe = putWord32be . floatToWord 58 | {-# INLINE putFloatbe #-} 59 | 60 | -- | Write a 'Double' in big endian IEEE-754 format. 61 | putDoublebe :: Double -> Put 62 | putDoublebe = putWord64be . doubleToWord 63 | {-# INLINE putDoublebe #-} 64 | 65 | -- | Reinterpret-casts a `Float` to a `Word32`. 66 | floatToWord :: Float -> Word32 67 | floatToWord x = runST (cast x) 68 | {-# INLINE floatToWord #-} 69 | 70 | -- | Reinterpret-casts a `Double` to a `Word64`. 71 | doubleToWord :: Double -> Word64 72 | doubleToWord x = runST (cast x) 73 | {-# INLINE doubleToWord #-} 74 | 75 | #endif 76 | 77 | -- | Reinterpret-casts a `Word32` to a `Float`. 78 | wordToFloat :: Word32 -> Float 79 | wordToFloat x = runST (cast x) 80 | {-# INLINE wordToFloat #-} 81 | 82 | -- | Reinterpret-casts a `Word64` to a `Double`. 83 | wordToDouble :: Word64 -> Double 84 | wordToDouble x = runST (cast x) 85 | {-# INLINE wordToDouble #-} 86 | 87 | cast :: (MArray (STUArray s) a (ST s), 88 | MArray (STUArray s) b (ST s)) => a -> ST s b 89 | cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 90 | {-# INLINE cast #-} 91 | 92 | -- TODO: Currently not working 93 | -- -- | Write a Int32 in big endian format 94 | -- putInt32be :: Int32 -> Put 95 | -- putInt32be = putBuilder . B.int32BE 96 | -- {-# INLINE putInt32be #-} 97 | 98 | -- -- | Write a Int64 in big endian format 99 | -- putInt64be :: Int64 -> Put 100 | -- putInt64be = putBuilder . B.int64BE 101 | -- {-# INLINE putInt64be #-} 102 | -------------------------------------------------------------------------------- /src/Codec/JVM/Method.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Codec.JVM.Method where 3 | 4 | import Data.Set (Set) 5 | import qualified Data.List as L 6 | 7 | import Codec.JVM.Attr 8 | import Codec.JVM.Const 9 | import Codec.JVM.ASM.Code 10 | import Codec.JVM.ConstPool 11 | import Codec.JVM.Internal 12 | import Codec.JVM.Types 13 | 14 | 15 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.6 16 | 17 | data MethodInfo = MethodInfo 18 | { miAccessFlags :: Set AccessFlag 19 | , miName :: UName 20 | , miDescriptor :: Desc 21 | , miCode :: Code 22 | , miAttributes :: [Attr] } 23 | deriving Show 24 | 25 | -- TODO: This is very ugly hack 26 | unpackMethodInfo :: MethodInfo -> [Const] 27 | unpackMethodInfo _ = [ CUTF8 $ attrName (ACode a a a a a) 28 | , CUTF8 $ attrName (AStackMapTable a) 29 | , CUTF8 $ attrName (ALineNumberTable a)] 30 | where a = undefined 31 | 32 | putMethodInfo :: String -> ConstPool -> MethodInfo -> Put 33 | putMethodInfo debug cp MethodInfo { miName = UName methodName 34 | , miDescriptor = Desc methodDescriptor 35 | , .. } = do 36 | putAccessFlags miAccessFlags 37 | putIx "putMethodInfo[name]" cp $ CUTF8 methodName 38 | putIx "putMethodInfo[descriptor]" cp $ CUTF8 methodDescriptor 39 | putI16 . L.length $ attributes 40 | mapM_ (putAttr ("Method[" ++ show methodName ++ "][" ++ debug ++ "]") Nothing cp) attributes 41 | where attributes = toAttrs cp miCode ++ miAttributes 42 | -------------------------------------------------------------------------------- /src/Codec/JVM/Opcode.hs: -------------------------------------------------------------------------------- 1 | module Codec.JVM.Opcode where 2 | 3 | import Data.Word (Word8) 4 | 5 | newtype Opcode = Opcode Int 6 | deriving (Eq, Show) 7 | 8 | opcode :: Opcode -> Word8 9 | opcode (Opcode i) = fromIntegral i 10 | 11 | -- | https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html 12 | 13 | nop :: Opcode 14 | aconst_null :: Opcode 15 | iconst_m1 :: Opcode 16 | iconst_0 :: Opcode 17 | iconst_1 :: Opcode 18 | iconst_2 :: Opcode 19 | iconst_3 :: Opcode 20 | iconst_4 :: Opcode 21 | iconst_5 :: Opcode 22 | lconst_0 :: Opcode 23 | lconst_1 :: Opcode 24 | fconst_0 :: Opcode 25 | fconst_1 :: Opcode 26 | fconst_2 :: Opcode 27 | dconst_0 :: Opcode 28 | dconst_1 :: Opcode 29 | bipush :: Opcode 30 | sipush :: Opcode 31 | ldc :: Opcode 32 | ldc_w :: Opcode 33 | ldc2_w :: Opcode 34 | iload :: Opcode 35 | lload :: Opcode 36 | fload :: Opcode 37 | dload :: Opcode 38 | aload :: Opcode 39 | iload_0 :: Opcode 40 | iload_1 :: Opcode 41 | iload_2 :: Opcode 42 | iload_3 :: Opcode 43 | lload_0 :: Opcode 44 | lload_1 :: Opcode 45 | lload_2 :: Opcode 46 | lload_3 :: Opcode 47 | fload_0 :: Opcode 48 | fload_1 :: Opcode 49 | fload_2 :: Opcode 50 | fload_3 :: Opcode 51 | dload_0 :: Opcode 52 | dload_1 :: Opcode 53 | dload_2 :: Opcode 54 | dload_3 :: Opcode 55 | aload_0 :: Opcode 56 | aload_1 :: Opcode 57 | aload_2 :: Opcode 58 | aload_3 :: Opcode 59 | iaload :: Opcode 60 | laload :: Opcode 61 | faload :: Opcode 62 | daload :: Opcode 63 | aaload :: Opcode 64 | baload :: Opcode 65 | caload :: Opcode 66 | saload :: Opcode 67 | istore :: Opcode 68 | lstore :: Opcode 69 | fstore :: Opcode 70 | dstore :: Opcode 71 | astore :: Opcode 72 | istore_0 :: Opcode 73 | istore_1 :: Opcode 74 | istore_2 :: Opcode 75 | istore_3 :: Opcode 76 | lstore_0 :: Opcode 77 | lstore_1 :: Opcode 78 | lstore_2 :: Opcode 79 | lstore_3 :: Opcode 80 | fstore_0 :: Opcode 81 | fstore_1 :: Opcode 82 | fstore_2 :: Opcode 83 | fstore_3 :: Opcode 84 | dstore_0 :: Opcode 85 | dstore_1 :: Opcode 86 | dstore_2 :: Opcode 87 | dstore_3 :: Opcode 88 | astore_0 :: Opcode 89 | astore_1 :: Opcode 90 | astore_2 :: Opcode 91 | astore_3 :: Opcode 92 | iastore :: Opcode 93 | lastore :: Opcode 94 | fastore :: Opcode 95 | dastore :: Opcode 96 | aastore :: Opcode 97 | bastore :: Opcode 98 | castore :: Opcode 99 | sastore :: Opcode 100 | pop :: Opcode 101 | pop2 :: Opcode 102 | dup :: Opcode 103 | dup_x1 :: Opcode 104 | dup_x2 :: Opcode 105 | dup2 :: Opcode 106 | dup2_x1 :: Opcode 107 | dup2_x2 :: Opcode 108 | swap :: Opcode 109 | iadd :: Opcode 110 | ladd :: Opcode 111 | fadd :: Opcode 112 | dadd :: Opcode 113 | isub :: Opcode 114 | lsub :: Opcode 115 | fsub :: Opcode 116 | dsub :: Opcode 117 | imul :: Opcode 118 | lmul :: Opcode 119 | fmul :: Opcode 120 | dmul :: Opcode 121 | idiv :: Opcode 122 | ldiv :: Opcode 123 | fdiv :: Opcode 124 | ddiv :: Opcode 125 | irem :: Opcode 126 | lrem :: Opcode 127 | frem :: Opcode 128 | drem :: Opcode 129 | ineg :: Opcode 130 | lneg :: Opcode 131 | fneg :: Opcode 132 | dneg :: Opcode 133 | ishl :: Opcode 134 | lshl :: Opcode 135 | ishr :: Opcode 136 | lshr :: Opcode 137 | iushr :: Opcode 138 | lushr :: Opcode 139 | iand :: Opcode 140 | land :: Opcode 141 | ior :: Opcode 142 | lor :: Opcode 143 | ixor :: Opcode 144 | lxor :: Opcode 145 | iinc :: Opcode 146 | i2l :: Opcode 147 | i2f :: Opcode 148 | i2d :: Opcode 149 | l2i :: Opcode 150 | l2f :: Opcode 151 | l2d :: Opcode 152 | f2i :: Opcode 153 | f2l :: Opcode 154 | f2d :: Opcode 155 | d2i :: Opcode 156 | d2l :: Opcode 157 | d2f :: Opcode 158 | i2b :: Opcode 159 | i2c :: Opcode 160 | i2s :: Opcode 161 | lcmp :: Opcode 162 | fcmpl :: Opcode 163 | fcmpg :: Opcode 164 | dcmpl :: Opcode 165 | dcmpg :: Opcode 166 | ifeq :: Opcode 167 | ifne :: Opcode 168 | iflt :: Opcode 169 | ifge :: Opcode 170 | ifgt :: Opcode 171 | ifle :: Opcode 172 | if_icmpeq :: Opcode 173 | if_icmpne :: Opcode 174 | if_icmplt :: Opcode 175 | if_icmpge :: Opcode 176 | if_icmpgt :: Opcode 177 | if_icmple :: Opcode 178 | if_acmpeq :: Opcode 179 | if_acmpne :: Opcode 180 | goto :: Opcode 181 | jsr :: Opcode 182 | ret :: Opcode 183 | tableswitch :: Opcode 184 | lookupswitch :: Opcode 185 | ireturn :: Opcode 186 | lreturn :: Opcode 187 | freturn :: Opcode 188 | dreturn :: Opcode 189 | areturn :: Opcode 190 | vreturn :: Opcode -- return 191 | getstatic :: Opcode 192 | putstatic :: Opcode 193 | getfield :: Opcode 194 | putfield :: Opcode 195 | invokevirtual :: Opcode 196 | invokespecial :: Opcode 197 | invokestatic :: Opcode 198 | invokeinterface :: Opcode 199 | invokedynamic :: Opcode 200 | new :: Opcode 201 | newarray :: Opcode 202 | anewarray :: Opcode 203 | arraylength :: Opcode 204 | athrow :: Opcode 205 | checkcast :: Opcode 206 | instanceof :: Opcode 207 | monitorenter :: Opcode 208 | monitorexit :: Opcode 209 | wide :: Opcode 210 | multianewarray :: Opcode 211 | ifnull :: Opcode 212 | ifnonnull :: Opcode 213 | goto_w :: Opcode 214 | jsr_w :: Opcode 215 | 216 | nop = Opcode 0x00 217 | aconst_null = Opcode 0x01 218 | iconst_m1 = Opcode 0x02 219 | iconst_0 = Opcode 0x03 220 | iconst_1 = Opcode 0x04 221 | iconst_2 = Opcode 0x05 222 | iconst_3 = Opcode 0x06 223 | iconst_4 = Opcode 0x07 224 | iconst_5 = Opcode 0x08 225 | lconst_0 = Opcode 0x09 226 | lconst_1 = Opcode 0x0a 227 | fconst_0 = Opcode 0x0b 228 | fconst_1 = Opcode 0x0c 229 | fconst_2 = Opcode 0x0d 230 | dconst_0 = Opcode 0x0e 231 | dconst_1 = Opcode 0x0f 232 | bipush = Opcode 0x10 233 | sipush = Opcode 0x11 234 | ldc = Opcode 0x12 235 | ldc_w = Opcode 0x13 236 | ldc2_w = Opcode 0x14 237 | iload = Opcode 0x15 238 | lload = Opcode 0x16 239 | fload = Opcode 0x17 240 | dload = Opcode 0x18 241 | aload = Opcode 0x19 242 | iload_0 = Opcode 0x1a 243 | iload_1 = Opcode 0x1b 244 | iload_2 = Opcode 0x1c 245 | iload_3 = Opcode 0x1d 246 | lload_0 = Opcode 0x1e 247 | lload_1 = Opcode 0x1f 248 | lload_2 = Opcode 0x20 249 | lload_3 = Opcode 0x21 250 | fload_0 = Opcode 0x22 251 | fload_1 = Opcode 0x23 252 | fload_2 = Opcode 0x24 253 | fload_3 = Opcode 0x25 254 | dload_0 = Opcode 0x26 255 | dload_1 = Opcode 0x27 256 | dload_2 = Opcode 0x28 257 | dload_3 = Opcode 0x29 258 | aload_0 = Opcode 0x2a 259 | aload_1 = Opcode 0x2b 260 | aload_2 = Opcode 0x2c 261 | aload_3 = Opcode 0x2d 262 | iaload = Opcode 0x2e 263 | laload = Opcode 0x2f 264 | faload = Opcode 0x30 265 | daload = Opcode 0x31 266 | aaload = Opcode 0x32 267 | baload = Opcode 0x33 268 | caload = Opcode 0x34 269 | saload = Opcode 0x35 270 | istore = Opcode 0x36 271 | lstore = Opcode 0x37 272 | fstore = Opcode 0x38 273 | dstore = Opcode 0x39 274 | astore = Opcode 0x3a 275 | istore_0 = Opcode 0x3b 276 | istore_1 = Opcode 0x3c 277 | istore_2 = Opcode 0x3d 278 | istore_3 = Opcode 0x3e 279 | lstore_0 = Opcode 0x3f 280 | lstore_1 = Opcode 0x40 281 | lstore_2 = Opcode 0x41 282 | lstore_3 = Opcode 0x42 283 | fstore_0 = Opcode 0x43 284 | fstore_1 = Opcode 0x44 285 | fstore_2 = Opcode 0x45 286 | fstore_3 = Opcode 0x46 287 | dstore_0 = Opcode 0x47 288 | dstore_1 = Opcode 0x48 289 | dstore_2 = Opcode 0x49 290 | dstore_3 = Opcode 0x4a 291 | astore_0 = Opcode 0x4b 292 | astore_1 = Opcode 0x4c 293 | astore_2 = Opcode 0x4d 294 | astore_3 = Opcode 0x4e 295 | iastore = Opcode 0x4f 296 | lastore = Opcode 0x50 297 | fastore = Opcode 0x51 298 | dastore = Opcode 0x52 299 | aastore = Opcode 0x53 300 | bastore = Opcode 0x54 301 | castore = Opcode 0x55 302 | sastore = Opcode 0x56 303 | pop = Opcode 0x57 304 | pop2 = Opcode 0x58 305 | dup = Opcode 0x59 306 | dup_x1 = Opcode 0x5a 307 | dup_x2 = Opcode 0x5b 308 | dup2 = Opcode 0x5c 309 | dup2_x1 = Opcode 0x5d 310 | dup2_x2 = Opcode 0x5e 311 | swap = Opcode 0x5f 312 | iadd = Opcode 0x60 313 | ladd = Opcode 0x61 314 | fadd = Opcode 0x62 315 | dadd = Opcode 0x63 316 | isub = Opcode 0x64 317 | lsub = Opcode 0x65 318 | fsub = Opcode 0x66 319 | dsub = Opcode 0x67 320 | imul = Opcode 0x68 321 | lmul = Opcode 0x69 322 | fmul = Opcode 0x6a 323 | dmul = Opcode 0x6b 324 | idiv = Opcode 0x6c 325 | ldiv = Opcode 0x6d 326 | fdiv = Opcode 0x6e 327 | ddiv = Opcode 0x6f 328 | irem = Opcode 0x70 329 | lrem = Opcode 0x71 330 | frem = Opcode 0x72 331 | drem = Opcode 0x73 332 | ineg = Opcode 0x74 333 | lneg = Opcode 0x75 334 | fneg = Opcode 0x76 335 | dneg = Opcode 0x77 336 | ishl = Opcode 0x78 337 | lshl = Opcode 0x79 338 | ishr = Opcode 0x7a 339 | lshr = Opcode 0x7b 340 | iushr = Opcode 0x7c 341 | lushr = Opcode 0x7d 342 | iand = Opcode 0x7e 343 | land = Opcode 0x7f 344 | ior = Opcode 0x80 345 | lor = Opcode 0x81 346 | ixor = Opcode 0x82 347 | lxor = Opcode 0x83 348 | iinc = Opcode 0x84 349 | i2l = Opcode 0x85 350 | i2f = Opcode 0x86 351 | i2d = Opcode 0x87 352 | l2i = Opcode 0x88 353 | l2f = Opcode 0x89 354 | l2d = Opcode 0x8a 355 | f2i = Opcode 0x8b 356 | f2l = Opcode 0x8c 357 | f2d = Opcode 0x8d 358 | d2i = Opcode 0x8e 359 | d2l = Opcode 0x8f 360 | d2f = Opcode 0x90 361 | i2b = Opcode 0x91 362 | i2c = Opcode 0x92 363 | i2s = Opcode 0x93 364 | lcmp = Opcode 0x94 365 | fcmpl = Opcode 0x95 366 | fcmpg = Opcode 0x96 367 | dcmpl = Opcode 0x97 368 | dcmpg = Opcode 0x98 369 | ifeq = Opcode 0x99 370 | ifne = Opcode 0x9a 371 | iflt = Opcode 0x9b 372 | ifge = Opcode 0x9c 373 | ifgt = Opcode 0x9d 374 | ifle = Opcode 0x9e 375 | if_icmpeq = Opcode 0x9f 376 | if_icmpne = Opcode 0xa0 377 | if_icmplt = Opcode 0xa1 378 | if_icmpge = Opcode 0xa2 379 | if_icmpgt = Opcode 0xa3 380 | if_icmple = Opcode 0xa4 381 | if_acmpeq = Opcode 0xa5 382 | if_acmpne = Opcode 0xa6 383 | goto = Opcode 0xa7 384 | jsr = Opcode 0xa8 385 | ret = Opcode 0xa9 386 | tableswitch = Opcode 0xaa 387 | lookupswitch = Opcode 0xab 388 | ireturn = Opcode 0xac 389 | lreturn = Opcode 0xad 390 | freturn = Opcode 0xae 391 | dreturn = Opcode 0xaf 392 | areturn = Opcode 0xb0 393 | vreturn = Opcode 0xb1 -- return 394 | getstatic = Opcode 0xb2 395 | putstatic = Opcode 0xb3 396 | getfield = Opcode 0xb4 397 | putfield = Opcode 0xb5 398 | invokevirtual = Opcode 0xb6 399 | invokespecial = Opcode 0xb7 400 | invokestatic = Opcode 0xb8 401 | invokeinterface = Opcode 0xb9 402 | invokedynamic = Opcode 0xba 403 | new = Opcode 0xbb 404 | newarray = Opcode 0xbc 405 | anewarray = Opcode 0xbd 406 | arraylength = Opcode 0xbe 407 | athrow = Opcode 0xbf 408 | checkcast = Opcode 0xc0 409 | instanceof = Opcode 0xc1 410 | monitorenter = Opcode 0xc2 411 | monitorexit = Opcode 0xc3 412 | wide = Opcode 0xc4 413 | multianewarray = Opcode 0xc5 414 | ifnull = Opcode 0xc6 415 | ifnonnull = Opcode 0xc7 416 | goto_w = Opcode 0xc8 417 | jsr_w = Opcode 0xc9 418 | -------------------------------------------------------------------------------- /src/Codec/JVM/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Codec.JVM.Parse where 3 | 4 | import Data.Binary.Get 5 | import Data.Maybe (catMaybes) 6 | import Data.Text (Text) 7 | import Data.Word (Word32,Word16,Word8) 8 | 9 | import qualified Data.Text as T 10 | import qualified Data.ByteString.Lazy as BL 11 | import Control.Monad (when,replicateM) 12 | import Control.Applicative (some) 13 | 14 | import Codec.JVM.Attr 15 | import Codec.JVM.Const 16 | import Codec.JVM.ConstPool 17 | import Codec.JVM.Field as F 18 | import Codec.JVM.Method 19 | import Codec.JVM.Types 20 | import Text.ParserCombinators.ReadP 21 | 22 | -- TODO: abstract out the replicateM bit 23 | 24 | -- TODO: need to recycle/merge this with Method.hs 25 | 26 | data Info = Info 27 | { interfaces :: [InterfaceName] 28 | , fieldInfos :: [FieldInfo] 29 | , methodInfos :: [MethodInfo] 30 | , classAttributes :: [Attr]} 31 | deriving Show 32 | 33 | mAGIC :: Word32 34 | mAGIC = 0xCAFEBABE 35 | 36 | parseClassFileHeaders :: Get (ClassName,SuperClassName,[InterfaceName], IxConstPool) 37 | parseClassFileHeaders = do 38 | magic <- getWord32be 39 | when (magic /= mAGIC) $ 40 | fail $ "Invalid .class file MAGIC value: " ++ show magic 41 | _minorVersion <- getWord16be 42 | _majorVersion <- getWord16be 43 | poolSize <- getWord16be 44 | pool <- getConstPool $ fromIntegral $ poolSize - 1 45 | _afs <- getAccessFlags ATClass 46 | classIdx <- getWord16be 47 | let CClass (IClassName iclsName) = getConstAt classIdx pool 48 | superClassIdx <- getWord16be 49 | let CClass (IClassName isuperClsName) = getConstAt superClassIdx pool 50 | interfacesCount <- getWord16be 51 | interfaceNames <- parseInterfaces pool interfacesCount -- :: [InterfaceName] 52 | return (iclsName,isuperClsName,interfaceNames, pool) 53 | 54 | parse :: FilePath -> IO (ClassName, Info) 55 | parse fp = do 56 | bs <- BL.readFile fp 57 | return $ runGet parseClassFile bs 58 | 59 | parsePool :: FilePath -> IO IxConstPool 60 | parsePool fp = do 61 | bs <- BL.readFile fp 62 | let (_, _, _, pool) = runGet parseClassFileHeaders bs 63 | return pool 64 | 65 | parseClassFile :: Get (ClassName,Info) 66 | parseClassFile = do 67 | (iclsName, isuperClsName, interfaceNames, pool) <- parseClassFileHeaders 68 | fieldsCount <- getWord16be 69 | fis <- parseFields pool fieldsCount 70 | methodsCount <- getWord16be 71 | mis <- parseMethods pool methodsCount 72 | attributesCount <- getWord16be 73 | parseAttributes <- parseClassAttributes pool attributesCount 74 | return (iclsName, Info { interfaces = interfaceNames 75 | , fieldInfos = fis 76 | , methodInfos = mis 77 | , classAttributes = parseAttributes}) 78 | 79 | parseClassAttributes :: IxConstPool -> Word16 -> Get [Attr] 80 | parseClassAttributes pool n = fmap catMaybes 81 | $ replicateM (fromIntegral n) $ parseClassAttribute pool 82 | 83 | parseClassAttribute :: IxConstPool -> Get (Maybe Attr) 84 | parseClassAttribute pool = do 85 | attribute_name_index <- getWord16be 86 | attribute_length <- getWord32be 87 | let CUTF8 attributeName = getConstAt attribute_name_index pool 88 | case attributeName of 89 | "Signature" -> fmap Just $ parseClassSignature pool 90 | _ -> skip (fromIntegral attribute_length) >> return Nothing 91 | 92 | parseInterfaces :: IxConstPool -> Word16 -> Get [InterfaceName] 93 | parseInterfaces pool n = replicateM (fromIntegral n) $ parseInterface pool 94 | 95 | parseInterface :: IxConstPool -> Get InterfaceName 96 | parseInterface pool = do 97 | _tag <- getWord8 98 | name_index <- getWord16be 99 | let (CUTF8 interfaceName) = getConstAt name_index pool 100 | return interfaceName 101 | 102 | parseFields :: IxConstPool -> Word16 -> Get [FieldInfo] 103 | parseFields pool n = replicateM (fromIntegral n) $ parseField pool 104 | 105 | parseField :: IxConstPool -> Get FieldInfo 106 | parseField cp = do 107 | access_flags <- getAccessFlags ATField 108 | name_index <- getWord16be 109 | descriptor_index <- getWord16be 110 | attributes_count <- getWord16be 111 | parse_attributes <- parseFieldAttributes cp attributes_count 112 | return $ FieldInfo { 113 | F.accessFlags = access_flags, 114 | F.name = parseName cp name_index, 115 | F.descriptor = parseDescriptor cp descriptor_index, 116 | F.attributes = parse_attributes 117 | } 118 | 119 | parseName :: IxConstPool -> Word16 -> UName 120 | parseName pool idx 121 | | CUTF8 methodName <- getConstAt idx pool 122 | = UName methodName 123 | | otherwise = error $ "parseName: Invalid constant pool index (" ++ show idx ++ ")" 124 | 125 | parseDescriptor :: IxConstPool -> Word16 -> Desc 126 | parseDescriptor pool idx 127 | | CUTF8 desc <- getConstAt idx pool 128 | = Desc desc 129 | | otherwise = error $ "parseDescriptor: Invalid constant pool idx (" ++ show idx ++ ")" 130 | 131 | parseFieldAttributes :: IxConstPool -> Word16 -> Get [Attr] 132 | parseFieldAttributes pool n = fmap catMaybes $ 133 | replicateM (fromIntegral n) $ parseFieldAttribute pool 134 | 135 | parseFieldAttribute :: IxConstPool -> Get (Maybe Attr) 136 | parseFieldAttribute pool = do 137 | attribute_name_index <- getWord16be 138 | attribute_length <- getWord32be 139 | let CUTF8 attributeName = getConstAt attribute_name_index pool 140 | case attributeName of 141 | "ConstantValue" -> fmap Just $ parseConstantValue pool 142 | "Signature" -> fmap Just $ parseFieldSignature pool 143 | _ -> skip (fromIntegral attribute_length) >> return Nothing 144 | 145 | showText :: Show a => a -> Text 146 | showText = T.pack . show 147 | 148 | munch1Text :: (Char -> Bool) -> ReadP Text 149 | munch1Text predicate = fmap T.pack $ munch1 predicate 150 | 151 | parseConstantValue :: IxConstPool -> Get Attr 152 | parseConstantValue pool = do 153 | constant_value_index <- getWord16be 154 | let (CValue x) = getConstAt constant_value_index pool 155 | case x of 156 | CString s -> return $ AConstantValue s 157 | CInteger i -> return $ AConstantValue $ showText i 158 | CLong l -> return $ AConstantValue $ showText l 159 | CFloat f -> return $ AConstantValue $ showText f 160 | CDouble d -> return $ AConstantValue $ showText d 161 | 162 | parseMethods :: IxConstPool -> Word16 -> Get [MethodInfo] 163 | parseMethods pool n = replicateM (fromIntegral n) $ parseMethod pool 164 | 165 | parseMethod :: IxConstPool -> Get MethodInfo 166 | parseMethod cp = do 167 | access_flags <- getAccessFlags ATMethod 168 | name_index <- getWord16be 169 | descriptor_index <- getWord16be 170 | attributes_count <- getWord16be 171 | parse_attributes <- parseMethodAttributes cp attributes_count 172 | return $ MethodInfo { 173 | miAccessFlags = access_flags, 174 | miName = parseName cp name_index, 175 | miDescriptor = parseDescriptor cp descriptor_index, 176 | miCode = mempty, -- TODO: Parse method bytecode 177 | miAttributes = parse_attributes 178 | } 179 | 180 | parseMethodAttributes :: IxConstPool -> Word16 -> Get [Attr] 181 | parseMethodAttributes pool n = fmap catMaybes 182 | $ replicateM (fromIntegral n) $ parseMethodAttribute pool 183 | 184 | parseMethodAttribute :: IxConstPool -> Get (Maybe Attr) 185 | parseMethodAttribute pool = do 186 | attribute_name_index <- getWord16be 187 | attribute_length <- getWord32be 188 | let (CUTF8 attribute_name) = getConstAt attribute_name_index pool 189 | case attribute_name of 190 | "Signature" -> fmap Just $ parseMethodSignature pool 191 | "MethodParameters" -> fmap Just $ parseMethodParameters pool 192 | _ -> skip (fromIntegral attribute_length) >> return Nothing 193 | 194 | parseMethodParameters :: IxConstPool -> Get Attr 195 | parseMethodParameters pool = do 196 | parameters_count <- getWord8 197 | parameters <- parseMParameters pool parameters_count 198 | return $ AMethodParam parameters 199 | 200 | parseMParameters :: IxConstPool -> Word8 -> Get [MParameter] 201 | parseMParameters pool n = replicateM (fromIntegral n) $ parseMethodParameter pool 202 | 203 | parseMethodParameter :: IxConstPool -> Get MParameter 204 | parseMethodParameter pool = do 205 | name_index <- getWord16be 206 | access_flags <- getAccessFlags ATMethodParam 207 | let CUTF8 parameterName = getConstAt name_index pool 208 | return (parameterName,access_flags) 209 | 210 | parseSignature :: ReadP a -> Text -> a 211 | parseSignature parse text = fst $ last $ readP_to_S parse $ T.unpack text 212 | 213 | parseClassSignature :: IxConstPool -> Get Attr 214 | parseClassSignature pool = do 215 | signature_index <- getWord16be 216 | let (CUTF8 signature) = getConstAt signature_index pool 217 | return $ ASignature $ ClassSig $ parseSignature parseClassSig signature 218 | 219 | parseClassSig :: ReadP (ClassSignature TypeVariable) 220 | parseClassSig = do 221 | tyVarDecls <- option [] parseTypeVariableDeclarations 222 | classParams <- some parseReferenceParameter 223 | return $ ClassSignature tyVarDecls classParams 224 | 225 | parseMethodSignature :: IxConstPool -> Get Attr 226 | parseMethodSignature pool = do 227 | signature_index <- getWord16be 228 | let (CUTF8 signature) = getConstAt signature_index pool 229 | return $ ASignature $ MethodSig $ parseSignature parseMethodSig signature 230 | 231 | parseMethodSig :: ReadP (MethodSignature TypeVariable) 232 | parseMethodSig = do 233 | tyVarDecls <- option [] parseTypeVariableDeclarations 234 | char '(' 235 | methodParams <- many parseJavaType 236 | char ')' 237 | methodReturn <- fmap Just parseJavaType <++ (char 'V' >> return Nothing) 238 | throwsExceptions <- many (char '^' >> parseReferenceParameter) 239 | return $ MethodSignature tyVarDecls methodParams methodReturn throwsExceptions 240 | 241 | parseFieldSignature :: IxConstPool -> Get Attr 242 | parseFieldSignature pool = do 243 | signature_index <- getWord16be 244 | let (CUTF8 signature) = getConstAt signature_index pool 245 | parseFieldSig = fmap FieldSignature parseReferenceParameter 246 | return $ ASignature $ FieldSig $ parseSignature parseFieldSig signature 247 | 248 | parseTypeVariableDeclarations :: ReadP (TypeVariableDeclarations TypeVariable) 249 | parseTypeVariableDeclarations = do 250 | char '<' 251 | tyVarDecls <- some parseTypeVariableDeclaration 252 | char '>' 253 | return tyVarDecls 254 | 255 | parseTypeVariableDeclaration :: ReadP (TypeVariableDeclaration TypeVariable) 256 | parseTypeVariableDeclaration = do 257 | identifier <- munch1Text (/= ':') 258 | bounds <- many parseTypeParameterBound 259 | return $ TypeVariableDeclaration identifier bounds 260 | 261 | parseTypeParameterBound :: ReadP (Bound TypeVariable) 262 | parseTypeParameterBound = do 263 | char ':' 264 | refParam <- parseReferenceParameter 265 | return $ ExtendsBound refParam 266 | 267 | parseReferenceParameter :: ReadP (ReferenceParameter TypeVariable) 268 | parseReferenceParameter = parseGenericRefType 269 | <++ parseSingleTypeVariable 270 | <++ parseArrayRefType 271 | 272 | parseGenericRefType :: ReadP (ReferenceParameter TypeVariable) 273 | parseGenericRefType = do 274 | char 'L' 275 | identifier <- munch1Text (\c -> c /= '<' && c /= ';') 276 | typeArgs <- option [] $ do 277 | char '<' 278 | typeArgs <- some parseTypeParameter 279 | char '>' 280 | return typeArgs 281 | -- TODO: Parse generic inner classes 282 | char ';' 283 | return $ GenericReferenceParameter (IClassName identifier) typeArgs [] 284 | 285 | parseSingleTypeVariable :: ReadP (ReferenceParameter TypeVariable) 286 | parseSingleTypeVariable = do 287 | char 'T' 288 | typeVariable <- munch1Text (/= ';') 289 | char ';' 290 | return $ VariableReferenceParameter typeVariable 291 | 292 | parseArrayRefType :: ReadP (ReferenceParameter TypeVariable) 293 | parseArrayRefType = do 294 | char '[' 295 | param <- parseJavaType 296 | return $ ArrayReferenceParameter param 297 | 298 | parseTypeParameter :: ReadP (TypeParameter TypeVariable) 299 | parseTypeParameter = fmap WildcardTypeParameter parseWildCard 300 | <++ fmap SimpleTypeParameter parseReferenceParameter 301 | 302 | parseWildCard :: ReadP (Bound TypeVariable) 303 | parseWildCard = parseSimpleWildCard 304 | <++ parseGenExtendsClass 305 | <++ parseGenSuperClass 306 | 307 | parseSimpleWildCard :: ReadP (Bound TypeVariable) 308 | parseSimpleWildCard = do 309 | _ <- char '*' 310 | return NotBounded 311 | 312 | parseGenExtendsClass :: ReadP (Bound TypeVariable) 313 | parseGenExtendsClass = do 314 | char '+' 315 | refParam <- parseReferenceParameter 316 | return $ ExtendsBound $ refParam 317 | 318 | parseGenSuperClass :: ReadP (Bound TypeVariable) 319 | parseGenSuperClass = do 320 | char '-' 321 | refParam <- parseReferenceParameter 322 | return $ SuperBound $ refParam 323 | 324 | parseJavaType :: ReadP (Parameter TypeVariable) 325 | parseJavaType = fmap ReferenceParameter parseReferenceParameter 326 | <++ fmap PrimitiveParameter parsePrimitiveType 327 | 328 | parsePrimitiveType :: ReadP PrimType 329 | parsePrimitiveType = do 330 | x <- get 331 | case x of 332 | 'B' -> return $ JByte 333 | 'C' -> return $ JChar 334 | 'D' -> return $ JDouble 335 | 'F' -> return $ JFloat 336 | 'I' -> return $ JInt 337 | 'J' -> return $ JLong 338 | 'S' -> return $ JShort 339 | 'Z' -> return $ JBool 340 | _ -> fail "Nothing" 341 | -------------------------------------------------------------------------------- /src/Codec/JVM/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Codec.JVM.Types where 4 | 5 | import Codec.JVM.Internal 6 | import Data.Set (Set) 7 | import Data.Word (Word16) 8 | import Data.Text (Text) 9 | import Data.String (IsString) 10 | import Data.Maybe (mapMaybe) 11 | import Data.Bits 12 | import Data.List 13 | 14 | import qualified Data.Set as S 15 | import qualified Data.Text as Text 16 | 17 | data PrimType 18 | = JByte 19 | | JChar 20 | | JDouble 21 | | JFloat 22 | | JInt 23 | | JLong 24 | | JShort 25 | | JBool 26 | deriving (Eq, Ord, Show) 27 | 28 | jbyte, jchar, jdouble, jfloat, jint, jlong, jshort, jbool, jobject :: FieldType 29 | jbyte = BaseType JByte 30 | jchar = BaseType JChar 31 | jdouble = BaseType JDouble 32 | jfloat = BaseType JFloat 33 | jint = BaseType JInt 34 | jlong = BaseType JLong 35 | jshort = BaseType JShort 36 | jbool = BaseType JBool 37 | jobject = ObjectType jlObject 38 | 39 | jarray :: FieldType -> FieldType 40 | jarray = ArrayType 41 | 42 | baseType :: FieldType -> PrimType 43 | baseType (BaseType pt) = pt 44 | baseType _ = error "baseType: Not base type!" 45 | 46 | jstring :: FieldType 47 | jstring = ObjectType jlString 48 | 49 | jstringC :: Text 50 | jstringC = "java/lang/String" 51 | 52 | jobjectC :: Text 53 | jobjectC = "java/lang/Object" 54 | 55 | jlObject :: IClassName 56 | jlObject = IClassName jobjectC 57 | 58 | jlString :: IClassName 59 | jlString = IClassName jstringC 60 | 61 | -- | Binary class names in their internal form. 62 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.2.1 63 | newtype IClassName = IClassName { unIClassName :: Text } 64 | deriving (Eq, Ord, Show, IsString) 65 | 66 | -- | Unqualified name 67 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms4.html#jvms-4.2.2 68 | newtype UName = UName Text 69 | deriving (Eq, Ord, Show, IsString) 70 | 71 | -- | Field descriptor 72 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.3.2 73 | newtype FieldDesc = FieldDesc Text 74 | deriving (Eq, Ord, Show) 75 | 76 | data FieldType = BaseType PrimType | ObjectType IClassName | ArrayType FieldType 77 | deriving (Eq, Ord, Show) 78 | 79 | getFtClass :: FieldType -> Text 80 | getFtClass (ObjectType (IClassName t)) = t 81 | getFtClass ft@(ArrayType _) = mkFieldDesc' ft 82 | getFtClass ft = error $ "getFtClass: " ++ show ft ++ " is not object type!" 83 | 84 | isCategory2 :: FieldType -> Bool 85 | isCategory2 (BaseType JLong) = True 86 | isCategory2 (BaseType JDouble) = True 87 | isCategory2 _ = False 88 | 89 | isObjectFt :: FieldType -> Bool 90 | isObjectFt (ObjectType _) = True 91 | isObjectFt (ArrayType _) = True 92 | isObjectFt _ = False 93 | 94 | getArrayElemFt :: FieldType -> Maybe FieldType 95 | getArrayElemFt (ArrayType ft) = Just ft 96 | getArrayElemFt _ = Nothing 97 | 98 | mkFieldDesc :: FieldType -> FieldDesc 99 | mkFieldDesc ft = FieldDesc $ mkFieldDesc' ft where 100 | 101 | mkFieldDesc' :: FieldType -> Text 102 | mkFieldDesc' ft = case ft of 103 | BaseType JByte -> "B" 104 | BaseType JChar -> "C" 105 | BaseType JDouble -> "D" 106 | BaseType JFloat -> "F" 107 | BaseType JInt -> "I" 108 | BaseType JLong -> "J" 109 | BaseType JShort -> "S" 110 | BaseType JBool -> "Z" 111 | ObjectType (IClassName cn) -> objectWrap cn 112 | ArrayType ft' -> arrayWrap (mkFieldDesc' ft') 113 | 114 | decodeDesc :: Text -> Maybe (FieldType, Text) 115 | decodeDesc desc 116 | | Just (c, rest) <- Text.uncons desc 117 | , let base x = Just (BaseType x, rest) 118 | = case c of 119 | 'B' -> base JByte 120 | 'C' -> base JChar 121 | 'D' -> base JDouble 122 | 'F' -> base JFloat 123 | 'I' -> base JInt 124 | 'J' -> base JLong 125 | 'S' -> base JShort 126 | 'Z' -> base JBool 127 | '[' -> case decodeDesc rest of 128 | Just (ft, rest') -> Just (ArrayType ft, rest') 129 | Nothing -> Nothing 130 | 'L' -> case Text.span (/= ';') rest of 131 | (clsName, rest') -> Just (ObjectType (IClassName clsName), Text.drop 1 rest') 132 | _ -> Nothing 133 | | otherwise = Nothing 134 | 135 | decodeFieldDesc :: Text -> Maybe FieldType 136 | decodeFieldDesc desc 137 | | Just (ft, rest)<- decodeDesc desc 138 | , Text.null rest 139 | = Just ft 140 | | otherwise = Nothing 141 | 142 | arrayWrap :: Text -> Text 143 | arrayWrap = Text.append "[" 144 | 145 | objectWrap :: Text -> Text 146 | objectWrap x = Text.concat ["L", x, ";"] 147 | 148 | fieldSize :: FieldType -> Int 149 | fieldSize (BaseType JLong) = 2 150 | fieldSize (BaseType JDouble) = 2 151 | fieldSize _ = 1 152 | 153 | fieldByteSize :: FieldType -> Int 154 | fieldByteSize (BaseType JByte) = 1 155 | fieldByteSize (BaseType JChar) = 2 156 | fieldByteSize (BaseType JDouble) = 8 157 | fieldByteSize (BaseType JFloat) = 4 158 | fieldByteSize (BaseType JInt) = 4 159 | fieldByteSize (BaseType JLong) = 8 160 | fieldByteSize (BaseType JShort) = 2 161 | fieldByteSize (BaseType JBool) = 1 -- TODO: Is this correct? 162 | fieldByteSize _ = 4 -- TODO: Is this correct? 163 | 164 | prim :: PrimType -> FieldType 165 | prim = BaseType 166 | 167 | obj :: Text -> FieldType 168 | obj = ObjectType . IClassName 169 | 170 | arr :: FieldType -> FieldType 171 | arr = ArrayType 172 | 173 | data MethodType = MethodType [FieldType] ReturnType 174 | 175 | type ReturnType = Maybe FieldType 176 | 177 | void :: ReturnType 178 | void = Nothing 179 | 180 | ret :: FieldType -> ReturnType 181 | ret = Just 182 | 183 | -- | Method descriptor 184 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.3.3 185 | data MethodDesc = MethodDesc Text 186 | deriving (Eq, Ord, Show) 187 | 188 | mkMethodDesc :: [FieldType] -> ReturnType -> MethodDesc 189 | mkMethodDesc fts rt = MethodDesc (mkMethodDesc' fts rt) 190 | 191 | mkMethodDesc' :: [FieldType] -> ReturnType -> Text 192 | mkMethodDesc' fts rt = Text.concat ["(", args, ")", result] where 193 | args = Text.concat $ mkFieldDesc' <$> fts 194 | result = maybe "V" mkFieldDesc' rt 195 | 196 | decodeMethodDesc :: Text -> Maybe ([FieldType], ReturnType) 197 | decodeMethodDesc desc 198 | | Just ('(', rest) <- Text.uncons desc 199 | , (inside, outside') <- Text.span (/= ')') rest 200 | , let outside = Text.drop 1 outside' 201 | = let retType = case Text.uncons outside of 202 | Just ('V', rest') 203 | | Text.null rest' -> Just Nothing 204 | | otherwise -> Nothing 205 | _ -> case decodeDesc outside of 206 | Just (ft, rest') -> if Text.null rest' then Just (Just ft) else Nothing 207 | _ -> Nothing 208 | in do 209 | a <- argTypes inside [] 210 | b <- retType 211 | return (a,b) 212 | | otherwise = Nothing --error $ "decodeMethodDesc: Bad desc: " ++ Text.unpack desc 213 | where argTypes text fts 214 | | Text.null text = Just $ reverse fts 215 | | Just (ft, rest') <- decodeDesc text = argTypes rest' (ft:fts) 216 | | otherwise = Nothing 217 | 218 | -- | Field or method reference 219 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.4.2 220 | 221 | data FieldRef = FieldRef IClassName UName FieldType 222 | deriving (Eq, Ord, Show) 223 | 224 | mkFieldRef :: Text -> Text -> FieldType -> FieldRef 225 | mkFieldRef cn un ft = FieldRef (IClassName cn) (UName un) ft 226 | 227 | data MethodRef = MethodRef IClassName UName [FieldType] ReturnType 228 | deriving (Eq, Ord, Show) 229 | 230 | mkMethodRef :: Text -> Text -> [FieldType] -> ReturnType -> MethodRef 231 | mkMethodRef cn un fts rt = MethodRef (IClassName cn) (UName un) fts rt 232 | 233 | data NameAndDesc = NameAndDesc UName Desc 234 | deriving (Eq, Ord, Show) 235 | 236 | -- | Field or method descriptor 237 | newtype Desc = Desc Text 238 | deriving (Eq, Ord, Show) 239 | 240 | data Version = Version 241 | { versionMaj :: Int 242 | , versionMin :: Int } 243 | deriving (Eq, Ord, Show) 244 | 245 | java8 :: Version 246 | java8 = Version 52 0 247 | 248 | java7 :: Version 249 | java7 = Version 51 0 250 | 251 | -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.6-200-A.1 252 | data AccessFlag 253 | = Public 254 | | Private 255 | | Protected 256 | | Static 257 | | Final 258 | | Super 259 | | Synchronized 260 | | Volatile 261 | | Bridge 262 | | VarArgs 263 | | Transient 264 | | Native 265 | | Interface 266 | | Abstract 267 | | Strict 268 | | Synthetic 269 | | Annotation 270 | | Enum 271 | deriving (Eq, Ord, Show, Enum) 272 | 273 | data AccessType 274 | = ATClass 275 | | ATMethod 276 | | ATField 277 | | ATInnerClass 278 | | ATMethodParam 279 | deriving (Eq, Ord, Show) 280 | 281 | accessFlagValue :: AccessFlag -> Word16 282 | accessFlagValue Public = 0x0001 283 | accessFlagValue Private = 0x0002 284 | accessFlagValue Protected = 0x0004 285 | accessFlagValue Static = 0x0008 286 | accessFlagValue Final = 0x0010 287 | accessFlagValue Super = 0x0020 288 | accessFlagValue Synchronized = 0x0020 289 | accessFlagValue Volatile = 0x0040 290 | accessFlagValue Bridge = 0x0040 291 | accessFlagValue VarArgs = 0x0080 292 | accessFlagValue Transient = 0x0080 293 | accessFlagValue Native = 0x0100 294 | accessFlagValue Interface = 0x0200 295 | accessFlagValue Abstract = 0x0400 296 | accessFlagValue Strict = 0x0800 297 | accessFlagValue Synthetic = 0x1000 298 | accessFlagValue Annotation = 0x2000 299 | accessFlagValue Enum = 0x4000 300 | 301 | putAccessFlags :: Set AccessFlag -> Put 302 | putAccessFlags accessFlags = putWord16be $ sum (accessFlagValue <$> (S.toList accessFlags)) 303 | 304 | getAccessFlags :: AccessType -> Get (Set AccessFlag) 305 | getAccessFlags at = do 306 | mask <- getWord16be 307 | return $ S.fromList $ accessFlagsFromBitmask at mask 308 | 309 | accessFlagsFromBitmask :: AccessType -> Word16 -> [AccessFlag] 310 | accessFlagsFromBitmask at mask = 311 | mapMaybe (\(i, af) -> if testBit mask i 312 | then Just af 313 | else Nothing) accessFlagMap 314 | where removeFlags = case at of 315 | ATField -> [Super, Bridge, VarArgs] 316 | ATMethod -> [Super, Volatile, Transient] 317 | _ -> [Synchronized, Bridge, Transient] -- Bridge and Transient are arbitrary choices 318 | accessFlagMap = zip [0..] $ [Public ..] \\ removeFlags 319 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-6.27 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | --------------------------------------------------------------------------------